Merge pull request #4679 from input-output-hk/ml/foldblocks-test

Add fix and test for `foldBlocks`

cardano-testnet/cardano-testnet.cabal

@@ -33,7 +33,9 @@ library
                       , bytestring
                       , cardano-api
                       , cardano-cli
+                      , cardano-crypto-class
                       , cardano-git-rev
+                      , cardano-ledger-byron
                       , cardano-node
                       , containers
                       , directory
@@ -103,25 +105,28 @@ test-suite cardano-testnet-tests
   other-modules:        Test.Cli.Alonzo.LeadershipSchedule
                         Test.Cli.Babbage.LeadershipSchedule
                         Test.Cli.KesPeriodInfo
+                        Test.FoldBlocks
                         Test.Misc
                         Test.Node.Shutdown
                         Test.ShutdownOnSlotSynced
 
   type:                 exitcode-stdio-1.0
 
   build-depends:        aeson
+                      , async
                       , cardano-api
                       , cardano-cli
                       , cardano-testnet
                       , containers
                       , directory
                       , filepath
-                      , hedgehog                      
+                      , hedgehog
                       , hedgehog-extras
                       , process
                       , tasty
                       , text
                       , time
+                      , transformers
 
 
   other-modules:

cardano-testnet/src/Testnet/Cardano.hs

@@ -17,20 +17,26 @@ module Testnet.Cardano
   , cardanoTestnet
   ) where
 
+import qualified Cardano.Crypto.Hash.Blake2b
+import qualified Cardano.Crypto.Hash.Class
 import           Control.Monad
-import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.IO.Class (MonadIO, liftIO)
+import           Control.Monad.Trans.Except
 import           Data.Aeson ((.=))
+import qualified Data.ByteString as BS
 import           Data.ByteString.Lazy (ByteString)
 import           Data.List ((\\))
 import           Data.Maybe
 import           Data.String
+import qualified Hedgehog as H
 import           Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..))
 import           Hedgehog.Extras.Stock.Time (formatIso8601, showUTCTimeSeconds)
 import           Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..))
 import           Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..))
 import           Prelude
 import           System.FilePath.Posix ((</>))
 
+import           Cardano.Chain.Genesis (GenesisHash (unGenesisHash), readGenesisData)
 import qualified Cardano.Node.Configuration.Topology as NonP2P
 import qualified Cardano.Node.Configuration.TopologyP2P as P2P
 import qualified Data.Aeson as J
@@ -706,6 +712,15 @@ cardanoTestnet testnetOptions H.Conf {..} = do
   -- Generated a signed 'do it all' transaction:
   H.assertIO . IO.doesFileExist $ tempAbsPath </> "tx1.tx"
 
+  -- Add Byron, Shelley and Alonzo genesis hashes to node configuration
+  byronGenesisHash <- getByronGenesisHash $ tempAbsPath </> "byron/genesis.json"
+  shelleyGenesisHash <- getShelleyGenesisHash $ tempAbsPath </> "shelley/genesis.json"
+  alonzoGenesisHash <- getShelleyGenesisHash $ tempAbsPath </> "shelley/genesis.alonzo.json"
+  H.rewriteYamlFile (tempAbsPath </> "configuration.yaml") . J.rewriteObject
+    $ HM.insert "ByronGenesisHash" byronGenesisHash
+    . HM.insert "ShelleyGenesisHash" shelleyGenesisHash
+    . HM.insert "AlonzoGenesisHash" alonzoGenesisHash
+
   --------------------------------
   -- Launch cluster of three nodes
 
@@ -761,3 +776,18 @@ cardanoTestnet testnetOptions H.Conf {..} = do
     , wallets
     , delegators = [] -- TODO this should be populated
     }
+
+-- * Generate hashes for genesis.json files
+
+getByronGenesisHash :: (H.MonadTest m, MonadIO m) => FilePath -> m J.Value
+getByronGenesisHash path = do
+  e <- runExceptT $ readGenesisData path
+  (_, genesisHash) <- H.leftFail e
+  let genesisHash' = J.toJSON $ unGenesisHash genesisHash
+  pure genesisHash'
+
+getShelleyGenesisHash :: (H.MonadTest m, MonadIO m) => FilePath -> m J.Value
+getShelleyGenesisHash path = do
+  content <- liftIO $ BS.readFile path
+  let genesisHash = Cardano.Crypto.Hash.Class.hashWith id content :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 BS.ByteString
+  pure $ J.toJSON genesisHash

cardano-testnet/test/Main.hs

@@ -14,6 +14,7 @@ import qualified Test.Tasty.Ingredients as T
 --import qualified Test.Cli.Alonzo.LeadershipSchedule
 import qualified Test.Cli.Babbage.LeadershipSchedule
 import qualified Test.Cli.KesPeriodInfo
+import qualified Test.FoldBlocks
 import qualified Test.Node.Shutdown
 import qualified Test.ShutdownOnSlotSynced
 import qualified Util.Ignore as H
@@ -35,6 +36,7 @@ tests = pure $ T.testGroup "test/Spec.hs"
       -- TODO: Babbage temporarily ignored due to broken protocol-state query
     , H.disabled "kes-period-info" Test.Cli.KesPeriodInfo.hprop_kes_period_info
     ]
+  , H.ignoreOnWindows "foldBlocks receives ledger state" Test.FoldBlocks.prop_foldBlocks
   ]
 
 ingredients :: [T.Ingredient]

cardano-testnet/test/Test/FoldBlocks.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.FoldBlocks where
+
+import qualified Control.Concurrent as IO
+import           Control.Concurrent.Async (async, link)
+import           Control.Exception (Exception, throw)
+import           Control.Monad (forever)
+import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.Trans.Except (runExceptT)
+import qualified Data.Text as TS
+import           Prelude
+import qualified System.Directory as IO
+import           System.FilePath ((</>))
+
+import qualified Hedgehog as H
+import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as HE
+import qualified Hedgehog.Extras.Test as HE
+import qualified Hedgehog.Extras.Test.Base as H
+
+import qualified Cardano.Api as C
+import qualified Testnet.Cardano as TN
+import qualified Testnet.Conf as TC (Conf (..), ProjectBase (ProjectBase),
+                   YamlFilePath (YamlFilePath), mkConf)
+import qualified Util.Base as U
+import qualified Util.Runtime as U
+
+
+newtype FoldBlocksException = FoldBlocksException C.FoldBlocksError
+instance Exception FoldBlocksException
+instance Show FoldBlocksException where
+  show (FoldBlocksException a) = TS.unpack $ C.renderFoldBlocksError a
+
+-- | This test starts a testnet with wery short timing, then starts
+-- `foldBlocks` in another thread to listen for ledger state, ledger
+-- events and block, and on reception writes this to the `lock` `MVar`
+-- that main thread blocks on.
+prop_foldBlocks :: H.Property
+prop_foldBlocks = U.integration . H.runFinallies . H.workspace "chairman" $ \tempAbsBasePath' -> do
+
+  -- Start testnet
+  base <- HE.noteM $ liftIO . IO.canonicalizePath =<< HE.getProjectBase
+  configurationTemplate <- H.noteShow $ base </> "configuration/defaults/byron-mainnet/configuration.yaml"
+  conf <- HE.noteShowM $
+    TC.mkConf (TC.ProjectBase base) (TC.YamlFilePath configurationTemplate)
+      (tempAbsBasePath' <> "/")
+      Nothing
+
+  let options = TN.defaultTestnetOptions
+        -- NB! The `activeSlotsCoeff` value is very important for
+        -- chain extension for the two-node/one-pool testnet that
+        -- `defaultTestnetOptions` define. The default 0.2 often fails
+        -- to extend the chain in a reasonable time (< 90s, e.g as the
+        -- deadline is defined in Testnet.Cardano).
+        { TN.activeSlotsCoeff = 0.9 }
+  runtime <- TN.cardanoTestnet options conf
+
+  -- Get socketPath
+  socketPathAbs <- do
+    socketPath' <- HE.sprocketArgumentName <$> HE.headM (U.nodeSprocket <$> TN.bftNodes runtime)
+    H.note =<< liftIO (IO.canonicalizePath $ TC.tempAbsPath conf </> socketPath')
+
+  configurationFile <- H.noteShow $ TC.tempAbsPath conf </> "configuration.yaml"
+
+  -- Start foldBlocks in a separate thread
+  lock <- liftIO IO.newEmptyMVar
+  liftIO $ do
+    a <- async $
+      -- The `forever` is here because `foldBlocks` drains blocks
+      -- until current slot and then quits -- even if there are no
+      -- permanent (= older than the k parameter) blocks created. In
+      -- that case we simply restart `foldBlocks` again.
+      forever $ do
+        let handler _env _ledgerState _ledgerEvents _blockInCardanoMode _ = IO.putMVar lock ()
+        e <- runExceptT (C.foldBlocks configurationFile socketPathAbs  C.QuickValidation () handler)
+        either (throw . FoldBlocksException) (\_ -> pure ()) e
+    link a -- Throw async thread's exceptions in main thread
+
+  -- The `lock` is written to from within the `handler` above. It
+  -- tests that `foldBlocks` receives ledger state; once that happens,
+  -- handler is called, which then writes to the `lock` and allows the
+  -- test to finish.
+  _ <- liftIO $ IO.readMVar lock
+  H.assert True