Add test for running foldBlocks on testnet

cardano-testnet/cardano-testnet.cabal

@@ -112,6 +112,7 @@ test-suite cardano-testnet-tests
 
   build-depends:        cardano-testnet
                       , aeson
+                      , async
                       , cardano-api
                       , cardano-cli
                       , containers
@@ -125,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/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
     ]
+  , Test.FoldBlocks.tests
   ]
 
 ingredients :: [T.Ingredient]

cardano-testnet/test/Test/FoldBlocks.hs

@@ -0,0 +1,91 @@
+{-# 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           Test.Tasty (TestTree, testGroup)
+import           Test.Tasty.Hedgehog (testPropertyNamed)
+
+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
+
+tests :: TestTree
+tests = testGroup "FoldBlocks"
+  [ testPropertyNamed "foldBlocks receives ledger state" "prop_foldBlocks_fails" prop_foldBlocks
+  ]
+
+-- | 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