Replace usage of resourcet's allocate with resourceForkWith as this is

the recommended concurrency primitive the library exposes
Update `runInBackground` with the ability to execute an IO action when
the background thread is terminated due to an unexpected exception

cabal.project

@@ -31,8 +31,8 @@ packages:
   trace-resources
   trace-forward
 
-program-options
-  ghc-options: -Werror
+-- program-options
+--   ghc-options: -Werror
 
 test-show-details: direct
 

cardano-testnet/cardano-testnet.cabal

@@ -34,6 +34,7 @@ library
   build-depends:        aeson
                       , aeson-pretty
                       , ansi-terminal
+                      , async
                       , bytestring
                       , cardano-api ^>= 8.46
                       , cardano-cli ^>= 8.23

cardano-testnet/src/Testnet/Components/Query.hs

@@ -49,8 +49,12 @@ import qualified Cardano.Ledger.Conway.PParams as L
 import qualified Cardano.Ledger.Shelley.LedgerState as L
 import qualified Cardano.Ledger.UTxO as L
 
+<<<<<<< HEAD
 import           Control.Exception.Safe (MonadCatch)
 import           Control.Monad
+=======
+import           Control.Monad (void)
+>>>>>>> 0d8b07527 (Replace usage of resourcet's allocate with resourceForkWith as this is)
 import           Control.Monad.Trans.Resource
 import           Control.Monad.Trans.State.Strict (put)
 import           Data.Bifunctor (bimap)
@@ -248,15 +252,14 @@ getEpochStateView
   :: HasCallStack
   => MonadResource m
   => MonadTest m
-  => MonadCatch m
   => NodeConfigFile In -- ^ node Yaml configuration file path
   -> SocketPath -- ^ node socket path
   -> m EpochStateView
 getEpochStateView nodeConfigFile socketPath = withFrozenCallStack $ do
   epochStateView <- H.evalIO $ newIORef Nothing
-  runInBackground . runExceptT . foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) Nothing
-    $ \epochState slotNumber blockNumber -> do
-        liftIO . writeIORef epochStateView $ Just (epochState, slotNumber, blockNumber)
+  runInBackground (return ()) . runExceptT . foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) Nothing
+    $ \epochState _slotNb _blockNb -> do
+        liftIO $ writeIORef epochStateView (Just epochState)
         pure ConditionNotMet
   pure $ EpochStateView nodeConfigFile socketPath epochStateView
 

cardano-testnet/src/Testnet/Property/Util.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -15,11 +16,13 @@ module Testnet.Property.Util
 
 import           Cardano.Api
 
-import           Control.Exception.Safe (MonadCatch)
+import           Control.Concurrent.Async
+import qualified Control.Exception as E
 import           Control.Monad
 import           Control.Monad.Trans.Resource
 import qualified Data.Aeson as Aeson
 import           GHC.Stack
+import           Network.Mux.Trace
 import qualified System.Environment as IO
 import           System.Info (os)
 import qualified System.IO.Unsafe as IO
@@ -60,18 +63,44 @@ integrationWorkspace workspaceName f = withFrozenCallStack $
 isLinux :: Bool
 isLinux = os == "linux"
 
-
 -- | Runs an action in background, and registers cleanup to `MonadResource m`
--- The argument forces IO monad to prevent leaking of `MonadResource` to the child thread
+-- Concurrency is tricky in the 'ResourceT' monad. See the "Concurrency" section of
+-- https://www.fpcomplete.com/blog/understanding-resourcet/.
 runInBackground :: MonadTest m
                 => MonadResource m
-                => MonadCatch m
-                => IO a
+                => IO ()
+                -> IO a
                 -> m ()
-runInBackground act = void . H.evalM $ allocate (H.async act) cleanUp
-  where
-    cleanUp :: H.Async a -> IO ()
-    cleanUp a = H.cancel a >> H.link a
+runInBackground runOnException act  =
+  void . H.evalIO
+       $ runResourceT
+       -- We don't 'wait' because this "background process" may not terminate.
+       -- If we 'wait' and it doesn't terminate, 'ResourceT' will not kill it
+       -- and the test will hang indefinitely.
+       -- Not waiting isn't a problem because this "background process"
+       -- is meant to run indefinitely and will be cleaned up by
+       -- 'ResourceT' when the test ends or fails.
+       -- We use 'asyncWithUnmask' because our logging thread is terminated via an exception.
+       -- In order to avoid competing for a file handle we must catch the exception which signals
+       -- the logging file is no longer being written to and we can now run the desired additional IO action we
+       -- want (runOnException). Attempting to share the 'FileHandle' and use concurrency primitives was not fruitful
+       -- and the section "Other ways to abuse ResourceT" in https://www.fpcomplete.com/blog/understanding-resourcet/
+       -- confirms this is problematic in 'ResourceT'.
+       $ resourceForkWith (\_ -> do r <- H.asyncWithUnmask (\restore -> restore act `E.onException` runOnException)
+                                    linkOnly ignoreException r
+                          ) $ return ()
+ where
+  ignoreException  :: E.SomeException -> Bool
+  ignoreException e =
+    case E.fromException e of
+     Just (MuxError errType _) ->
+       case errType of
+         MuxBearerClosed -> False
+         -- This is expected as the background thread is killed.
+         -- However we do want to be made aware about other
+         -- exceptions.
+         _ -> True
+     _ -> False
 
 decodeEraUTxO :: (IsShelleyBasedEra era, MonadTest m) => ShelleyBasedEra era -> Aeson.Value -> m (UTxO era)
 decodeEraUTxO _ = H.jsonErrorFail . Aeson.fromJSON

cardano-testnet/src/Testnet/Runtime.hs

@@ -21,7 +21,6 @@ import qualified Cardano.Ledger.Shelley.LedgerState as L
 
 import           Prelude
 
-import           Control.Concurrent
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.State.Strict
@@ -48,8 +47,9 @@ import qualified System.Process as IO
 import           Testnet.Filepath
 import qualified Testnet.Ping as Ping
 import           Testnet.Process.Run
-import           Testnet.Property.Util (runInBackground)
-import           Testnet.Types hiding (testnetMagic)
+import           Testnet.Property.Util
+import           Testnet.Types (NodeRuntime (NodeRuntime), TestnetRuntime (configurationFile),
+                   poolSprockets)
 
 import           Hedgehog (MonadTest)
 import qualified Hedgehog as H
@@ -217,56 +217,46 @@ startLedgerNewEpochStateLogging testnetRuntime tmpWorkspace = withFrozenCallStac
     False -> do
       H.evalIO $ appendFile logFile ""
       socketPath <- H.noteM $ H.sprocketSystemName <$> H.headM (poolSprockets testnetRuntime)
-      _ <- runInBackground . runExceptT $
-        foldEpochState
-          (configurationFile testnetRuntime)
-          (Api.File socketPath)
-          Api.QuickValidation
-          (EpochNo maxBound)
-          ()
-          (\epochState _ _ ->
-              liftIO $ evalStateT (handler logFile epochState) 0
-          )
-      H.note_ $ "Started logging epoch states to: " <> logFile
 
-      -- In order to create a diff of the epoch state logging file contents
-      -- we must do so when the resources are deallocated (see runInBackground)
-      -- and therefore when the log file is no longer in use.
-      void . H.evalM $ allocate (pure ()) $ \_ -> do
-          isFileReadableLoop logFile >>= \case
-            False -> error "isFileReadableLoop: Impossible"
-            True -> do
-              logFileContents <- IO.readFile logFile
-              let epochStateValues = epochStateBeforeAfterValues logFileContents
-                  epochStateDiffs' = epochStateDiffs epochStateValues
-              Text.writeFile (logDir </> "ledger-epoch-state-diffs.log") epochStateDiffs'
+      runInBackground
+        (do logFileContents <- IO.readFile logFile
+            let epochStateValues = epochStateBeforeAfterValues logFileContents
+                epochStateDiffs' = epochStateDiffs epochStateValues
+            Text.writeFile (logDir </> "ledger-epoch-state-diffs.log") epochStateDiffs'
+        )
+        (do void $ runExceptT $
+              foldEpochState
+                (configurationFile testnetRuntime)
+                (Api.File socketPath)
+                Api.QuickValidation
+                (EpochNo maxBound)
+                ()
+                (\epochState _ _ ->
+                    liftIO $ evalStateT (handler logFile epochState) 0
+                )
+        )
+
+
+      H.note_ $ "Started logging epoch states to: " <> logFile
 
   where
     handler :: FilePath -> AnyNewEpochState -> StateT Int IO LedgerStateCondition
-    handler outputFp (AnyNewEpochState sbe nes) = do
+    handler outputFpHandle (AnyNewEpochState sbe nes) = do
       handleException . liftIO $ do
-        appendFile outputFp $ "#### BLOCK ####" <> "\n"
-        appendFile outputFp $ BSC.unpack (shelleyBasedEraConstraints sbe $ encodePretty nes) <> "\n"
+        appendFile outputFpHandle $ "#### BLOCK ####" <> "\n"
+        appendFile outputFpHandle $ BSC.unpack (shelleyBasedEraConstraints sbe $ encodePretty nes) <> "\n"
         pure ConditionNotMet
       where
         -- | Handle all sync exceptions and log them into the log file. We don't want to fail the test just
         -- because logging has failed.
         handleException = handle $ \(e :: SomeException) -> do
-          liftIO $ appendFile outputFp $ "Ledger new epoch logging failed - caught exception:\n"
+          liftIO $ appendFile outputFpHandle $ "Ledger new epoch logging failed - caught exception:\n"
             <> displayException e <> "\n"
           pure ConditionMet
+-- TODO: Not sure why this isn't terminating. Read up on resourcet and how it works.
+-- See concurrency section: https://www.fpcomplete.com/blog/understanding-resourcet/
+-- Probably need to use resourceForkWith but best to not use concurrency at all!
 
--- TODO: I hate this. Is there a better way to do this without
--- reaching for concurrency primitives?
-isFileReadableLoop :: FilePath -> IO Bool
-isFileReadableLoop fp = do
-  threadDelay 100000
-  isFileReadable fp >>= \case
-    True -> return True
-    False -> isFileReadableLoop fp
-
-isFileReadable :: FilePath -> IO Bool
-isFileReadable fp = IO.withFile fp IO.ReadMode $ \h -> IO.hIsReadable h
 
 -- | Produce tuples that represent the change of the 'NewEpochState' after
 -- a transition.