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 .&&.
     not (all (Chain.null . snd) finalChains) .&&.
     conjoin (map (hasAllEBBs k numSlots produceEBBs) finalChains)

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

@@ -84,6 +84,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

@@ -61,6 +61,7 @@ import qualified Codec.CBOR.Encoding as CBOR
 import qualified Codec.CBOR.Read as CBOR
 import qualified Codec.CBOR.Write as CBOR
 import           Codec.Serialise (Serialise (..), serialise)
+import           Control.Monad (guard)
 import           Control.Monad.Except
 import qualified Data.Binary.Get as Get
 import qualified Data.Binary.Put as Put
@@ -330,8 +331,22 @@ instance MockProtocolSpecific c ext => ApplyTx (SimpleBlock c ext) where
 
   type ApplyTxErr (SimpleBlock c ext) = MockError (SimpleBlock c ext)
 
-  applyTx   = const updateSimpleUTxO
-  reapplyTx = const updateSimpleUTxO
+  applyTx           = reapplyTx
+  reapplyTx _ tx tl =
+      case hasExpired of
+        Just e  -> throwError e
+        Nothing -> updateSimpleUTxO tx tl
+    where
+      hasExpired :: Maybe (MockError blk)
+      hasExpired = case expiry of
+          Mock.DoNotExpire       -> Nothing
+          Mock.ExpireAtOnsetOf s -> do
+            guard $ s <= tickedSlotNo
+            Just $ MockExpired s tickedSlotNo
+        where
+          TickedLedgerState{tickedSlotNo} = tl
+          SimpleGenTx{simpleGenTx}        = tx
+          Mock.Tx expiry _ins _outs       = simpleGenTx
 
 instance HasTxId (GenTx (SimpleBlock c ext)) where
   newtype TxId (GenTx (SimpleBlock c ext)) = SimpleGenTxId

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

@@ -25,7 +25,7 @@ import           Cardano.Crypto.Hash
 import           Cardano.Prelude (NoUnexpectedThunks)
 
 import           Ouroboros.Network.Block (ChainHash, HasHeader, HeaderHash,
-                     Point, StandardHash, genesisPoint, pointHash)
+                     Point, SlotNo, StandardHash, genesisPoint, pointHash)
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Mock.Ledger.Address
@@ -45,7 +45,11 @@ data MockState blk = MockState {
 deriving instance Serialise (HeaderHash blk) => Serialise (MockState blk)
 
 data MockError blk =
-    MockUtxoError UtxoError
+    -- | The block expired in the first 'SlotNo', and it failed to validate
+    -- against a 'Ouroboros.Consensus.Ledger.Abstract.TickedLedgerState'
+    -- carrying the second 'SlotNo'.
+    MockExpired !SlotNo !SlotNo
+  | MockUtxoError UtxoError
   | MockInvalidHash (ChainHash blk) (ChainHash blk)
   deriving (Generic, NoUnexpectedThunks)
 

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

@@ -15,6 +15,7 @@ module Ouroboros.Consensus.Mock.Ledger.UTxO (
   , Amount
   , Ix
   , Utxo
+  , Expiry (..)
     -- * Computing UTxO
   , UtxoError(..)
   , HasUtxo(..)
@@ -38,6 +39,7 @@ 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
@@ -50,22 +52,31 @@ import           Ouroboros.Consensus.Mock.Ledger.Address
   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
@@ -100,8 +111,8 @@ class HasUtxo a where
 -------------------------------------------------------------------------------}
 
 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)
@@ -143,7 +154,8 @@ instance HasUtxo a => HasUtxo (Chain a) where
 
 -- | 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
 

ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/BFT.hs

@@ -1,22 +1,25 @@
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NamedFieldPuns   #-}
 
 module Test.ThreadNet.BFT (
     tests
   ) where
 
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
+
 import           Test.QuickCheck
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
 import           Cardano.Slotting.Slot
 
+import           Ouroboros.Network.Block (SlotNo (..))
+
 import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.BlockchainTime.Mock
 import           Ouroboros.Consensus.Mock.Ledger
 import           Ouroboros.Consensus.Mock.Node ()
 import           Ouroboros.Consensus.Mock.Node.BFT
-import           Ouroboros.Consensus.Node.ProtocolInfo
+import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
 import           Ouroboros.Consensus.NodeId
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Util.Random (Seed (..))
@@ -27,11 +30,12 @@ import           Test.ThreadNet.Util
 import           Test.ThreadNet.Util.NodeJoinPlan
 import           Test.ThreadNet.Util.NodeRestarts
 import           Test.ThreadNet.Util.NodeTopology
+import           Test.ThreadNet.Util.SimpleBlock
 
 import           Test.Util.Orphans.Arbitrary ()
 
 tests :: TestTree
-tests = testGroup "BFT"
+tests = testGroup "BFT" $
     [ testProperty "delayed message corner case" $
         once $
         let ncn = NumCoreNodes 2 in
@@ -44,11 +48,30 @@ tests = testGroup "BFT"
           , slotLengths = singletonSlotLengths (slotLengthFromSec 1)
           , initSeed = Seed {getSeed = (12659702313441544615,9326820694273232011,15820857683988100572,2201554969601311572,4716411940989238571)}
           }
-    ,
-      testProperty "simple convergence" $ \tc ->
+    , testProperty "Mock.applyChainTick is not a no-op" $
+        -- This repro failed via on a wip branch that included a fix for Issue
+        -- 1489 and but not for Issue 1559. PR 1562 fixed it. We're retaining
+        -- this as a regression test.
+        once $
+        let ncn = NumCoreNodes 3 in
+        prop_simple_bft_convergence (SecurityParam 5)
+        TestConfig
+          { numCoreNodes = ncn
+          , numSlots     = NumSlots 7
+          , nodeJoinPlan = NodeJoinPlan $ Map.fromList [(CoreNodeId 0, SlotNo 0),(CoreNodeId 1, SlotNo 2),(CoreNodeId 2, SlotNo 2)]
+          , nodeRestarts = noRestarts
+          , nodeTopology = meshNodeTopology ncn
+          , slotLengths  = defaultSlotLengths
+          , initSeed     = Seed (6358650144370660550,17563794202468751585,17692838336641672274,12649320068211251815,18441126729279419067)
+          }
+    , testProperty "simple convergence" $ \tc ->
+        -- TODO k > 1 as a workaround for Issue #1511.
+        --
         forAll (SecurityParam <$> elements [2 .. 10]) $ \k ->
         prop_simple_bft_convergence k tc
     ]
+  where
+    defaultSlotLengths = singletonSlotLengths $ slotLengthFromSec 1
 
 prop_simple_bft_convergence :: SecurityParam
                             -> TestConfig
@@ -64,6 +87,7 @@ prop_simple_bft_convergence k
         Nothing
         (const False)
         0
+        prop_validSimpleBlock
         testOutput
   where
     testOutput =

ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/LeaderSchedule.hs

@@ -35,6 +35,7 @@ import           Test.ThreadNet.Util.HasCreator.Mock ()
 import           Test.ThreadNet.Util.NodeJoinPlan
 import           Test.ThreadNet.Util.NodeRestarts
 import           Test.ThreadNet.Util.NodeTopology
+import           Test.ThreadNet.Util.SimpleBlock
 
 import           Test.Util.Orphans.Arbitrary ()
 
@@ -98,6 +99,7 @@ prop_simple_leader_schedule_convergence
       Nothing
       (const False)
       0
+      prop_validSimpleBlock
       testOutput
   where
     testOutput@TestOutput{testOutputNodes} =

ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/PBFT.hs

@@ -40,6 +40,7 @@ import           Test.ThreadNet.Util.HasCreator.Mock ()
 import           Test.ThreadNet.Util.NodeJoinPlan
 import           Test.ThreadNet.Util.NodeRestarts
 import           Test.ThreadNet.Util.NodeTopology
+import           Test.ThreadNet.Util.SimpleBlock
 
 import           Test.Util.Orphans.Arbitrary ()
 
@@ -87,6 +88,7 @@ prop_simple_pbft_convergence
            _            -> 0)
         (expectedBlockRejection numCoreNodes)
         0
+        prop_validSimpleBlock
         testOutput
   where
     NumCoreNodes nn = numCoreNodes

ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Praos.hs

@@ -29,6 +29,7 @@ import           Test.ThreadNet.Util.HasCreator.Mock ()
 import           Test.ThreadNet.Util.NodeJoinPlan
 import           Test.ThreadNet.Util.NodeRestarts
 import           Test.ThreadNet.Util.NodeTopology
+import           Test.ThreadNet.Util.SimpleBlock
 
 import           Test.Util.Orphans.Arbitrary ()
 
@@ -102,6 +103,7 @@ prop_simple_praos_convergence
       Nothing
       (const False)
       0
+      prop_validSimpleBlock
       testOutput
   where
     testOutput@TestOutput{testOutputNodes} =

ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/TxGen/Mock.hs

@@ -8,6 +8,8 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import           GHC.Stack (HasCallStack)
 
+import           Ouroboros.Network.Block (SlotNo (..))
+
 import           Ouroboros.Consensus.Mock.Ledger
 import           Ouroboros.Consensus.Util.Random
 
@@ -18,17 +20,17 @@ import           Test.ThreadNet.TxGen
 -------------------------------------------------------------------------------}
 
 instance TxGen (SimpleBlock SimpleMockCrypto ext) where
-  testGenTx numCoreNodes _curSlotNo _cfg ledgerState =
-      mkSimpleGenTx <$> genSimpleTx addrs utxo
+  testGenTx numCoreNodes curSlotNo _cfg ledgerState =
+      mkSimpleGenTx <$> genSimpleTx curSlotNo addrs utxo
     where
       addrs :: [Addr]
       addrs = Map.keys $ mkAddrDist numCoreNodes
 
       utxo :: Utxo
       utxo = mockUtxo $ simpleLedgerState ledgerState
 
-genSimpleTx :: forall m. MonadRandom m => [Addr] -> Utxo -> m Tx
-genSimpleTx addrs u = do
+genSimpleTx :: forall m. MonadRandom m => SlotNo -> [Addr] -> Utxo -> m Tx
+genSimpleTx curSlotNo addrs u = do
     let senders = Set.toList . Set.fromList . map fst . Map.elems $ u -- people with funds
     sender    <- genElt senders
     recipient <- genElt $ filter (/= sender) addrs
@@ -40,8 +42,12 @@ genSimpleTx addrs u = do
         outs         = if amount == fortune
             then [outRecipient]
             else [outRecipient, (sender, fortune - amount)]
-    return $ Tx ins outs
+    expiry <- (mkExpiry . SlotNo . fromIntegral) <$> generateBetween 2 10
+    return $ Tx expiry ins outs
   where
+    mkExpiry :: SlotNo -> Expiry
+    mkExpiry delta = ExpireAtOnsetOf $ curSlotNo + delta
+
     genElt :: HasCallStack => [a] -> m a
     genElt xs = do
         m <- generateElement xs

ouroboros-consensus/ouroboros-consensus-mock/test/Test/ThreadNet/Util/SimpleBlock.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Test.ThreadNet.Util.SimpleBlock (
+  prop_validSimpleBlock,
+  ) where
+
+import           Test.QuickCheck
+
+import           Ouroboros.Network.Block (HasHeader, SlotNo (..), blockSlot)
+
+import           Ouroboros.Consensus.Mock.Ledger
+import           Ouroboros.Consensus.Util.Condense (condense)
+
+prop_validSimpleBlock
+  :: HasHeader (SimpleBlock' c ext ext')
+  => SimpleBlock' c ext ext' -> Property
+prop_validSimpleBlock blk = conjoin $ map each $ simpleTxs $ simpleBody blk
+  where
+    now :: SlotNo
+    now = blockSlot blk
+
+    msg :: String
+    msg = "block contains expired transaction:"
+
+    each :: Tx -> Property
+    each tx@(Tx expiry _ins _outs) =
+      counterexample (msg <> " " <> condense (now, tx)) $
+      case expiry of
+        DoNotExpire       -> True
+        ExpireAtOnsetOf s -> now < s