diff --git a/lib/launcher/cardano-wallet-launcher.cabal b/lib/launcher/cardano-wallet-launcher.cabal index 5b10f725a14..e25c2b63e1c 100644 --- a/lib/launcher/cardano-wallet-launcher.cabal +++ b/lib/launcher/cardano-wallet-launcher.cabal @@ -65,10 +65,13 @@ test-suite unit -Werror build-depends: base + , async , cardano-wallet-launcher , fmt , hspec , iohk-monitoring + , process + , retry , text build-tools: hspec-discover diff --git a/lib/launcher/src/Cardano/Launcher.hs b/lib/launcher/src/Cardano/Launcher.hs index de06e55669d..d12d9f3c6d1 100644 --- a/lib/launcher/src/Cardano/Launcher.hs +++ b/lib/launcher/src/Cardano/Launcher.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -- | -- Copyright: © 2018-2019 IOHK @@ -14,8 +13,8 @@ module Cardano.Launcher ( Command (..) , StdStream(..) , ProcessHasExited(..) - , launch , withBackendProcess + , withBackendProcessHandle -- * Program startup , installSignalHandlers @@ -34,14 +33,12 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Trace ( Trace, appendName, traceNamedItem ) -import Control.Concurrent - ( threadDelay ) import Control.Concurrent.Async - ( async, race, waitAnyCancel ) + ( race ) import Control.Exception ( Exception, IOException, tryJust ) import Control.Monad - ( forever, join ) + ( join ) import Control.Monad.IO.Class ( MonadIO (..) ) import Control.Tracer @@ -73,6 +70,7 @@ import System.IO.CodePage ( withCP65001 ) import System.Process ( CreateProcess (..) + , ProcessHandle , StdStream (..) , getPid , proc @@ -142,19 +140,6 @@ data ProcessHasExited instance Exception ProcessHasExited --- | Run a bunch of command in separate processes. Note that, this operation is --- blocking and will throw when one of the given commands terminates. Commands --- are therefore expected to be daemon or long-running services. -launch :: Trace IO LauncherLog -> [Command] -> IO ProcessHasExited -launch tr cmds = mapM start cmds >>= waitAnyCancel >>= \case - (_, Left e) -> return e - (_, Right _) -> error $ - "Unreachable. Supervising threads should never finish. " <> - "They should stay running or throw @ProcessHasExited@." - where - sleep = forever $ threadDelay maxBound - start = async . flip (withBackendProcess tr) sleep - -- | Starts a command in the background and then runs an action. If the action -- finishes (through an exception or otherwise) then the process is terminated -- (see 'withCreateProcess') for details. If the process exits, the action is @@ -167,7 +152,19 @@ withBackendProcess -> IO a -- ^ Action to execute while process is running. -> IO (Either ProcessHasExited a) -withBackendProcess tr cmd@(Command name args before output) action = do +withBackendProcess tr cmd = withBackendProcessHandle tr cmd . const + +-- | A variant of 'withBackendProcess' which also provides the 'ProcessHandle' to the +-- given action. +withBackendProcessHandle + :: Trace IO LauncherLog + -- ^ Logging + -> Command + -- ^ 'Command' description + -> (ProcessHandle -> IO a) + -- ^ Action to execute while process is running. + -> IO (Either ProcessHasExited a) +withBackendProcessHandle tr cmd@(Command name args before output) action = do before launcherLog tr $ MsgLauncherStart cmd let process = (proc name args) { std_out = output, std_err = output } @@ -177,7 +174,7 @@ withBackendProcess tr cmd@(Command name args before output) action = do let tr' = appendName (T.pack name <> "." <> pid) tr launcherLog tr' $ MsgLauncherStarted name pid race (ProcessHasExited name <$> waitForProcess h) - (action <* launcherLog tr' MsgLauncherCleanup) + (action h <* launcherLog tr' MsgLauncherCleanup) either (launcherLog tr . MsgLauncherFinish) (const $ pure ()) res pure res where diff --git a/lib/launcher/test/unit/Cardano/LauncherSpec.hs b/lib/launcher/test/unit/Cardano/LauncherSpec.hs index ee7ffa56ccc..d169670c65f 100644 --- a/lib/launcher/test/unit/Cardano/LauncherSpec.hs +++ b/lib/launcher/test/unit/Cardano/LauncherSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module Cardano.LauncherSpec @@ -7,11 +8,26 @@ module Cardano.LauncherSpec import Prelude import Cardano.BM.Trace - ( nullTracer ) + ( Trace, nullTracer ) import Cardano.Launcher - ( Command (..), ProcessHasExited (..), StdStream (..), launch ) + ( Command (..) + , LauncherLog + , ProcessHasExited (..) + , StdStream (..) + , withBackendProcessHandle + ) +import Control.Concurrent + ( threadDelay ) +import Control.Concurrent.Async + ( async, waitAnyCancel ) import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, tryReadMVar ) + ( modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, tryReadMVar ) +import Control.Monad + ( forever ) +import Control.Retry + ( exponentialBackoff, limitRetriesByCumulativeDelay, recoverAll ) +import Data.Maybe + ( isJust ) import Data.Text ( Text ) import Fmt @@ -20,8 +36,10 @@ import System.Exit ( ExitCode (..) ) import System.Info ( os ) +import System.Process + ( ProcessHandle, getProcessExitCode ) import Test.Hspec - ( Spec, it, shouldBe, shouldContain, shouldReturn ) + ( Spec, it, shouldBe, shouldContain, shouldReturn, shouldSatisfy ) {-# ANN spec ("HLint: ignore Use head" :: String) #-} spec :: Spec @@ -45,36 +63,40 @@ spec = do [ mockCommand True (pure ()) , foreverCommand ] - (ProcessHasExited name code) <- launch nullTracer commands + (phs, ProcessHasExited name code) <- launch nullTracer commands name `shouldBe` cmdName (commands !! 0) code `shouldBe` ExitSuccess + assertProcessesExited phs it "2nd process exits with 0, others are cancelled" $ do let commands = [ foreverCommand , mockCommand True (pure ()) ] - (ProcessHasExited name code) <- launch nullTracer commands + (phs, ProcessHasExited name code) <- launch nullTracer commands name `shouldBe` cmdName (commands !! 1) code `shouldBe` ExitSuccess + assertProcessesExited phs it "1st process exits with 3, others are cancelled" $ do let commands = [ mockCommand False (pure ()) , foreverCommand ] - (ProcessHasExited name code) <- launch nullTracer commands + (phs, ProcessHasExited name code) <- launch nullTracer commands name `shouldBe` cmdName (commands !! 0) code `shouldBe` (ExitFailure 3) + assertProcessesExited phs it "2nd process exits with 3, others are cancelled" $ do let commands = [ foreverCommand , mockCommand False (pure ()) ] - (ProcessHasExited name code) <- launch nullTracer commands + (phs, ProcessHasExited name code) <- launch nullTracer commands name `shouldBe` cmdName (commands !! 1) code `shouldBe` (ExitFailure 3) + assertProcessesExited phs it "Process executes a command before they start" $ do mvar <- newEmptyMVar @@ -82,16 +104,18 @@ spec = do let commands = [ mockCommand True before ] - (ProcessHasExited _ code) <- launch nullTracer commands + (phs, ProcessHasExited _ code) <- launch nullTracer commands code `shouldBe` ExitSuccess tryReadMVar mvar `shouldReturn` (Just @String "executed") + assertProcessesExited phs it "Handles command not found" $ do let commands = [ Command "foobar" [] (pure ()) Inherit ] - ProcessDidNotStart name _exc <- launch nullTracer commands + (phs, ProcessDidNotStart name _exc) <- launch nullTracer commands name `shouldBe` "foobar" + assertProcessesExited phs it "Sanity check System.Info.os" $ ["linux", "darwin", "mingw32"] `shouldContain` [os] @@ -115,3 +139,33 @@ foreverCommand isWindows :: Bool isWindows = os == "mingw32" + +-- | Run a bunch of command in separate processes. Note that, this operation is +-- blocking and will throw when one of the given commands terminates. +-- It records the PID of all processes which started (in undefined order). +launch :: Trace IO LauncherLog -> [Command] -> IO ([ProcessHandle], ProcessHasExited) +launch tr cmds = do + phsVar <- newMVar [] + let + waitForOthers ph = do + modifyMVar_ phsVar (pure . (ph:)) + forever $ threadDelay maxBound + start = async . flip (withBackendProcessHandle tr) waitForOthers + + mapM start cmds >>= waitAnyCancel >>= \case + (_, Left e) -> do + phs <- readMVar phsVar + return (phs, e) + (_, Right _) -> error $ + "Unreachable. Supervising threads should never finish. " <> + "They should stay running or throw @ProcessHasExited@." + +-- | Check that all processes eventually exit somehow. This will wait for up to +-- 10 seconds for that to happen. +assertProcessesExited :: [ProcessHandle] -> IO () +assertProcessesExited phs = recoverAll policy test + where + policy = limitRetriesByCumulativeDelay 10000 (exponentialBackoff 50) + test _ = do + statuses <- mapM getProcessExitCode phs + statuses `shouldSatisfy` all isJust diff --git a/nix/.stack.nix/cardano-wallet-launcher.nix b/nix/.stack.nix/cardano-wallet-launcher.nix index edf640d228a..f6b40de9282 100644 --- a/nix/.stack.nix/cardano-wallet-launcher.nix +++ b/nix/.stack.nix/cardano-wallet-launcher.nix @@ -75,10 +75,13 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }: "unit" = { depends = [ (hsPkgs."base" or (buildDepError "base")) + (hsPkgs."async" or (buildDepError "async")) (hsPkgs."cardano-wallet-launcher" or (buildDepError "cardano-wallet-launcher")) (hsPkgs."fmt" or (buildDepError "fmt")) (hsPkgs."hspec" or (buildDepError "hspec")) (hsPkgs."iohk-monitoring" or (buildDepError "iohk-monitoring")) + (hsPkgs."process" or (buildDepError "process")) + (hsPkgs."retry" or (buildDepError "retry")) (hsPkgs."text" or (buildDepError "text")) ]; build-tools = [