Use exceptions to signal ProcessExited

cardano-foundation · May 3, 2024 · d267683 · d267683
1 parent 8cedd79
commit d267683
Show file tree

Hide file tree

Showing 7 changed files with 20 additions and 19 deletions.
diff --git a/lib/benchmarks/src/Cardano/Wallet/BenchShared.hs b/lib/benchmarks/src/Cardano/Wallet/BenchShared.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 -- |
@@ -46,6 +47,9 @@ import Cardano.BM.Trace
     ( Trace
     , nullTracer
     )
+import Cardano.Launcher
+    ( ProcessHasExited (..)
+    )
 import Cardano.Launcher.Node
     ( CardanoNodeConfig (..)
     , CardanoNodeConn
@@ -139,6 +143,7 @@ import UnliftIO.Concurrent
     )
 import UnliftIO.Exception
     ( evaluate
+    , try
     )
 import UnliftIO.Temporary
     ( withSystemTempDirectory
@@ -169,12 +174,13 @@ execBenchWithNode networkConfig action = withNoBuffering $ do
             action tr (networkConfig args) conn
             pure ExitSuccess
         Nothing -> do
-            res <- withNetworkConfiguration args $ \nodeConfig ->
+            res <- try $ withNetworkConfiguration args $ \nodeConfig ->
                 withCardanoNode (trMessageText tr) nodeConfig $
                     action tr (networkConfig args)
             case res of
-                Left exited -> do
-                    sayErr $ "FAIL: cardano-node exited with status " <> toText exited
+                Left (exited :: ProcessHasExited) -> do
+                    sayErr $ "FAIL: cardano-node exited with status "
+                        <> toText exited
                     pure $ ExitFailure 1
                 Right _ -> pure ExitSuccess
 

diff --git a/lib/launcher/src/Cardano/Launcher.hs b/lib/launcher/src/Cardano/Launcher.hs
@@ -105,6 +105,7 @@ import UnliftIO.Exception
     , bracket_
     , finally
     , onException
+    , throwIO
     , tryJust
     )
 import UnliftIO.MVar
@@ -206,7 +207,7 @@ withBackendProcess
     -- ^ 'Command' description
     -> (ProcessHandles -> m a)
     -- ^ Action to execute while process is running.
-    -> m (Either ProcessHasExited a)
+    -> m a
 withBackendProcess tr (Command name args before std_in std_out) action =
     liftIO before >> withBackendCreateProcess tr process action
   where
@@ -239,7 +240,7 @@ withBackendCreateProcess
     -- ^ 'Command' description
     -> (ProcessHandles -> m a)
     -- ^ Action to execute while process is running.
-    -> m (Either ProcessHasExited a)
+    -> m a
 withBackendCreateProcess tr process action = do
     traceWith tr $ MsgLauncherStart name args
     exitVar <- newEmptyMVar
@@ -258,7 +259,7 @@ withBackendCreateProcess tr process action = do
                     (action $ ProcessHandles mstdin mstdout mstderr ph)
 
     traceWith tr $ MsgLauncherFinish (leftToMaybe res)
-    pure res
+    either throwIO pure res
   where
     -- Exceptions resulting from the @exec@ call for this command. The most
     -- likely exception is that the command does not exist. We don't want to

diff --git a/lib/launcher/src/Cardano/Launcher/Node.hs b/lib/launcher/src/Cardano/Launcher/Node.hs
@@ -25,7 +25,6 @@ import Prelude
 
 import Cardano.Launcher
     ( LauncherLog
-    , ProcessHasExited
     , StdStream (..)
     , withBackendCreateProcess
     )
@@ -134,7 +133,7 @@ withCardanoNode
     -> CardanoNodeConfig
     -> (CardanoNodeConn -> IO a)
     -- ^ Callback function with a socket filename and genesis params
-    -> IO (Either ProcessHasExited a)
+    -> IO a
 withCardanoNode tr cfg action = do
     let socketPath = nodeSocketPath (nodeDir cfg)
     let run output = do

diff --git a/lib/launcher/src/Cardano/Launcher/Wallet.hs b/lib/launcher/src/Cardano/Launcher/Wallet.hs
@@ -20,7 +20,6 @@ import Prelude
 
 import Cardano.Launcher
     ( LauncherLog
-    , ProcessHasExited
     , withBackendCreateProcess
     )
 import Cardano.Launcher.Node
@@ -91,7 +90,7 @@ withCardanoWallet
     -> CardanoWalletConfig
     -> (CardanoWalletConn -> IO a)
     -- ^ Callback function with a socket filename and genesis params
-    -> IO (Either ProcessHasExited a)
+    -> IO a
 withCardanoWallet tr node cfg@CardanoWalletConfig{..} action =
     withBackendCreateProcess tr (cardanoWallet cfg node)
         $ \_ -> action $ CardanoWalletConn walletPort

diff --git a/lib/launcher/test/unit/Cardano/LauncherSpec.hs b/lib/launcher/test/unit/Cardano/LauncherSpec.hs
@@ -105,6 +105,7 @@ import UnliftIO.Concurrent
     )
 import UnliftIO.Exception
     ( bracket
+    , try
     )
 import UnliftIO.MVar
     ( modifyMVar_
@@ -277,7 +278,7 @@ launch tr cmds = do
         waitForOthers (ProcessHandles _ _ _ ph) = do
             modifyMVar_ phsVar (pure . (ph:))
             forever $ threadDelay maxBound
-        start = async . flip (withBackendProcess tr) waitForOthers
+        start = async . try . flip (withBackendProcess tr) waitForOthers
 
     mapM start cmds >>= waitAnyCancel >>= \case
         (_, Left e) -> do

diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/Process.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/Process.hs
@@ -17,9 +17,6 @@ import Cardano.Wallet.Launch.Cluster.Config
 import Cardano.Wallet.Launch.Cluster.Logging
     ( ClusterLog (MsgLauncher)
     )
-import Control.Exception
-    ( throwIO
-    )
 import Control.Monad.Reader
     ( MonadIO (..)
     , MonadReader (..)
@@ -35,6 +32,4 @@ withCardanoNodeProcess
     -> ClusterM a
 withCardanoNodeProcess name cfg f = do
     Config{..} <- ask
-    liftIO $ do
-        r <- withCardanoNode (contramap (MsgLauncher name) cfgTracer) cfg f
-        either throwIO pure r
+    liftIO $ withCardanoNode (contramap (MsgLauncher name) cfgTracer) cfg f
diff --git a/lib/wallet-benchmarks/bench/memory-benchmark.hs b/lib/wallet-benchmarks/bench/memory-benchmark.hs
@@ -226,7 +226,7 @@ withCardanoWallet
     -> BenchmarkConfig
     -> C.CardanoNodeConn
     -> (C.CardanoWalletConn -> IO r)
-    -> IO (Either C.ProcessHasExited r)
+    -> IO r
 withCardanoWallet tr workingDir walletExe BenchmarkConfig{..} node action = do
     C.withCardanoWallet tr node
         C.CardanoWalletConfig
@@ -252,7 +252,7 @@ withCardanoNode
     -> FilePath
     -> BenchmarkConfig
     -> (C.CardanoNodeConn -> IO r)
-    -> IO (Either C.ProcessHasExited r)
+    -> IO r
 withCardanoNode tr nodeExe BenchmarkConfig{..} =
     C.withCardanoNode tr
         C.CardanoNodeConfig