Add a Test.Util.HeaderValidation module

... which contains an `AddBogusTime` type class, which allows to add bogus times to headers. This type class and its instances are meant to be used in test code.
IntersectMBO · Nov 19, 2024 · 2b11f09 · 2b11f09
1 parent fdb333b
commit 2b11f09
Show file tree

Hide file tree

Showing 4 changed files with 55 additions and 11 deletions.
diff --git a/...consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs b/...consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs
@@ -60,6 +60,7 @@ import           Test.QuickCheck
 import           Test.QuickCheck.Extras (unsafeMapSuchThatJust)
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
+import           Test.Util.HeaderValidation (addBogusTimeToFragment)
 import           Test.Util.Orphans.IOLike ()
 import           Test.Util.PartialAccessors
 import           Test.Util.TersePrinting (terseHFragment, terseHeader)
@@ -94,11 +95,6 @@ data StaticCandidates =
   }
   deriving Show
 
-addTime ::
-     AnchoredFragment (Header TestBlock)
-  -> AnchoredFragment (HeaderWithTime TestBlock)
-addTime = undefined
-
 dropTime ::
      AnchoredFragment (HeaderWithTime blk)
   -> AnchoredFragment (Header blk)
@@ -123,7 +119,7 @@ staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} =
       }
       where
         (loeFrag, suffixes) =
-          sharedCandidatePrefix curChain (second (addTime . toHeaders) <$> candidates)
+          sharedCandidatePrefix curChain (second (addBogusTimeToFragment . toHeaders) <$> candidates)
 
     selections = selection <$> branches
 
@@ -144,7 +140,7 @@ staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} =
 prop_densityDisconnectStatic :: Property
 prop_densityDisconnectStatic =
   forAll gen $ \ StaticCandidates {k, sgen, suffixes, loeFrag} -> do
-    let (disconnect, _) = densityDisconnect sgen k (mkState <$> Map.fromList suffixes) (fmap (second addTime) suffixes) (addTime loeFrag)
+    let (disconnect, _) = densityDisconnect sgen k (mkState <$> Map.fromList suffixes) (fmap (second addBogusTimeToFragment) suffixes) (addBogusTimeToFragment loeFrag)
     counterexample "it should disconnect some node" (not (null disconnect))
       .&&.
      counterexample "it should not disconnect the honest peers"
@@ -153,7 +149,7 @@ prop_densityDisconnectStatic =
     mkState :: AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock
     mkState frag =
       ChainSyncState {
-        csCandidate = addTime frag,
+        csCandidate = addBogusTimeToFragment frag,
         csLatestSlot = SJust (AF.headSlot frag),
         csIdling = False
       }
@@ -388,12 +384,12 @@ evolveBranches EvolvingPeers {k, sgen, peers = initialPeers, fullTree} =
         states =
           candidates <&> \ csCandidate ->
             ChainSyncState {
-              csCandidate = addTime csCandidate,
+              csCandidate = addBogusTimeToFragment csCandidate,
               csIdling = False,
               csLatestSlot = SJust (AF.headSlot csCandidate)
             }
         -- Run GDD.
-        (loeFrag, suffixes) = sharedCandidatePrefix curChain (Map.toList $ fmap addTime candidates)
+        (loeFrag, suffixes) = sharedCandidatePrefix curChain (Map.toList $ fmap addBogusTimeToFragment candidates)
         (killedNow, bounds) = first Set.fromList $ densityDisconnect sgen k states suffixes loeFrag
         event = UpdateEvent {
           target,

diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -349,6 +349,7 @@ library unstable-consensus-testlib
     Test.Util.FileLock
     Test.Util.HardFork.Future
     Test.Util.HardFork.OracularClock
+    Test.Util.HeaderValidation
     Test.Util.InvertedMap
     Test.Util.LogicalClock
     Test.Util.MockChain
@@ -391,6 +392,7 @@ library unstable-consensus-testlib
     cardano-binary:testlib,
     cardano-crypto-class,
     cardano-prelude,
+    cardano-slotting,
     cardano-slotting:testlib,
     cardano-strict-containers,
     cborg,

diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HeaderValidation.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Test.Util.HeaderValidation (
+    -- * Bogus time
+    AddBogusTime
+  , addBogusTime
+  , addBogusTimeToFragment
+  ) where
+
+import           Cardano.Slotting.Time (RelativeTime (..))
+import           Data.Typeable (Typeable)
+import           Ouroboros.Consensus.Block (Header)
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
+import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+
+{-------------------------------------------------------------------------------
+  Bogus time
+-------------------------------------------------------------------------------}
+
+-- REVIEW: I'm not sure about the name of this type class, and how safe it is to use it in testing code. What if suddenly a test decides to rely on the header's time?
+class AddBogusTime blk where
+  addBogusTime ::
+       Header blk
+    -> HeaderWithTime blk
+
+-- REVIEW: I even wonder if this instance should be defined here and
+-- at all: there might be use cases in which the 'TestBlock's are used
+-- in tests that depend on the header having a meaningful time
+-- associated with them.
+--
+instance AddBogusTime blk where
+  addBogusTime testHeader = HeaderWithTime {
+      hwtHeader = testHeader
+    , hwtSlotRelativeTime = RelativeTime (error "Header time should not be used!")
+    }
+
+addBogusTimeToFragment :: (AF.HasHeader (Header blk), Typeable blk)
+  => AnchoredFragment (Header blk)
+  -> AnchoredFragment (HeaderWithTime blk)
+addBogusTimeToFragment = AF.mapAnchoredFragment addBogusTime
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
@@ -155,6 +155,8 @@ import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck (testProperty)
 import           Test.Util.ChainDB
 import           Test.Util.ChunkInfo
+import           Test.Util.HeaderValidation (AddBogusTime,
+                     addBogusTimeToFragment)
 import           Test.Util.Orphans.Arbitrary ()
 import           Test.Util.Orphans.ToExpr ()
 import           Test.Util.QuickCheck
@@ -330,6 +332,7 @@ type TestConstraints blk =
   , ConvertRawHash                    blk
   , HasHardForkHistory                blk
   , SerialiseDiskConstraints          blk
+  , AddBogusTime                      blk
   )
 
 deriving instance (TestConstraints blk, Eq   it, Eq   flr)
@@ -442,7 +445,7 @@ run env@ChainDBEnv { varDB, .. } cmd =
     updateLoE :: ChainDBState m blk -> AnchoredFragment blk -> m (Point blk)
     updateLoE ChainDBState { chainDB } frag = do
       let headersFrag = AF.mapAnchoredFragment getHeader frag
-      atomically $ writeTVar varLoEFragment headersFrag
+      atomically $ writeTVar varLoEFragment $ addBogusTimeToFragment headersFrag
       ChainDB.triggerChainSelection chainDB
       atomically $ getTipPoint chainDB