Plt 745 fix tx processing in emulator with regards to slot ranges (#679)

* Emulator : Don't filter txs that must be send to validation according to their validity range

* Fix the vesting contract

* Fix the crowdfunding contract tests

* Fix plutus playground for the new txPool management

* Document the slot vs POSIX time conversion

Author: berewt

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

@@ -21,12 +21,12 @@ import Control.Applicative ((<|>))
 import Control.Lens hiding (index)
 import Control.Monad.Freer
 import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logInfo, logWarn)
-import Control.Monad.Freer.State
+import Control.Monad.Freer.State (State, gets, modify)
 import Control.Monad.State qualified as S
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Either (fromRight)
 import Data.Foldable (traverse_)
-import Data.List (partition, (\\))
+import Data.List ((\\))
 import Data.Maybe (mapMaybe)
 import Data.Monoid (Ap (Ap))
 import Data.Traversable (for)
@@ -103,21 +103,20 @@ type ChainEffs = '[State ChainState, LogMsg ChainEvent]
 handleControlChain :: Members ChainEffs effs => Params -> ChainControlEffect ~> Eff effs
 handleControlChain params = \case
     ProcessBlock -> do
-        st <- get
-        let pool  = st ^. txPool
-            slot  = st ^. currentSlot
-            idx   = st ^. index
-            ValidatedBlock block events rest idx' =
-                validateBlock params slot idx pool
-
-        let st' = st & txPool .~ rest
-                     & index .~ idx'
-                     & addBlock block
-
-        put st'
-        traverse_ logEvent events
 
+        pool  <- gets $ view txPool
+        slot  <- gets $ view currentSlot
+        idx   <- gets $ view index
+
+        let ValidatedBlock block events idx' = validateBlock params slot idx pool
+
+        modify $ txPool .~ []
+        modify $ index .~ idx'
+        modify $ addBlock block
+
+        traverse_ logEvent events
         pure block
+
     ModifySlot f -> modify @ChainState (over currentSlot f) >> gets (view currentSlot)
 
 logEvent :: Member (LogMsg ChainEvent) effs => ChainEvent -> Eff effs ()
@@ -138,26 +137,18 @@ data ValidatedBlock = ValidatedBlock
     -- ^ The transactions that have been validated in this block.
     , vlbEvents :: [ChainEvent]
     -- ^ Transaction validation events for the transactions in this block.
-    , vlbRest   :: TxPool
-    -- ^ The transactions that haven't been validated because the current slot is
-    --   not in their validation interval.
     , vlbIndex  :: Index.UtxoIndex
     -- ^ The updated UTxO index after processing the block
     }
 
 -- | Validate a block given the current slot and UTxO index, returning the valid
---   transactions, success/failure events, remaining transactions and the
---   updated UTxO set.
+--   transactions, success/failure events and the updated UTxO set.
 validateBlock :: Params -> Slot -> Index.UtxoIndex -> TxPool -> ValidatedBlock
 validateBlock params 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
+        -- Validate transactions, updating the UTXO index each time
         (processed, Index.ValidationCtx idx' _) =
-            flip S.runState (Index.ValidationCtx idx params) $ for eligibleTxns $ \tx -> do
+            flip S.runState (Index.ValidationCtx idx params) $ for txns $ \tx -> do
                 (err, events_) <- validateEm slot cUtxoIndex tx
                 pure (tx, err, events_)
 
@@ -176,7 +167,7 @@ validateBlock params slot@(Slot s) idx txns =
 
         cUtxoIndex = either (error . show) id $ Validation.fromPlutusIndex params idx
 
-    in ValidatedBlock block events rest idx'
+    in ValidatedBlock block events idx'
 
 getCollateral :: Index.UtxoIndex -> CardanoTx -> Value
 getCollateral idx tx = fromRight (getCardanoTxFee tx) $

plutus-contract/test/Spec/Emulator.hs

@@ -57,7 +57,6 @@ tests = testGroup "all tests" [
     testGroup "UTXO model" [
         testProperty "compute UTxO of trivial blockchain" utxo,
         testProperty "validate transaction" txnValid,
-        testProperty "validate transaction when it can be validated" txnValidFrom,
         testProperty "update UTXO set after each transaction" txnUpdateUtxo
         ],
     testGroup "traces" [
@@ -127,22 +126,6 @@ txnValid = property $ do
     (m, txn) <- forAll genChainTxn
     Gen.assertValid txn m
 
-txnValidFrom :: Property
-txnValidFrom =
-    let five = Ada.adaValueOf 5
-        -- Set the validation interval to (5, 5] for the
-        -- transaction generated by payToPaymentPublicKeyHash_
-        -- so that the transaction can be validated only during slot 5
-        range = W.singleton 5
-
-    in checkPredicateGen Gen.generatorModel
-        (walletFundsChange wallet1 (P.negate five)
-        .&&. walletFundsChange wallet2 five
-        )
-        $ do
-            Trace.liftWallet wallet1 $ payToPaymentPublicKeyHash_ def range five pubKey2
-            void $ Trace.waitUntilSlot 6
-
 selectCoinProp :: Property
 selectCoinProp = property $ do
     inputs <- forAll $ zip [(1 :: Integer) ..] <$> Gen.list (Range.linear 1 100) Gen.genValueNonNegative

plutus-contract/test/Spec/TxConstraints/TimeValidity.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
@@ -13,6 +14,8 @@ import Data.Map qualified as Map
 import Data.Void (Void)
 import Test.Tasty (TestTree, testGroup)
 
+import Data.List (isSubsequenceOf)
+import Ledger (POSIXTimeRange)
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Constraints qualified as Constraints
@@ -48,6 +51,7 @@ tests = testGroup "time validitity constraint"
         -- , protocolV5Cardano
         , defaultProtocolParamsValidCardano
         , defaultProtocolParamsPastTxCardano
+        , defaultProtocolParamsFutureTxCardano
         ]
     ]
 
@@ -68,6 +72,7 @@ contract = do
             foldMap (\oref -> Constraints.mustSpendScriptOutput oref unitRedeemer) orefs
             <> Constraints.mustIncludeDatum unitDatum
             <> Constraints.mustValidateIn (from $ now + 1000)
+    void $ waitNSlots 2
     ledgerTx2 <- submitTxConstraintsWith @Void lookups2 tx2
     awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx2
     cSlot <- Con.currentPABSlot
@@ -104,8 +109,8 @@ traceCardano c = do
     void $ Trace.activateContractWallet w1 c
     void $ Trace.waitNSlots 4
 
-validContractCardano :: Ledger.Params -> Contract () Empty ContractError ()
-validContractCardano p = do
+contractCardano :: (POSIXTime -> POSIXTimeRange) -> Ledger.Params -> Contract () Empty ContractError ()
+contractCardano f p = do
     let mkTx lookups constraints = either (error . show) id $ Tx.Constraints.mkTx @UnitTest p lookups constraints
     pkh <- Con.ownFirstPaymentPubKeyHash
     utxos <- Con.ownUtxos
@@ -115,7 +120,8 @@ validContractCardano p = do
         lookups = Tx.Constraints.unspentOutputs utxos
         tx  =  Tx.Constraints.mustPayToPubKey pkh (Ada.toValue Ledger.minAdaTxOut)
             <> Tx.Constraints.mustSpendPubKeyOutput utxoRef
-            <> Tx.Constraints.mustValidateIn (from $ 1000 + now)
+            <> Tx.Constraints.mustValidateIn (f now)
+    void $ waitNSlots 2
     ledgerTx <- submitUnbalancedTx $ mkTx lookups tx
     awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx
 
@@ -126,34 +132,14 @@ validContractCardano p = do
 
     P.unless (cSlot `I.member` txRange) $ P.traceError "InvalidRange"
 
+validContractCardano :: Ledger.Params -> Contract () Empty ContractError ()
+validContractCardano = contractCardano $ from . (+ 1000)
 
 pastTxContractCardano :: Ledger.Params -> Contract () Empty ContractError ()
-pastTxContractCardano p = do
-    let mkTx lookups constraints = either (error . show) id $ Tx.Constraints.mkTx @UnitTest p lookups constraints
-    pkh <- Con.ownFirstPaymentPubKeyHash
-    utxos <- Con.ownUtxos
-    now <- Con.currentTime
-    logInfo @String $ "now: " ++ show now
-    let (utxoRef1, utxoRef2) = get2 $ map fst $ Map.toList utxos
-        lookups = Tx.Constraints.unspentOutputs utxos
-        tx1 =  Tx.Constraints.mustPayToPubKey pkh (Ada.toValue Ledger.minAdaTxOut)
-            <> Tx.Constraints.mustSpendPubKeyOutput utxoRef1
-        tx2 =  Tx.Constraints.mustPayToPubKey pkh (Ada.toValue Ledger.minAdaTxOut)
-            <> Tx.Constraints.mustSpendPubKeyOutput utxoRef2
-            <> Tx.Constraints.mustValidateIn (I.to now)
-    -- submit a first transaction to occupy the first slot
-    ledgerTx1 <- submitUnbalancedTx $ mkTx lookups tx1
-    awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1
-    -- submit a tx that should be validated at the latest in slot 1
-    ledgerTx2 <- submitUnbalancedTx $ mkTx lookups tx2
-    awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx2
+pastTxContractCardano = contractCardano I.to
 
-    cSlot <- Con.currentPABSlot
-    logInfo @String $ "Current slot: " ++ show cSlot
-    let txRange = Tx.getCardanoTxValidityRange ledgerTx1
-    logInfo @String $ show txRange
-
-    P.unless (cSlot `I.member` txRange) $ P.traceError "InvalidRange"
+futureTxContractCardano :: Ledger.Params -> Contract () Empty ContractError ()
+futureTxContractCardano = contractCardano $ from . (+ 4000)
 
 protocolV6Cardano :: TestTree
 protocolV6Cardano =
@@ -171,19 +157,29 @@ defaultProtocolParamsValidCardano = checkPredicateOptions
     (assertValidatedTransactionCount 1)
     (void $ traceCardano $ validContractCardano $ view (emulatorConfig . params) defaultCheckOptions)
 
--- We only test here if the contract rejects transactions with a time range uppper bound set before the
--- current slot.
--- We submit a first successful transaction to ensure that the validityRange of the second one is in the
--- past.
--- As the range of the second transaction is unreachable, the transaction should fail.
--- (it's unfortunately not the case at the moment, the tx is just postponed indefinitely).
+
+outsideValidityIntervalError :: Ledger.ValidationError -> Bool
+outsideValidityIntervalError = \case
+    Ledger.CardanoLedgerValidationError msg ->
+        "OutsideValidityIntervalUTxO" `isSubsequenceOf` msg
+    _ -> False
+
+-- | Past range are rejected
 defaultProtocolParamsPastTxCardano :: TestTree
 defaultProtocolParamsPastTxCardano = checkPredicateOptions
     defaultCheckOptions
     "tx valid time interval in the past make transactions fail"
-    (assertValidatedTransactionCount 1)
+    (assertFailedTransaction $ \_ err _ -> outsideValidityIntervalError err)
     (void $ traceCardano $ pastTxContractCardano $ view (emulatorConfig . params) defaultCheckOptions)
 
+-- | Future range are rejected
+defaultProtocolParamsFutureTxCardano :: TestTree
+defaultProtocolParamsFutureTxCardano = checkPredicateOptions
+    defaultCheckOptions
+    "tx valid time interval in the past make transactions fail"
+    (assertFailedTransaction $ \_ err _ -> outsideValidityIntervalError err)
+    (void $ traceCardano $ futureTxContractCardano $ view (emulatorConfig . params) defaultCheckOptions)
+
 deadline :: POSIXTime
 deadline = 1596059092000 -- (milliseconds) transaction's valid range must be after this
 

plutus-pab/src/Cardano/Chain.hs

@@ -17,7 +17,7 @@ import Control.Concurrent.STM
 import Control.Lens hiding (index)
 import Control.Monad.Freer
 import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logInfo, logWarn)
-import Control.Monad.Freer.State (State, get, gets, modify, put)
+import Control.Monad.Freer.State (State, gets, modify)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Foldable (traverse_)
 import Data.Functor (void)
@@ -85,21 +85,20 @@ handleControlChain ::
   => Params -> EC.ChainControlEffect ~> Eff effs
 handleControlChain params = \case
     EC.ProcessBlock -> do
-        st <- get
-        let pool  = st ^. txPool
-            slot  = st ^. currentSlot
-            idx   = st ^. index
-            EC.ValidatedBlock block events rest idx' =
-                EC.validateBlock params slot idx pool
-
-        let st' = st & txPool .~ rest
-                     & tip    ?~ block
-                     & index  .~ idx'
-
-        put st'
+        pool  <- gets $ view txPool
+        slot  <- gets $ view currentSlot
+        idx   <- gets $ view index
+        chan   <- gets $ view channel
+
+        let EC.ValidatedBlock block events idx' = EC.validateBlock params slot idx pool
+
+        modify $ txPool .~ []
+        modify $ tip    ?~ block
+        modify $ index  .~ idx'
+
         traverse_ logEvent events
 
-        liftIO $ atomically $ writeTChan (st ^. channel) block
+        liftIO $ atomically $ writeTChan chan block
         pure block
     EC.ModifySlot f -> modify @MockNodeServerChainState (over currentSlot f) >> gets (view currentSlot)
 

plutus-playground-server/usecases/Vesting.hs

@@ -176,12 +176,12 @@ retrieveFundsC
 retrieveFundsC vesting payment = do
     let inst = typedValidator vesting
         addr = Scripts.validatorAddress inst
-    nextTime <- awaitTime 0
+    now <- currentTime
     unspentOutputs <- utxosAt addr
     let
         currentlyLocked = foldMap (view Tx.ciTxOutValue) (Map.elems unspentOutputs)
         remainingValue = currentlyLocked - payment
-        mustRemainLocked = totalAmount vesting - availableAt vesting nextTime
+        mustRemainLocked = totalAmount vesting - availableAt vesting now
         maxPayment = currentlyLocked - mustRemainLocked
 
     when (remainingValue `Value.lt` mustRemainLocked)
@@ -202,11 +202,12 @@ retrieveFundsC vesting payment = do
                             Dead  -> mempty
         txn = Constraints.collectFromTheScript unspentOutputs ()
                 <> remainingOutputs
-                <> mustValidateIn (Interval.from nextTime)
+                <> mustValidateIn (Interval.from now)
                 <> mustBeSignedBy (vestingOwner vesting)
                 -- we don't need to add a pubkey output for 'vestingOwner' here
                 -- because this will be done by the wallet when it balances the
                 -- transaction.
+    void $ waitNSlots 1 -- wait until we reach a slot in the validity range
     mkTxConstraints (Constraints.plutusV1TypedValidatorLookups inst
                   <> Constraints.unspentOutputs unspentOutputs) txn
       >>= adjustUnbalancedTx >>= void . submitUnbalancedTx

plutus-use-cases/src/Plutus/Contracts/Vesting.hs

@@ -192,6 +192,15 @@ vestFundsC vesting = mapError (review _VestingError) $ do
 
 data Liveness = Alive | Dead
 
+{- Note [slots and POSIX time]
+ - A slot has a given duration. As a consequence, 'currentTime' does not return exactly the current time but,
+ - by convention, the last POSIX time of the current slot.
+ - A consequence to this design choice is that when we use this time to build the 'mustValidateIn constraints',
+ - we get a range that start at the slot after the current one.
+ - To be sure that the validity range is valid when the transaction will be validated by the pool, we must therefore
+ - wait the next slot before sumitting it (which is done using 'waitNSlots 1').
+ -
+ -}
 retrieveFundsC
     :: ( AsVestingError e
        )
@@ -201,12 +210,12 @@ retrieveFundsC
 retrieveFundsC vesting payment = mapError (review _VestingError) $ do
     let inst = typedValidator vesting
         addr = Scripts.validatorAddress inst
-    nextTime <- awaitTime 0
+    now <- currentTime
     unspentOutputs <- utxosAt addr
     let
         currentlyLocked = foldMap (view Tx.ciTxOutValue) (Map.elems unspentOutputs)
         remainingValue = currentlyLocked - payment
-        mustRemainLocked = totalAmount vesting - availableAt vesting nextTime
+        mustRemainLocked = totalAmount vesting - availableAt vesting now
         maxPayment = currentlyLocked - mustRemainLocked
 
     when (remainingValue `Value.lt` mustRemainLocked)
@@ -219,11 +228,12 @@ retrieveFundsC vesting payment = mapError (review _VestingError) $ do
                             Dead  -> mempty
         tx = Constraints.collectFromTheScript unspentOutputs ()
                 <> remainingOutputs
-                <> mustValidateIn (Interval.from nextTime)
+                <> mustValidateIn (Interval.from now)
                 <> mustBeSignedBy (vestingOwner vesting)
                 -- we don't need to add a pubkey output for 'vestingOwner' here
                 -- because this will be done by the wallet when it balances the
                 -- transaction.
+    void $ waitNSlots 1 -- see [slots and POSIX time]
     mkTxConstraints (Constraints.plutusV1TypedValidatorLookups inst
                   <> Constraints.unspentOutputs unspentOutputs) tx
       >>= adjustUnbalancedTx >>= void . submitUnbalancedTx

plutus-use-cases/test/Spec/Crowdfunding.hs

@@ -35,6 +35,7 @@ import Test.Tasty.Golden (goldenVsString)
 import Test.Tasty.HUnit qualified as HUnit
 import Test.Tasty.QuickCheck hiding ((.&&.))
 
+import Data.List (isSubsequenceOf)
 import Ledger (Value)
 import Ledger qualified
 import Ledger.Ada qualified as Ada
@@ -89,7 +90,12 @@ tests = testGroup "crowdfunding"
 
     , checkPredicate "cannot collect money too late"
         (walletFundsChange w1 PlutusTx.zero
-        .&&. assertNoFailedTransactions)
+        .&&. assertFailedTransaction (\_ err _ ->
+            case err of
+                Ledger.CardanoLedgerValidationError msg ->
+                    "OutsideValidityIntervalUTxO" `isSubsequenceOf` msg
+                _ -> False
+            ))
         $ do
             ContractHandle{chInstanceId} <- startCampaign
             makeContribution w2 (Ada.adaValueOf 10)