PAB: improve consistent slot config through several components

Author: kk-hainq

plutus-contract/src/Wallet/Emulator/Chain.hs

@@ -95,15 +95,15 @@ getCurrentSlot = send GetCurrentSlot
 
 type ChainEffs = '[State ChainState, LogMsg ChainEvent]
 
-handleControlChain :: Members ChainEffs effs => ChainControlEffect ~> Eff effs
-handleControlChain = \case
+handleControlChain :: Members ChainEffs effs => SlotConfig -> ChainControlEffect ~> Eff effs
+handleControlChain slotCfg = \case
     ProcessBlock -> do
         st <- get
         let pool  = st ^. txPool
             slot  = st ^. currentSlot
             idx   = st ^. index
             ValidatedBlock block events rest =
-                validateBlock slot idx pool
+                validateBlock slotCfg slot idx pool
 
         let st' = st & txPool .~ rest
                      & addBlock block
@@ -140,16 +140,16 @@ data ValidatedBlock = ValidatedBlock
 -- | Validate a block given the current slot and UTxO index, returning the valid
 --   transactions, success/failure events, remaining transactions and the
 --   updated UTxO set.
-validateBlock :: Slot -> Index.UtxoIndex -> [Tx] -> ValidatedBlock
-validateBlock slot@(Slot s) idx txns =
+validateBlock :: SlotConfig -> Slot -> Index.UtxoIndex -> [Tx] -> ValidatedBlock
+validateBlock slotCfg slot@(Slot s) idx txns =
     let
         -- Select those transactions that can be validated in the
         -- current slot
         (eligibleTxns, rest) = partition (canValidateNow slot) txns
 
         -- Validate eligible transactions, updating the UTXO index each time
         processed =
-            flip S.evalState idx $ for eligibleTxns $ \tx -> do
+            flip S.evalState (Index.ValidationCtx idx slotCfg) $ for eligibleTxns $ \tx -> do
                 (err, events_) <- validateEm slot tx
                 pure (tx, err, events_)
 
@@ -179,11 +179,11 @@ mkValidationEvent t result events =
         Just (phase, err) -> TxnValidationFail phase (txId t) t err events
 
 -- | Validate a transaction in the current emulator state.
-validateEm :: S.MonadState Index.UtxoIndex m => Slot -> Tx -> m (Maybe Index.ValidationErrorInPhase, [ScriptValidationEvent])
+validateEm :: S.MonadState Index.ValidationCtx m => Slot -> Tx -> m (Maybe Index.ValidationErrorInPhase, [ScriptValidationEvent])
 validateEm h txn = do
-    idx <- S.get
-    let ((e, idx'), events) = Index.runValidation (Index.validateTransaction h txn) idx
-    _ <- S.put idx'
+    ctx <- S.get
+    let ((e, idx'), events) = Index.runValidation (Index.validateTransaction h txn) ctx
+    _ <- S.put ctx{Index.vctxIndex=idx'}
     pure (e, events)
 
 -- | Adds a block to ChainState, without validation.

plutus-contract/src/Wallet/Emulator/Types.hs

@@ -106,6 +106,6 @@ processEmulated slotCfg feeCfg act =
         & reinterpret2 @ChainEffect @(State ChainState) @(LogMsg ChainEvent) (handleChain slotCfg)
         & interpret (Eff.handleZoomedState chainState)
         & interpret (mapLog (review chainEvent))
-        & reinterpret2 @ChainControlEffect @(State ChainState) @(LogMsg ChainEvent) handleControlChain
+        & reinterpret2 @ChainControlEffect @(State ChainState) @(LogMsg ChainEvent) (handleControlChain slotCfg)
         & interpret (Eff.handleZoomedState chainState)
         & interpret (mapLog (review chainEvent))

plutus-contract/src/Wallet/Emulator/Wallet.hs

@@ -51,7 +51,7 @@ import Ledger.Constraints.OffChain (UnbalancedTx (..))
 import Ledger.Constraints.OffChain qualified as U
 import Ledger.Credential (Credential (..))
 import Ledger.Fee (FeeConfig (..), calcFees)
-import Ledger.TimeSlot (posixTimeRangeToContainedSlotRange)
+import Ledger.TimeSlot (SlotConfig, posixTimeRangeToContainedSlotRange)
 import Ledger.Tx qualified as Tx
 import Ledger.Value qualified as Value
 import Plutus.ChainIndex (PageQuery)
@@ -210,7 +210,7 @@ handleWallet feeCfg = \case
         slotConfig <- WAPI.getClientSlotConfig
         let validitySlotRange = posixTimeRangeToContainedSlotRange slotConfig (utx' ^. U.validityTimeRange)
         let utx = utx' & U.tx . validRange .~ validitySlotRange
-        utxWithFees <- validateTxAndAddFees feeCfg utxo utx
+        utxWithFees <- validateTxAndAddFees feeCfg slotConfig utxo utx
         -- balance to add fees
         tx' <- handleBalanceTx utxo (utx & U.tx . fee .~ (utxWithFees ^. U.tx . fee))
         tx'' <- handleAddSignature tx'
@@ -260,15 +260,16 @@ validateTxAndAddFees ::
     , Member (State WalletState) effs
     )
     => FeeConfig
+    -> SlotConfig
     -> Map.Map TxOutRef ChainIndexTxOut
     -> UnbalancedTx
     -> Eff effs UnbalancedTx
-validateTxAndAddFees feeCfg ownTxOuts utx = do
+validateTxAndAddFees feeCfg slotCfg ownTxOuts utx = do
     -- Balance and sign just for validation
     tx <- handleBalanceTx ownTxOuts utx
     signedTx <- handleAddSignature tx
     let utxoIndex        = Ledger.UtxoIndex $ unBalancedTxUtxoIndex utx <> (toTxOut <$> ownTxOuts)
-        ((e, _), events) = Ledger.runValidation (Ledger.validateTransactionOffChain signedTx) utxoIndex
+        ((e, _), events) = Ledger.runValidation (Ledger.validateTransactionOffChain signedTx) (Ledger.ValidationCtx utxoIndex slotCfg)
     for_ e $ \(phase, ve) -> do
         logWarn $ ValidationFailed phase (txId tx) tx ve events
         throwError $ WAPI.ValidationError ve

plutus-contract/test/Spec/Emulator.hs

@@ -116,7 +116,7 @@ pubKey3 = walletPubKeyHash wallet3
 
 utxo :: Property
 utxo = property $ do
-    Mockchain txPool o <- forAll Gen.genMockchain
+    Mockchain txPool o _ <- forAll Gen.genMockchain
     Hedgehog.assert (unspentOutputs [map Valid txPool] == o)
 
 txnValid :: Property
@@ -153,7 +153,7 @@ selectCoinProp = property $ do
 
 txnUpdateUtxo :: Property
 txnUpdateUtxo = property $ do
-    (Mockchain m _, txn) <- forAll genChainTxn
+    (Mockchain m _ _, txn) <- forAll genChainTxn
     let options = defaultCheckOptions & emulatorConfig . Trace.initialChainState .~ Right m
 
         -- submit the same txn twice, so it should be accepted the first time
@@ -173,14 +173,14 @@ txnUpdateUtxo = property $ do
 
 validTrace :: Property
 validTrace = property $ do
-    (Mockchain m _, txn) <- forAll genChainTxn
+    (Mockchain m _ _, txn) <- forAll genChainTxn
     let options = defaultCheckOptions & emulatorConfig . Trace.initialChainState .~ Right m
         trace = Trace.liftWallet wallet1 (submitTxn $ Right txn)
     checkPredicateInner options assertNoFailedTransactions trace Hedgehog.annotate Hedgehog.assert
 
 validTrace2 :: Property
 validTrace2 = property $ do
-    (Mockchain m _, txn) <- forAll genChainTxn
+    (Mockchain m _ _, txn) <- forAll genChainTxn
     let options = defaultCheckOptions & emulatorConfig . Trace.initialChainState .~ Right m
         trace = do
             Trace.liftWallet wallet1 (submitTxn $ Right txn)
@@ -190,7 +190,7 @@ validTrace2 = property $ do
 
 invalidTrace :: Property
 invalidTrace = property $ do
-    (Mockchain m _, txn) <- forAll genChainTxn
+    (Mockchain m _ _, txn) <- forAll genChainTxn
     let invalidTxn = txn { txMint = Ada.adaValueOf 1 }
         options = defaultCheckOptions & emulatorConfig . Trace.initialChainState .~ Right m
         trace = Trace.liftWallet wallet1 (submitTxn $ Right invalidTxn)
@@ -205,7 +205,7 @@ invalidTrace = property $ do
 
 invalidScript :: Property
 invalidScript = property $ do
-    (Mockchain m _, txn1) <- forAll genChainTxn
+    (Mockchain m _ _, txn1) <- forAll genChainTxn
 
     -- modify one of the outputs to be a script output
     index <- forAll $ Gen.int (Range.linear 0 ((length $ txOutputs txn1) -1))

plutus-ledger/src/Ledger/Generators.hs

@@ -114,12 +114,13 @@ constantFee = def { fcScriptsFeeFactor = 0 }
 --   unspent outputs of the chain when it is first created.
 data Mockchain = Mockchain {
     mockchainInitialTxPool :: [Tx],
-    mockchainUtxo          :: Map TxOutRef TxOut
+    mockchainUtxo          :: Map TxOutRef TxOut,
+    mockchainSlotConfig    :: SlotConfig
     } deriving Show
 
 -- | The empty mockchain.
 emptyChain :: Mockchain
-emptyChain = Mockchain [] Map.empty
+emptyChain = Mockchain [] Map.empty def
 
 -- | Generate a mockchain.
 --
@@ -130,9 +131,11 @@ genMockchain' :: MonadGen m
 genMockchain' gm = do
     let (txn, ot) = genInitialTransaction gm
         tid = txId txn
+    slotCfg <- genSlotConfig
     pure Mockchain {
         mockchainInitialTxPool = [txn],
-        mockchainUtxo = Map.fromList $ first (TxOutRef tid) <$> zip [0..] ot
+        mockchainUtxo = Map.fromList $ first (TxOutRef tid) <$> zip [0..] ot,
+        mockchainSlotConfig = slotCfg
         }
 
 -- | Generate a mockchain using the default 'GeneratorModel'.
@@ -171,7 +174,7 @@ genValidTransaction' :: MonadGen m
     -> FeeConfig
     -> Mockchain
     -> m Tx
-genValidTransaction' g feeCfg (Mockchain _ ops) = do
+genValidTransaction' g feeCfg (Mockchain _ ops _) = do
     -- Take a random number of UTXO from the input
     nUtxo <- if Map.null ops
                 then Gen.discard
@@ -350,10 +353,10 @@ assertValid tx mc = Hedgehog.assert $ isNothing $ validateMockchain mc tx
 
 -- | Validate a transaction in a mockchain.
 validateMockchain :: Mockchain -> Tx -> Maybe Index.ValidationError
-validateMockchain (Mockchain txPool _) tx = result where
+validateMockchain (Mockchain txPool _ slotCfg) tx = result where
     h      = 1
     idx    = Index.initialise [map Valid txPool]
-    result = fmap snd $ fst $ fst $ Index.runValidation (Index.validateTransaction h tx) idx
+    result = fmap snd $ fst $ fst $ Index.runValidation (Index.validateTransaction h tx) (ValidationCtx idx slotCfg)
 
 {- | Split a value into max. n positive-valued parts such that the sum of the
      parts equals the original value.
@@ -379,7 +382,8 @@ genTxInfo :: MonadGen m => Mockchain -> m TxInfo
 genTxInfo chain = do
     tx <- genValidTransaction chain
     let idx = UtxoIndex $ mockchainUtxo chain
-    let (res, _) = runWriter $ runExceptT $ runReaderT (_runValidation (Index.mkTxInfo tx)) idx
+    let slotCfg = mockchainSlotConfig chain
+    let (res, _) = runWriter $ runExceptT $ runReaderT (_runValidation (Index.mkTxInfo tx)) (ValidationCtx idx slotCfg)
     either (const Gen.discard) pure res
 
 genScriptPurposeSpending :: MonadGen m => TxInfo -> m Contexts.ScriptPurpose

plutus-ledger/src/Ledger/Index.hs

@@ -12,6 +12,7 @@
 module Ledger.Index(
     -- * Types for transaction validation based on UTXO index
     ValidationMonad,
+    ValidationCtx(..),
     UtxoIndex(..),
     insert,
     insertCollateral,
@@ -54,7 +55,6 @@ import Control.Monad.Except (ExceptT, MonadError (..), runExcept, runExceptT)
 import Control.Monad.Reader (MonadReader (..), ReaderT (..), ask)
 import Control.Monad.Writer (MonadWriter, Writer, runWriter, tell)
 import Data.Aeson (FromJSON, ToJSON)
-import Data.Default (Default (def))
 import Data.Foldable (asum, fold, foldl', traverse_)
 import Data.Map qualified as Map
 import Data.OpenApi.Schema qualified as OpenApi
@@ -86,7 +86,9 @@ import Prettyprinter.Extras (PrettyShow (..))
 
 -- | Context for validating transactions. We need access to the unspent
 --   transaction outputs of the blockchain, and we can throw 'ValidationError's.
-type ValidationMonad m = (MonadReader UtxoIndex m, MonadError ValidationError m, MonadWriter [ScriptValidationEvent] m)
+type ValidationMonad m = (MonadReader ValidationCtx m, MonadError ValidationError m, MonadWriter [ScriptValidationEvent] m)
+
+data ValidationCtx = ValidationCtx { vctxIndex :: UtxoIndex, vctxSlotConfig :: TimeSlot.SlotConfig }
 
 -- | The UTxOs of a blockchain indexed by their references.
 newtype UtxoIndex = UtxoIndex { getIndex :: Map.Map TxOutRef TxOut }
@@ -159,12 +161,12 @@ deriving via (PrettyShow ValidationPhase) instance Pretty ValidationPhase
 type ValidationErrorInPhase = (ValidationPhase, ValidationError)
 
 -- | A monad for running transaction validation inside, which is an instance of 'ValidationMonad'.
-newtype Validation a = Validation { _runValidation :: (ReaderT UtxoIndex (ExceptT ValidationError (Writer [ScriptValidationEvent]))) a }
-    deriving newtype (Functor, Applicative, Monad, MonadReader UtxoIndex, MonadError ValidationError, MonadWriter [ScriptValidationEvent])
+newtype Validation a = Validation { _runValidation :: (ReaderT ValidationCtx (ExceptT ValidationError (Writer [ScriptValidationEvent]))) a }
+    deriving newtype (Functor, Applicative, Monad, MonadReader ValidationCtx, MonadError ValidationError, MonadWriter [ScriptValidationEvent])
 
 -- | Run a 'Validation' on a 'UtxoIndex'.
-runValidation :: Validation (Maybe ValidationErrorInPhase, UtxoIndex) -> UtxoIndex -> ((Maybe ValidationErrorInPhase, UtxoIndex), [ScriptValidationEvent])
-runValidation l idx = runWriter $ fmap (either (\e -> (Just (Phase1, e), idx)) id) $ runExceptT $ runReaderT (_runValidation l) idx
+runValidation :: Validation (Maybe ValidationErrorInPhase, UtxoIndex) -> ValidationCtx -> ((Maybe ValidationErrorInPhase, UtxoIndex), [ScriptValidationEvent])
+runValidation l ctx = runWriter $ fmap (either (\e -> (Just (Phase1, e), vctxIndex ctx)) id) $ runExceptT $ runReaderT (_runValidation l) ctx
 
 -- | Determine the unspent value that a ''TxOutRef' refers to.
 lkpValue :: ValidationMonad m => TxOutRef -> m V.Value
@@ -174,7 +176,7 @@ lkpValue = fmap txOutValue . lkpTxOut
 --   output for this reference exists. If you want to handle the lookup error
 --   you can use 'runLookup'.
 lkpTxOut :: ValidationMonad m => TxOutRef -> m TxOut
-lkpTxOut t = lookup t =<< ask
+lkpTxOut t = lookup t . vctxIndex =<< ask
 
 -- | Validate a transaction in a 'ValidationMonad' context.
 validateTransaction :: ValidationMonad m
@@ -187,7 +189,7 @@ validateTransaction h t = do
     _ <- lkpOutputs $ toListOf (inputs . scriptTxIns) t
 
     -- see note [Minting of Ada]
-    emptyUtxoSet <- reader (Map.null . getIndex)
+    emptyUtxoSet <- reader (Map.null . getIndex . vctxIndex)
     unless emptyUtxoSet (checkTransactionFee t)
 
     validateTransactionOffChain t
@@ -201,7 +203,7 @@ validateTransactionOffChain t = do
     checkFeeIsAda t
 
     -- see note [Minting of Ada]
-    emptyUtxoSet <- reader (Map.null . getIndex)
+    emptyUtxoSet <- reader (Map.null . getIndex . vctxIndex)
     unless emptyUtxoSet (checkMintingAuthorised t)
 
     checkValidInputs (toListOf (inputs . pubKeyTxIns)) t
@@ -212,13 +214,13 @@ validateTransactionOffChain t = do
         checkValidInputs (toListOf (inputs . scriptTxIns)) t
         unless emptyUtxoSet (checkMintingScripts t)
 
-        idx <- ask
+        idx <- vctxIndex <$> ask
         pure (Nothing, insert t idx)
         )
     `catchError` payCollateral
     where
         payCollateral e = do
-            idx <- ask
+            idx <- vctxIndex <$> ask
             pure (Just (Phase2, e), insertCollateral t idx)
 
 -- | Check that a transaction can be validated in the given slot.
@@ -385,6 +387,7 @@ checkTransactionFee tx =
 -- | Create the data about the transaction which will be passed to a validator script.
 mkTxInfo :: ValidationMonad m => Tx -> m TxInfo
 mkTxInfo tx = do
+    slotCfg <- vctxSlotConfig <$> ask
     txins <- traverse mkIn $ Set.toList $ view inputs tx
     let ptx = TxInfo
             { txInfoInputs = txins
@@ -393,7 +396,7 @@ mkTxInfo tx = do
             , txInfoFee = txFee tx
             , txInfoDCert = [] -- DCerts not supported in emulator
             , txInfoWdrl = [] -- Withdrawals not supported in emulator
-            , txInfoValidRange = TimeSlot.slotRangeToPOSIXTimeRange def $ txValidRange tx
+            , txInfoValidRange = TimeSlot.slotRangeToPOSIXTimeRange slotCfg $ txValidRange tx
             , txInfoSignatories = fmap pubKeyHash $ Map.keys (tx ^. signatures)
             , txInfoData = Map.toList (tx ^. datumWitnesses)
             , txInfoId = txId tx

plutus-pab/src/Cardano/Chain.hs

@@ -83,15 +83,15 @@ handleControlChain ::
      , Member (LogMsg EC.ChainEvent) effs
      , LastMember m effs
      , MonadIO m )
-  => EC.ChainControlEffect ~> Eff effs
-handleControlChain = \case
+  => SlotConfig -> EC.ChainControlEffect ~> Eff effs
+handleControlChain slotCfg = \case
     EC.ProcessBlock -> do
         st <- get
         let pool  = st ^. txPool
             slot  = st ^. currentSlot
             idx   = st ^. index
             EC.ValidatedBlock block events rest =
-                EC.validateBlock slot idx pool
+                EC.validateBlock slotCfg slot idx pool
 
         let st' = st & txPool .~ rest
                      & tip    ?~ block

plutus-pab/src/Cardano/Node/Mock.hs

@@ -88,7 +88,7 @@ runChainEffects trace slotCfg clientHandler stateVar eff = do
             runChain = interpret (mapLog ProcessingChainEvent)
                      . reinterpret (handleChain slotCfg)
                      . interpret (mapLog ProcessingChainEvent)
-                     . reinterpret handleControlChain
+                     . reinterpret (handleControlChain slotCfg)
 
             mergeState = interpret (handleZoomedState chainState)
 

plutus-pab/src/Cardano/Node/Server.hs

@@ -67,7 +67,7 @@ main trace MockServerConfig { mscBaseUrl
             { _chainState = initialState
             , _eventHistory = mempty
             }
-    serverHandler <- liftIO $ Server.runServerNode trace mscSocketPath mscKeptBlocks (_chainState appState)
+    serverHandler <- liftIO $ Server.runServerNode trace mscSocketPath mscKeptBlocks (_chainState appState) mscSlotConfig
     serverState   <- liftIO $ newMVar appState
     handleDelayEffect $ delayThread (2 :: Second)
     clientHandler <- liftIO $ Client.runTxSender mscSocketPath