Add fix and test for foldBlocks, backported to 1.35 release branch

bench/tx-generator/src/Cardano/Benchmarking/Script/Setters.hs

@@ -1,24 +1,25 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE StandaloneDeriving #-}
 
 module Cardano.Benchmarking.Script.Setters
 where
 
-import           Prelude
-import           GHC.Generics
 import           Data.Constraint.Extras.TH (deriveArgDict)
-import           Data.Dependent.Sum (DSum(..) , (==>) )
+import           Data.Dependent.Sum (DSum (..), (==>))
 import           Data.GADT.Compare.TH (deriveGCompare, deriveGEq)
 import           Data.GADT.Show.TH (deriveGShow)
+import           GHC.Generics
+import           Prelude
 
-import           Cardano.Api (SlotNo, Lovelace, NetworkId)
+import           Cardano.Api (Lovelace, NetworkId, SlotNo)
 
 import           Cardano.Benchmarking.Types
 

bench/tx-generator/src/Cardano/Benchmarking/Script/Store.hs

@@ -1,12 +1,13 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Cardano.Benchmarking.Script.Store
@@ -22,10 +23,9 @@ import           Cardano.Api as Cardano (Tx)
 import           Cardano.Api.Shelley as Cardano (ProtocolParameters)
 import           Cardano.Node.Protocol.Types (SomeConsensusProtocol)
 
+import           Cardano.Benchmarking.OuroborosImports as Cardano (LoggingLayer, PaymentKey,
+                   ShelleyGenesis, SigningKey, StandardShelley)
 import           Cardano.Benchmarking.Script.Setters as Setters
-import           Cardano.Benchmarking.OuroborosImports as Cardano
-                    ( LoggingLayer, ShelleyGenesis, StandardShelley
-                    , SigningKey, PaymentKey)
 
 import           Cardano.Benchmarking.GeneratorTx as Core (AsyncBenchmarkControl)
 import qualified Cardano.Benchmarking.GeneratorTx.Tx as Core (Fund)

cardano-node-chairman/test/Spec/Network.hs

@@ -33,7 +33,7 @@ import qualified System.Random as IO
 import qualified UnliftIO.Exception as IO
 
 hprop_isPortOpen_False :: Property
-hprop_isPortOpen_False = H.propertyOnce . H.workspace "temp/network" $ \_ -> do
+hprop_isPortOpen_False = H.propertyOnce . H.workspace "temp-network" $ \_ -> do
   -- Check multiple random ports and assert that one is closed.
   -- Multiple random ports are checked because there is a remote possibility a random
   -- port is actually open by another program
@@ -42,7 +42,7 @@ hprop_isPortOpen_False = H.propertyOnce . H.workspace "temp/network" $ \_ -> do
   H.assert (False `L.elem` results)
 
 hprop_isPortOpen_True :: Property
-hprop_isPortOpen_True = H.propertyOnce . H.workspace "temp/network" $ \_ -> do
+hprop_isPortOpen_True = H.propertyOnce . H.workspace "temp-network" $ \_ -> do
   -- Check first random port from multiple possible ports to be successfully bound is open
   -- Multiple random ports are checked because there is a remote possibility a random
   -- port is actually open by another program

cardano-testnet/cardano-testnet.cabal

@@ -33,6 +33,8 @@ library
                       , bytestring
                       , cardano-api
                       , cardano-cli
+                      , cardano-crypto-class
+                      , cardano-ledger-byron
                       , cardano-node
                       , cardano-slotting
                       , containers
@@ -110,6 +112,7 @@ test-suite cardano-testnet-tests
 
   build-depends:        cardano-testnet
                       , aeson
+                      , async
                       , cardano-api
                       , cardano-cli
                       , containers
@@ -123,16 +126,16 @@ test-suite cardano-testnet-tests
                       , tasty-hedgehog
                       , text
                       , time
+                      , transformers
 
-  other-modules:
-                        Spec.Cli.Alonzo.LeadershipSchedule
+  other-modules:        Spec.Cli.Alonzo.LeadershipSchedule
                         Spec.Cli.Babbage.LeadershipSchedule
                         Spec.Cli.KesPeriodInfo
                         Spec.Node.Shutdown
                         Spec.ShutdownOnSlotSynced
-                        Testnet.Properties.Cli.KesPeriodInfo
-
+                        Test.FoldBlocks
                         Test.Util
+                        Testnet.Properties.Cli.KesPeriodInfo
 
   ghc-options:          -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T
 

cardano-testnet/src/Testnet/Cardano.hs

@@ -22,35 +22,28 @@ module Testnet.Cardano
   , testnet
   ) where
 
-import           Control.Applicative (pure)
-import           Control.Monad (Monad (..), fmap, forM, forM_, return, void, when, (=<<))
-import           Control.Monad.IO.Class (liftIO)
+import qualified Cardano.Crypto.Hash.Blake2b
+import qualified Cardano.Crypto.Hash.Class
+import           Control.Monad
+import           Control.Monad.IO.Class (MonadIO, liftIO)
+import           Control.Monad.Trans.Except
 import           Data.Aeson ((.=))
-import           Data.Bool (Bool (..))
+import qualified Data.ByteString as BS
 import           Data.ByteString.Lazy (ByteString)
-import           Data.Eq (Eq (..))
-import           Data.Function (flip, id, ($), (.))
-import           Data.Functor ((<$>), (<&>))
-import           Data.Int (Int)
+import           Data.Functor ((<&>))
 import           Data.List ((\\))
-import           Data.Maybe (Maybe (Just), fromJust)
-import           Data.Ord (Ord ((<=)))
-import           Data.Semigroup (Semigroup ((<>)))
-import           Data.String (IsString (fromString), String)
-import           GHC.Enum (Bounded, Enum)
-import           GHC.Float (Double)
-import           GHC.Num (Num ((+), (-)))
-import           GHC.Real (Integral (div), fromIntegral)
+import           Data.Maybe (fromJust)
+import           Data.String (IsString (fromString))
 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           Test.Runtime (NodeLoggingFormat (..), PaymentKeyPair (..), PoolNode (PoolNode),
                    PoolNodeKeys (..), TestnetNode (..), TestnetRuntime (..))
-import           Text.Read (Read)
-import           Text.Show (Show (show))
 
+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
@@ -73,6 +66,7 @@ import qualified System.Directory as IO
 import qualified System.Info as OS
 import qualified System.IO as IO
 import qualified System.Process as IO
+
 import qualified Test.Assert as H
 import qualified Test.Process as H
 import qualified Test.Runtime as TR
@@ -732,6 +726,15 @@ testnet 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
 
@@ -863,3 +866,18 @@ testnet 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

@@ -15,6 +15,8 @@ import qualified Spec.ShutdownOnSlotSynced
 import qualified System.Environment as E
 import qualified Test.Tasty as T
 import qualified Test.Tasty.Ingredients as T
+
+import qualified Test.FoldBlocks
 import qualified Test.Util as H
 
 tests :: IO TestTree
@@ -33,6 +35,7 @@ tests = pure $ T.testGroup "test/Spec.hs"
       -- TODO: Babbage temporarily ignored due to broken protocol-state query
     , H.disabled "kes-period-info" Spec.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,85 @@
+{-# 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 Test.Base as U
+import qualified Test.Runtime as U
+import qualified Testnet.Cardano as TN
+import qualified Testnet.Conf as TC (Conf (..), ProjectBase (ProjectBase),
+                   YamlFilePath (YamlFilePath), mkConf)
+
+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.testnet 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
+
+