Generalize test machinery's reliance on TestBlock

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -92,6 +92,7 @@ library
     Ouroboros.Consensus.Byron.Protocol
     Ouroboros.Consensus.Cardano
     Ouroboros.Consensus.Cardano.Block
+    Ouroboros.Consensus.Cardano.IssueTestBlock
     Ouroboros.Consensus.Cardano.CanHardFork
     Ouroboros.Consensus.Cardano.Condense
     Ouroboros.Consensus.Cardano.Ledger
@@ -158,6 +159,10 @@ library
     mtl,
     nothunks,
     ouroboros-consensus ^>=0.27,
+    ouroboros-consensus-diffusion:unstable-consensus-conformance-testlib,
+    cardano-ledger-shelley-test,
+    cardano-ledger-binary:testlib,
+    cardano-ledger-core:{cardano-ledger-core, testlib},
     ouroboros-consensus-protocol ^>=0.12,
     ouroboros-network-api ^>=0.14,
     serialise ^>=0.2,

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/IssueTestBlock.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Ouroboros.Consensus.Cardano.IssueTestBlock () where
+
+import           Cardano.Crypto.Hash as Hash
+import           Cardano.Crypto.KES as KES
+import           Cardano.Ledger.BaseTypes
+import           Cardano.Ledger.Keys hiding (hashVerKeyVRF)
+import           Cardano.Ledger.Shelley.API hiding (hashVerKeyVRF)
+import           Cardano.Ledger.Shelley.Core
+import           Cardano.Protocol.Crypto
+import           Cardano.Protocol.TPraos.BHeader
+import           Cardano.Protocol.TPraos.OCert
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as M
+import           Data.Proxy
+import qualified Data.Sequence.Strict as StrictSeq
+import           Ouroboros.Consensus.Cardano.Block (CardanoBlock,
+                     pattern BlockShelley)
+import           Ouroboros.Consensus.Shelley.Eras
+import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock (..),
+                     ShelleyHash (..))
+import           Ouroboros.Consensus.Shelley.Protocol.TPraos ()
+import           Test.Cardano.Ledger.Binary.Random (mkDummyHash)
+import           Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
+import           Test.Cardano.Ledger.Shelley.Examples.Consensus
+import           Test.Cardano.Ledger.Shelley.Generator.Core
+import           Test.Cardano.Ledger.Shelley.Utils hiding (mkVRFKeyPair)
+import           Test.Consensus.Genesis.Setup.GenChains (IssueTestBlock (..))
+
+
+instance IssueTestBlock (CardanoBlock StandardCrypto) where
+  issueFirstBlock fork slot = makeCardanoBlock (Just fork) 0 slot Nothing
+  issueSuccessorBlock fork slot (BlockShelley (ShelleyBlock (Block (BHeader (BHBody {bheaderBlockNo}) _) _) (ShelleyHash hh))) =
+    makeCardanoBlock fork (bheaderBlockNo + 1) slot $ Just $ HashHeader hh
+  issueSuccessorBlock _ _ _ =
+    -- Impossible because we only ever produce 'BlockShelley' in
+    -- 'makeCardanoBlock'.
+    error "issueSuccessorBlock: impossible"
+
+
+-- | Construct a fake 'CardanoBlock' with all of its crypto intact.
+makeCardanoBlock
+  :: Maybe Int
+  -> BlockNo
+  -> SlotNo
+  -> Maybe HashHeader
+  -> CardanoBlock StandardCrypto
+makeCardanoBlock fork blockNo slot mhash = BlockShelley $
+  let blk =
+        shelleyLedgerBlock slot blockNo mhash
+          (exampleTx
+            (mkWitnessesPreAlonzo (Proxy @ShelleyEra))
+              exampleTxBodyShelley
+              $ forkToAuxData fork)
+    in ShelleyBlock blk $ ShelleyHash $ unHashHeader $ bhHash $ bheader blk
+
+
+-- | Construct a made-up (but believable) cardano block for the Shelley era.
+shelleyLedgerBlock ::
+  SlotNo ->
+  BlockNo ->
+  Maybe HashHeader ->
+  -- ^ The parent hash, if there is one.
+  Tx ShelleyEra ->
+  -- ^ Some transaction to stick in the block.
+  Block (BHeader StandardCrypto) ShelleyEra
+shelleyLedgerBlock slot blockNo prev tx = Block blockHeader blockBody
+  where
+    keys :: AllIssuerKeys StandardCrypto 'StakePool
+    keys = exampleKeys
+
+    hotKey = kesSignKey $ snd $ NE.head $ aikHot keys
+    KeyPair vKeyCold _ = aikCold keys
+
+    blockHeader :: BHeader StandardCrypto
+    blockHeader = BHeader blockHeaderBody (unsoundPureSignedKES () 0 blockHeaderBody hotKey)
+
+    blockHeaderBody :: BHBody StandardCrypto
+    blockHeaderBody =
+      BHBody
+        { bheaderBlockNo = blockNo
+        , bheaderSlotNo = slot
+        , bheaderPrev = maybe GenesisHash BlockHash prev
+        , bheaderVk = coerceKeyRole vKeyCold
+        , bheaderVrfVk = vrfVerKey $ aikVrf keys
+        , bheaderEta = mkCertifiedVRF (mkBytes 0) (vrfSignKey $ aikVrf keys)
+        , bheaderL = mkCertifiedVRF (mkBytes 1) (vrfSignKey $ aikVrf keys)
+        , bsize = 2345
+        , bhash = hashTxSeq blockBody
+        , bheaderOCert = mkOCert keys 0 (KESPeriod 0)
+        , bprotver = ProtVer (natVersion @2) 0
+        }
+
+    blockBody = toTxSeq @ShelleyEra (StrictSeq.fromList [tx])
+
+    mkBytes :: Int -> Cardano.Ledger.BaseTypes.Seed
+    mkBytes = Seed . mkDummyHash @Blake2b_256
+
+
+-- | We need to do something with our fork number to futz the resulting hash.
+-- So we stick it into the auxilliary data that gets attached to the block.
+forkToAuxData :: Maybe Int -> TxAuxData ShelleyEra
+forkToAuxData
+  = ShelleyTxAuxData
+  . foldMap (\i -> M.singleton 1 $ I $ fromIntegral i)
+

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree.hs

@@ -18,30 +18,29 @@ module Test.Consensus.BlockTree (
   , addBranch
   , addBranch'
   , allFragments
+  , deforestBlockTree
   , findFragment
   , findPath
+  , isAncestorOf
   , mkTrunk
-  , prettyBlockTree
-  , deforestBlockTree
   , nonemptyPrefixesOf
+  , prettyBlockTree
   ) where
 
-import           Cardano.Slotting.Slot (SlotNo (unSlotNo))
+import           Cardano.Slotting.Slot (SlotNo (unSlotNo), WithOrigin (..))
 import           Data.Foldable (asum)
 import           Data.Function ((&))
 import           Data.Functor ((<&>))
-import           Data.List (sortOn, insert, inits)
+import           Data.List (inits, sortOn)
 import qualified Data.Map as M
-import           Data.Maybe (fromJust, fromMaybe, mapMaybe)
+import           Data.Maybe (fromJust, fromMaybe)
 import           Data.Ord (Down (Down))
-import           Data.Proxy
 import qualified Data.Vector as Vector
-import           Ouroboros.Consensus.Block.Abstract (blockNo, blockSlot, blockHash,
-                     fromWithOrigin, pointSlot, unBlockNo, HeaderHash, HasHeader)
+import           Ouroboros.Consensus.Block.Abstract (HasHeader, HeaderHash,
+                     blockHash, blockNo, blockSlot, fromWithOrigin, pointSlot,
+                     unBlockNo)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Text.Printf (printf)
-import qualified Test.QuickCheck as QC
-import qualified Test.Util.TestBlock
 
 -- | Represent a branch of a block tree by a prefix and a suffix. The full
 -- fragment (the prefix and suffix catenated) and the trunk suffix (the rest of
@@ -278,7 +277,31 @@ deforestBlockTree (BlockTree trunk branches) =
       -> M.Map (HeaderHash blk) (AF.AnchoredFragment blk)
       -> M.Map (HeaderHash blk) (AF.AnchoredFragment blk)
     addPrefix fragment mapSoFar = case fragment of
-      AF.Empty _ -> mapSoFar
+      AF.Empty _  -> mapSoFar
       _ AF.:> tip -> M.insert (blockHash tip) fragment mapSoFar
 
   in foldr addPrefix mempty allPrefixes
+
+
+-- | More efficient implementation of a check used in some of the handlers,
+-- determining whether the first argument is on the chain that ends in the
+-- second argument.
+-- We would usually call @withinFragmentBounds@ for this, but since we're
+-- using 'TestBlock', looking at the hash is cheaper.
+--
+-- TODO: Unify with 'Test.UtilTestBlock.isAncestorOf' which basically does the
+-- same thing except not on 'WithOrigin'.
+isAncestorOf ::
+  (HasHeader blk, Eq blk) =>
+  BlockTree blk ->
+  WithOrigin blk ->
+  WithOrigin blk ->
+  Bool
+isAncestorOf bt (At ancestor) (At descendant) =
+  fromMaybe False $ do
+    let m = deforestBlockTree bt
+    afD <- M.lookup (blockHash descendant) m
+    afA <- M.lookup (blockHash ancestor) m
+    pure $ AF.isPrefixOf afA afD
+isAncestorOf _ (At _) Origin = False
+isAncestorOf _ Origin _ = True

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -18,12 +19,25 @@ import           Control.Monad.Class.MonadAsync
 import           Control.Monad.IOSim (IOSim, runSimStrictShutdown)
 import           Control.Tracer (debugTracer, traceWith)
 import           Data.Maybe (mapMaybe)
+import           Ouroboros.Consensus.Block.Abstract (ConvertRawHash, Header)
+import           Ouroboros.Consensus.Block.SupportsDiffusionPipelining
+                     (BlockSupportsDiffusionPipelining)
+import           Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode)
+import           Ouroboros.Consensus.HardFork.Abstract
+import           Ouroboros.Consensus.Ledger.Basics (LedgerState)
+import           Ouroboros.Consensus.Ledger.Inspect (InspectLedger)
+import           Ouroboros.Consensus.Ledger.SupportsProtocol
+                     (LedgerSupportsProtocol)
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (ChainSyncClientException (..))
+import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB
+import           Ouroboros.Consensus.Storage.LedgerDB.API
+                     (CanUpgradeLedgerTables)
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.IOLike (Exception, fromException)
 import           Ouroboros.Network.Driver.Limits
                      (ProtocolLimitFailure (ExceededTimeLimit))
+import           Ouroboros.Network.Util.ShowProxy
 import           Test.Consensus.Genesis.Setup.Classifiers (Classifiers (..),
                      ResultClassifiers (..), ScheduleClassifiers (..),
                      classifiers, resultClassifiers, scheduleClassifiers)
@@ -33,9 +47,11 @@ import           Test.Consensus.PeerSimulator.StateView
 import           Test.Consensus.PeerSimulator.Trace (traceLinesWith,
                      tracerTestBlock)
 import           Test.Consensus.PointSchedule
+import           Test.Consensus.PointSchedule.NodeState (NodeState)
 import           Test.QuickCheck
 import           Test.Util.Orphans.IOLike ()
 import           Test.Util.QuickCheck (forAllGenRunShrinkCheck)
+import           Test.Util.TersePrinting (Terse)
 import           Test.Util.TestBlock (TestBlock)
 import           Test.Util.Tracer (recordingTracerM)
 import           Text.Printf (printf)
@@ -53,9 +69,26 @@ runSimStrictShutdownOrThrow action =
 -- | Runs the given 'GenesisTest' and 'PointSchedule' and evaluates the given
 -- property on the final 'StateView'.
 runGenesisTest ::
-  SchedulerConfig ->
-  GenesisTestFull TestBlock ->
-  RunGenesisTestResult
+  ( Condense (StateView blk)
+  , CondenseList (NodeState blk)
+  , ShowProxy blk
+  , ShowProxy (Header blk)
+  , ConfigSupportsNode blk
+  , LedgerSupportsProtocol blk
+  , ChainDB.SerialiseDiskConstraints blk
+  , BlockSupportsDiffusionPipelining blk
+  , InspectLedger blk
+  , HasHardForkHistory blk
+  , ConvertRawHash blk
+  , CanUpgradeLedgerTables (LedgerState blk)
+  , Eq (Header blk)
+  , Eq blk
+  , Terse blk
+  , Condense (NodeState blk)
+  )
+  => SchedulerConfig ->
+  GenesisTestFull blk ->
+  RunGenesisTestResult blk
 runGenesisTest schedulerConfig genesisTest =
   runSimStrictShutdownOrThrow $ do
     (recordingTracer, getTrace) <- recordingTracerM
@@ -87,12 +120,29 @@ runGenesisTest' schedulerConfig genesisTest makeProperty =
 -- | All-in-one helper that generates a 'GenesisTest' and a 'Peers
 -- PeerSchedule', runs them with 'runGenesisTest', check whether the given
 -- property holds on the resulting 'StateView'.
-forAllGenesisTest ::
-  Testable prop =>
-  Gen (GenesisTestFull TestBlock) ->
+forAllGenesisTest :: forall blk prop.
+  (Testable prop
+  , Condense (StateView blk)
+  , CondenseList (NodeState blk)
+  , ShowProxy blk
+  , ShowProxy (Header blk)
+  , ConfigSupportsNode blk
+  , LedgerSupportsProtocol blk
+  , ChainDB.SerialiseDiskConstraints blk
+  , BlockSupportsDiffusionPipelining blk
+  , InspectLedger blk
+  , HasHardForkHistory blk
+  , ConvertRawHash blk
+  , CanUpgradeLedgerTables (LedgerState blk)
+  , Eq (Header blk)
+  , Eq blk
+  , Terse blk
+  , Condense (NodeState blk)
+  ) =>
+  Gen (GenesisTestFull blk) ->
   SchedulerConfig ->
-  (GenesisTestFull TestBlock -> StateView TestBlock -> [GenesisTestFull TestBlock]) ->
-  (GenesisTestFull TestBlock -> StateView TestBlock -> prop) ->
+  (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]) ->
+  (GenesisTestFull blk -> StateView blk -> prop) ->
   Property
 forAllGenesisTest generator schedulerConfig shrinker mkProperty =
   forAllGenRunShrinkCheck generator runner shrinker' $ \genesisTest result ->