Experimenting with foldBlocks

cardano-testnet/cardano-testnet.cabal

@@ -221,6 +221,7 @@ test-suite cardano-testnet-test
                       , microlens
                       , mtl
                       , process
+                      , stm
                       , regex-compat
                       , tasty ^>= 1.5
                       , text

cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldBlocks.hs

@@ -1,25 +1,25 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
 
 module Cardano.Testnet.Test.FoldBlocks where
 
 import           Cardano.Api hiding (cardanoEra)
 import qualified Cardano.Api as Api
 import           Cardano.Api.Error
-import qualified Cardano.Api.Shelley as Api
 
 import           Cardano.Testnet as TN
 
 import           Prelude
 
-import qualified Control.Concurrent as IO
 import           Control.Concurrent.Async (async, link)
+import qualified Control.Concurrent.STM as STM
 import           Control.Exception (Exception, throw)
 import           Control.Monad
+import           Control.Monad.Trans.State.Strict
 import qualified System.Directory as IO
 import           System.FilePath ((</>))
+import qualified System.IO as IO
 
 import qualified Testnet.Property.Utils as H
 import           Testnet.Runtime
@@ -28,16 +28,14 @@ import qualified Hedgehog as H
 import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as H
 import qualified Hedgehog.Extras.Test as H
 
-
 newtype FoldBlocksException = FoldBlocksException Api.FoldBlocksError
 instance Exception FoldBlocksException
 instance Show FoldBlocksException where
   show (FoldBlocksException a) = displayError 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.
+moo :: a -> a -> b
+moo = undefined
+
 prop_foldBlocks :: H.Property
 prop_foldBlocks = H.integrationRetryWorkspace 2 "foldblocks" $ \tempAbsBasePath' -> do
   -- Start testnet
@@ -56,25 +54,35 @@ prop_foldBlocks = H.integrationRetryWorkspace 2 "foldblocks" $ \tempAbsBasePath'
     socketPath' <- H.sprocketArgumentName <$> H.headM (poolSprockets runtime)
     H.noteIO (IO.canonicalizePath $ tempAbsPath' </> socketPath')
 
+  H.evalIO $ IO.appendFile "out.txt" "test 3\n"
+
+  tDone <- H.evalIO $ STM.newTVarIO False
+
   -- Start foldBlocks in a separate thread
-  lock <- H.evalIO IO.newEmptyMVar
   H.evalIO $ 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 -> [Api.LedgerEvent] -> BlockInMode -> () -> IO ((), FoldStatus)
-            handler _env _ledgerState _ledgerEvents _blockInCardanoMode _ = (, ContinueFold) <$> IO.putMVar lock ()
-        e <- runExceptT (Api.foldBlocks (File configurationFile) (Api.File socketPathAbs) Api.QuickValidation () handler)
-        either (throw . FoldBlocksException) (\_ -> pure ()) e
+    a <- async $ do
+      let handler :: ()
+            => AnyNewEpochState
+            -> SlotNo
+            -> BlockNo
+            -> StateT () IO LedgerStateCondition
+          handler anyNewEpochState slotNo blockNo = do
+            liftIO $ IO.appendFile "out.txt" $ show slotNo <> "," <> show blockNo <> take 80 (show anyNewEpochState) <> ", " <> "\n"
+            liftIO $ STM.atomically $ STM.writeTVar tDone True
+            pure ConditionNotMet
+      e <- runExceptT (Api.foldEpochState (File configurationFile) (Api.File socketPathAbs) Api.QuickValidation (EpochNo maxBound) () 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.
-  _ <- H.evalIO $ H.timeout 30_000_000 $ IO.readMVar lock
+  _ <- H.evalIO $ H.timeout 30_000_000 $ STM.atomically $ do
+      done <- STM.readTVar tDone
+      unless done STM.retry
+
+  H.evalIO $ IO.appendFile "out.txt" "test done\n"
+
+  H.threadDelay 10_000_000
+
+  H.evalIO $ IO.appendFile "out.txt" "test end\n"
+
   H.assert True