consensus: add optional expiry slot to Mock transactions

ouroboros-consensus-byron/test/Test/ThreadNet/DualPBFT.hs

@@ -89,6 +89,7 @@ prop_convergence setup = withMaxSuccess 10 $
          _            -> 0)
       (setupExpectedRejections setup)
       1
+      (const (property True))
       (setupTestOutput         setup)
   where
     cfg = setupConfig setup

ouroboros-consensus-byron/test/Test/ThreadNet/RealPBFT.hs

@@ -574,6 +574,7 @@ prop_simple_real_pbft_convergence produceEBBs k
            _            -> 0)
         (expectedBlockRejection k numCoreNodes nodeRestarts)
         1
+        (const (property True))
         testOutput .&&.
     prop_pvu .&&.
     not (all (Chain.null . snd) finalChains) .&&.

ouroboros-consensus/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal

@@ -31,6 +31,7 @@ library
                        Ouroboros.Consensus.Mock.Ledger.Forge
                        Ouroboros.Consensus.Mock.Ledger.Stake
                        Ouroboros.Consensus.Mock.Ledger.State
+                       Ouroboros.Consensus.Mock.Ledger.Ticked
                        Ouroboros.Consensus.Mock.Ledger.UTxO
                        Ouroboros.Consensus.Mock.Node
                        Ouroboros.Consensus.Mock.Node.Abstract
@@ -84,6 +85,7 @@ test-suite test
                        Test.ThreadNet.Praos
                        Test.ThreadNet.TxGen.Mock
                        Test.ThreadNet.Util.HasCreator.Mock
+                       Test.ThreadNet.Util.SimpleBlock
 
   build-depends:       base
                      , binary

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs

@@ -84,6 +84,7 @@ import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Mempool.API
 import           Ouroboros.Consensus.Mock.Ledger.Address
 import           Ouroboros.Consensus.Mock.Ledger.State
+import qualified Ouroboros.Consensus.Mock.Ledger.Ticked as Mock
 import qualified Ouroboros.Consensus.Mock.Ledger.UTxO as Mock
 import           Ouroboros.Consensus.Node.LedgerDerivedInfo
 import           Ouroboros.Consensus.Util ((.:))
@@ -224,13 +225,20 @@ instance Mock.HasUtxo (SimpleBlock' c ext ext') where
   txIns      = Mock.txIns      . simpleBody
   txOuts     = Mock.txOuts     . simpleBody
   confirmed  = Mock.confirmed  . simpleBody
-  updateUtxo = Mock.updateUtxo . simpleBody
+
+instance HasHeader (SimpleBlock' c ext ext')
+      => Mock.UpdUtxo (SimpleBlock' c ext ext') where
+  updateUtxo blk =
+      Mock.updateUtxo $ Mock.Ticked (blockSlot blk) (simpleBody blk)
 
 instance Mock.HasUtxo SimpleBody where
   txIns      = Mock.txIns      . simpleTxs
   txOuts     = Mock.txOuts     . simpleTxs
   confirmed  = Mock.confirmed  . simpleTxs
-  updateUtxo = Mock.updateUtxo . simpleTxs
+
+instance Mock.UpdUtxo (Mock.Ticked SimpleBody) where
+  updateUtxo (Mock.Ticked slot body) =
+      Mock.updateUtxo $ map (Mock.Ticked slot) (simpleTxs body)
 
 {-------------------------------------------------------------------------------
   Envelope validation
@@ -304,13 +312,14 @@ updateSimpleLedgerState :: (SimpleCrypto c, Typeable ext)
 updateSimpleLedgerState b (SimpleLedgerState st) =
     SimpleLedgerState <$> updateMockState b st
 
-updateSimpleUTxO :: Mock.HasUtxo a
+updateSimpleUTxO :: Mock.UpdUtxo (Mock.Ticked a)
                  => a
                  -> TickedLedgerState (SimpleBlock c ext)
                  -> Except (MockError (SimpleBlock c ext))
                            (TickedLedgerState (SimpleBlock c ext))
-updateSimpleUTxO b (TickedLedgerState slot (SimpleLedgerState st)) =
-    TickedLedgerState slot . SimpleLedgerState <$> updateMockUTxO b st
+updateSimpleUTxO tx (TickedLedgerState slot (SimpleLedgerState st)) =
+    TickedLedgerState slot . SimpleLedgerState <$>
+      updateMockUTxO (Mock.Ticked slot tx) st
 
 genesisSimpleLedgerState :: AddrDist -> LedgerState (SimpleBlock c ext)
 genesisSimpleLedgerState = SimpleLedgerState . genesisMockState
@@ -351,7 +360,10 @@ instance Mock.HasUtxo (GenTx (SimpleBlock p c)) where
   txIns      = Mock.txIns      . simpleGenTx
   txOuts     = Mock.txOuts     . simpleGenTx
   confirmed  = Mock.confirmed  . simpleGenTx
-  updateUtxo = Mock.updateUtxo . simpleGenTx
+
+instance Mock.UpdUtxo (Mock.Ticked (GenTx (SimpleBlock p c))) where
+  updateUtxo (Mock.Ticked slot tx) =
+      Mock.updateUtxo $ Mock.Ticked slot $ simpleGenTx tx
 
 instance Condense (GenTx (SimpleBlock p c)) where
     condense = condense . simpleGenTx

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/State.hs

@@ -56,7 +56,7 @@ deriving instance Serialise (HeaderHash blk) => Serialise (MockError blk)
 updateMockState :: ( GetHeader blk
                    , HasHeader (Header blk)
                    , StandardHash blk
-                   , HasUtxo blk
+                   , UpdUtxo blk
                    )
                 => blk
                 -> MockState blk
@@ -75,7 +75,7 @@ updateMockTip hdr (MockState u c t)
     | otherwise
     = throwError $ MockInvalidHash (headerPrevHash hdr) (pointHash t)
 
-updateMockUTxO :: HasUtxo a
+updateMockUTxO :: UpdUtxo a
                => a
                -> MockState blk
                -> Except (MockError blk) (MockState blk)

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Ticked.hs

@@ -0,0 +1,14 @@
+module Ouroboros.Consensus.Mock.Ledger.Ticked (
+  Ticked (..),
+  ) where
+
+import           Cardano.Slotting.Slot (SlotNo)
+
+-- | As 'Ouroboros.Consensus.Ledger.Abstract.TickedLedgerState', but
+-- generalizing the ledger state field to anything that has time-dependent
+-- meaning
+--
+data Ticked a = Ticked
+  { getTick   :: !SlotNo
+  , getTicked :: !a
+  }

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/UTxO.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE DerivingVia          #-}
+{-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE PatternSynonyms      #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -15,16 +16,19 @@ module Ouroboros.Consensus.Mock.Ledger.UTxO (
   , Amount
   , Ix
   , Utxo
+  , Expiry (..)
     -- * Computing UTxO
   , UtxoError(..)
   , HasUtxo(..)
+  , UpdUtxo(..)
     -- * Genesis
   , genesisTx
   , genesisUtxo
   ) where
 
 import           Codec.Serialise (Serialise (..))
 import           Control.DeepSeq (NFData (..), force)
+import           Control.Monad (guard)
 import           Control.Monad.Except
 import           Control.Monad.State
 import           Data.Functor (($>))
@@ -38,34 +42,45 @@ import           Cardano.Binary (ToCBOR (..))
 import           Cardano.Crypto.Hash
 import           Cardano.Prelude (NoUnexpectedThunks, UseIsNormalForm (..))
 
+import           Ouroboros.Network.Block (SlotNo)
 import           Ouroboros.Network.MockChain.Chain (Chain, toOldestFirst)
 
 import           Ouroboros.Consensus.Util
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.Orphans ()
 
 import           Ouroboros.Consensus.Mock.Ledger.Address
+import           Ouroboros.Consensus.Mock.Ledger.Ticked
 
 {-------------------------------------------------------------------------------
   Basic definitions
 -------------------------------------------------------------------------------}
 
-data Tx = UnsafeTx (Set TxIn) [TxOut]
+data Expiry
+  = DoNotExpire
+  | ExpireAtOnsetOf !SlotNo
+  deriving stock    (Show, Eq, Ord, Generic)
+  deriving anyclass (Serialise, NFData, NoUnexpectedThunks)
+
+instance Condense Expiry where
+  condense = show
+
+data Tx = UnsafeTx Expiry (Set TxIn) [TxOut]
   deriving stock    (Show, Eq, Ord, Generic)
   deriving anyclass (Serialise, NFData)
   deriving NoUnexpectedThunks via UseIsNormalForm Tx
 
-pattern Tx :: Set TxIn -> [TxOut] -> Tx
-pattern Tx ins outs <- UnsafeTx ins outs where
-  Tx ins outs = force $ UnsafeTx ins outs
+pattern Tx :: Expiry -> Set TxIn -> [TxOut] -> Tx
+pattern Tx expiry ins outs <- UnsafeTx expiry ins outs where
+  Tx expiry ins outs = force $ UnsafeTx expiry ins outs
 
 {-# COMPLETE Tx #-}
 
 instance ToCBOR Tx where
   toCBOR = encode
 
 instance Condense Tx where
-  condense (Tx ins outs) = condense (ins, outs)
+  condense (Tx expiry ins outs) = condense (expiry, ins, outs)
 
 type Ix     = Word
 type Amount = Word
@@ -79,7 +94,10 @@ type Utxo   = Map TxIn TxOut
 -------------------------------------------------------------------------------}
 
 data UtxoError
-  = MissingInput TxIn
+  = Expired !SlotNo !SlotNo
+    -- ^ The transaction expired in the first 'SlotNo', and it failed to
+    -- validate in the second 'SlotNo'.
+  | MissingInput TxIn
   | InputOutputMismatch
       Amount  -- ^ Input
       Amount  -- ^ Output
@@ -93,57 +111,81 @@ class HasUtxo a where
   txIns      :: a -> Set TxIn
   txOuts     :: a -> Utxo
   confirmed  :: a -> Set TxId
+
+class HasUtxo a => UpdUtxo a where
   updateUtxo :: a -> Utxo -> Except UtxoError Utxo
 
 {-------------------------------------------------------------------------------
   HasUtxo instances
 -------------------------------------------------------------------------------}
 
 instance HasUtxo Tx where
-  txIns     (Tx ins _outs) = ins
-  txOuts tx@(Tx _ins outs) =
+  txIns     (Tx _expiry ins _outs) = ins
+  txOuts tx@(Tx _expiry _ins outs) =
       Map.fromList $ zipWith aux [0..] outs
     where
       aux :: Ix -> TxOut -> (TxIn, TxOut)
       aux ix out = ((hash tx, ix), out)
 
   confirmed       = Set.singleton . hash
-  updateUtxo tx = execStateT $ do
-    -- Remove all inputs from the Utxo and calculate the sum of all the input
-    -- amounts
-    inputAmount <- fmap sum $ forM (Set.toList (txIns tx)) $ \txIn -> do
-      u <- get
-      case Map.updateLookupWithKey (\_ _ -> Nothing) txIn u of
-        (Nothing,              _)  -> throwError $ MissingInput txIn
-        (Just (_addr, amount), u') -> put u' $> amount
-
-    -- Check that the sum of the inputs is equal to the sum of the outputs
-    let outputAmount = sum $ map snd $ Map.elems $ txOuts tx
-    when (inputAmount /= outputAmount) $
-      throwError $ InputOutputMismatch inputAmount outputAmount
-
-    -- Add the outputs to the Utxo
-    modify (`Map.union` txOuts tx)
+
+instance HasUtxo a => HasUtxo (Ticked a) where
+  txIns     = txIns     . getTicked
+  txOuts    = txOuts    . getTicked
+  confirmed = confirmed . getTicked
+
+instance UpdUtxo (Ticked Tx) where
+  updateUtxo (Ticked now tx) utxo = case hasExpired of
+      Just e  -> throwError e
+      Nothing -> flip execStateT utxo $ do
+          -- Remove all inputs from the Utxo and calculate the sum of all the
+          -- input amounts
+          inputAmount <- fmap sum $ forM (Set.toList (txIns tx)) $ \txIn -> do
+            u <- get
+            case Map.updateLookupWithKey (\_ _ -> Nothing) txIn u of
+              (Nothing,              _)  -> throwError $ MissingInput txIn
+              (Just (_addr, amount), u') -> put u' $> amount
+
+          -- Check that the sum of the inputs is equal to the sum of the
+          -- outputs
+          let outputAmount = sum $ map snd $ Map.elems $ txOuts tx
+          when (inputAmount /= outputAmount) $
+            throwError $ InputOutputMismatch inputAmount outputAmount
+
+          -- Add the outputs to the Utxo
+          modify (`Map.union` txOuts tx)
+    where
+      Tx expiry _ins _outs       = tx
+
+      hasExpired :: Maybe UtxoError
+      hasExpired = case expiry of
+          DoNotExpire       -> Nothing
+          ExpireAtOnsetOf s -> do
+            guard $ s <= now
+            Just $ Expired s now
+        where
 
 instance HasUtxo a => HasUtxo [a] where
   txIns      = foldr (Set.union . txIns)     Set.empty
   txOuts     = foldr (Map.union . txOuts)    Map.empty
   confirmed  = foldr (Set.union . confirmed) Set.empty
+
+instance UpdUtxo a => UpdUtxo [a] where
   updateUtxo = repeatedlyM updateUtxo
 
 instance HasUtxo a => HasUtxo (Chain a) where
-  txIns      = txIns      . toOldestFirst
-  txOuts     = txOuts     . toOldestFirst
-  updateUtxo = updateUtxo . toOldestFirst
-  confirmed  = confirmed  . toOldestFirst
+  txIns     = txIns     . toOldestFirst
+  txOuts    = txOuts    . toOldestFirst
+  confirmed = confirmed . toOldestFirst
 
 {-------------------------------------------------------------------------------
   Genesis
 -------------------------------------------------------------------------------}
 
 -- | Transaction giving initial stake to the nodes
 genesisTx :: AddrDist -> Tx
-genesisTx addrDist = Tx mempty [(addr, 1000) | addr <- Map.keys addrDist]
+genesisTx addrDist =
+    Tx DoNotExpire mempty [(addr, 1000) | addr <- Map.keys addrDist]
 
 genesisUtxo :: AddrDist -> Utxo
 genesisUtxo addrDist = txOuts (genesisTx addrDist)

ouroboros-consensus/ouroboros-consensus-mock/test/Test/Consensus/Ledger/Mock.hs

@@ -139,7 +139,7 @@ instance Arbitrary SimpleBody where
   arbitrary = SimpleBody <$> listOf arbitrary
 
 instance Arbitrary Tx where
-  arbitrary = Tx
+  arbitrary = Tx DoNotExpire
          <$> pure mempty  -- For simplicity
          <*> arbitrary