diff --git a/lib/launcher/cardano-wallet-launcher.cabal b/lib/launcher/cardano-wallet-launcher.cabal index 5b10f725a14..5b0451ee02f 100644 --- a/lib/launcher/cardano-wallet-launcher.cabal +++ b/lib/launcher/cardano-wallet-launcher.cabal @@ -57,7 +57,8 @@ test-suite unit NoImplicitPrelude OverloadedStrings ghc-options: - -threaded -rtsopts + -threaded + -rtsopts -Wall -O2 if (!flag(development)) @@ -65,11 +66,16 @@ test-suite unit -Werror build-depends: base + , async , cardano-wallet-launcher + , cardano-wallet-test-utils , fmt , hspec , iohk-monitoring + , process + , retry , text + , time build-tools: hspec-discover type: diff --git a/lib/launcher/src/Cardano/Launcher.hs b/lib/launcher/src/Cardano/Launcher.hs index de06e55669d..746701685db 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 @@ -35,13 +34,15 @@ import Cardano.BM.Data.Severity import Cardano.BM.Trace ( Trace, appendName, traceNamedItem ) import Control.Concurrent - ( threadDelay ) + ( forkIO ) import Control.Concurrent.Async - ( async, race, waitAnyCancel ) + ( race ) +import Control.Concurrent.MVar + ( newEmptyMVar, putMVar, takeMVar ) import Control.Exception - ( Exception, IOException, tryJust ) + ( Exception, IOException, onException, tryJust ) import Control.Monad - ( forever, join ) + ( join, void ) import Control.Monad.IO.Class ( MonadIO (..) ) import Control.Tracer @@ -73,6 +74,7 @@ import System.IO.CodePage ( withCP65001 ) import System.Process ( CreateProcess (..) + , ProcessHandle , StdStream (..) , getPid , proc @@ -142,19 +144,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 +156,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 } @@ -176,8 +177,14 @@ withBackendProcess tr cmd@(Command name args before output) action = do pid <- maybe "-" (T.pack . show) <$> getPid h let tr' = appendName (T.pack name <> "." <> pid) tr launcherLog tr' $ MsgLauncherStarted name pid - race (ProcessHasExited name <$> waitForProcess h) - (action <* launcherLog tr' MsgLauncherCleanup) + + let waitForExit = + ProcessHasExited name <$> interruptibleWaitForProcess tr' h + let runAction = do + launcherLog tr' MsgLauncherAction + action h <* launcherLog tr' MsgLauncherCleanup + + race waitForExit runAction either (launcherLog tr . MsgLauncherFinish) (const $ pure ()) res pure res where @@ -190,6 +197,27 @@ withBackendProcess tr cmd@(Command name args before output) action = do | name `isPrefixOf` show e = Just (ProcessDidNotStart name e) | otherwise = Nothing + -- Wraps 'waitForProcess' in another thread. This works around the unwanted + -- behaviour of the process library on Windows where 'waitForProcess' seems + -- to block all concurrent async actions in the thread. + interruptibleWaitForProcess + :: Trace IO LauncherLog + -> ProcessHandle + -> IO ExitCode + interruptibleWaitForProcess tr' ph = do + status <- newEmptyMVar + void $ forkIO $ waitThread status `onException` continue status + takeMVar status + where + waitThread var = do + launcherLog tr' MsgLauncherWaitBefore + status <- waitForProcess ph + launcherLog tr' (MsgLauncherWaitAfter $ exitStatus status) + putMVar var status + continue var = do + launcherLog tr' MsgLauncherCancel + putMVar var (ExitFailure 256) + {------------------------------------------------------------------------------- Logging -------------------------------------------------------------------------------} @@ -197,7 +225,11 @@ withBackendProcess tr cmd@(Command name args before output) action = do data LauncherLog = MsgLauncherStart Command | MsgLauncherStarted String Text + | MsgLauncherWaitBefore + | MsgLauncherWaitAfter Int + | MsgLauncherCancel | MsgLauncherFinish ProcessHasExited + | MsgLauncherAction | MsgLauncherCleanup deriving (Generic, ToJSON) @@ -223,10 +255,14 @@ launcherLog logTrace msg = traceNamedItem logTrace Public (launcherLogLevel msg) launcherLogLevel :: LauncherLog -> Severity launcherLogLevel (MsgLauncherStart _) = Notice launcherLogLevel (MsgLauncherStarted _ _) = Info +launcherLogLevel MsgLauncherWaitBefore = Debug +launcherLogLevel (MsgLauncherWaitAfter _) = Debug +launcherLogLevel MsgLauncherCancel = Debug launcherLogLevel (MsgLauncherFinish (ProcessHasExited _ st)) = case st of ExitSuccess -> Notice ExitFailure _ -> Error launcherLogLevel (MsgLauncherFinish (ProcessDidNotStart _ _)) = Error +launcherLogLevel MsgLauncherAction = Debug launcherLogLevel MsgLauncherCleanup = Notice launcherLogText :: LauncherLog -> Builder @@ -234,10 +270,14 @@ launcherLogText (MsgLauncherStart cmd) = "Starting process "+|cmd|+"" launcherLogText (MsgLauncherStarted name pid) = "Process "+|name|+" started with pid "+|pid|+"" +launcherLogText MsgLauncherWaitBefore = "About to waitForProcess" +launcherLogText (MsgLauncherWaitAfter status) = "waitForProcess returned "+||status||+"" +launcherLogText MsgLauncherCancel = "There was an exception waiting for the process" launcherLogText (MsgLauncherFinish (ProcessHasExited name code)) = "Child process "+|name|+" exited with status "+||exitStatus code||+"" launcherLogText (MsgLauncherFinish (ProcessDidNotStart name _e)) = "Could not start "+|name|+"" +launcherLogText MsgLauncherAction = "Running withBackend action" launcherLogText MsgLauncherCleanup = "Terminating child process" {------------------------------------------------------------------------------- diff --git a/lib/launcher/test/unit/Cardano/LauncherSpec.hs b/lib/launcher/test/unit/Cardano/LauncherSpec.hs index ee7ffa56ccc..1d1ba56419f 100644 --- a/lib/launcher/test/unit/Cardano/LauncherSpec.hs +++ b/lib/launcher/test/unit/Cardano/LauncherSpec.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Cardano.LauncherSpec @@ -6,27 +9,73 @@ module Cardano.LauncherSpec import Prelude +import Cardano.BM.Configuration.Model + ( setMinSeverity ) +import Cardano.BM.Configuration.Static + ( defaultConfigStdout ) +import Cardano.BM.Data.Severity + ( Severity (..) ) +import Cardano.BM.Setup + ( setupTrace_, shutdown ) import Cardano.BM.Trace - ( nullTracer ) + ( Trace, logDebug ) import Cardano.Launcher - ( Command (..), ProcessHasExited (..), StdStream (..), launch ) + ( Command (..) + , LauncherLog + , ProcessHasExited (..) + , StdStream (..) + , transformLauncherTrace + , withBackendProcessHandle + ) +import Control.Concurrent + ( threadDelay ) +import Control.Concurrent.Async + ( async, race_, waitAnyCancel ) import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, tryReadMVar ) + ( modifyMVar_ + , newEmptyMVar + , newMVar + , putMVar + , readMVar + , takeMVar + , tryReadMVar + ) +import Control.Exception + ( IOException, bracket, handle ) +import Control.Monad + ( forever ) +import Control.Retry + ( constantDelay, limitRetriesByCumulativeDelay, recoverAll ) +import Data.Maybe + ( isJust ) import Data.Text ( Text ) +import Data.Time.Clock + ( diffUTCTime, getCurrentTime ) import Fmt ( pretty ) import System.Exit ( ExitCode (..) ) import System.Info ( os ) +import System.Process + ( ProcessHandle, getProcessExitCode, readProcessWithExitCode ) import Test.Hspec - ( Spec, it, shouldBe, shouldContain, shouldReturn ) + ( Spec + , beforeAll + , it + , shouldBe + , shouldContain + , shouldReturn + , shouldSatisfy + ) +import Test.Utils.Windows + ( isWindows ) {-# ANN spec ("HLint: ignore Use head" :: String) #-} spec :: Spec -spec = do - it "Buildable Command" $ do +spec = beforeAll setupMockCommands $ do + it "Buildable Command" $ \MockCommands{..} -> do let command = Command "server" [ "start" , "--port", "8080" @@ -40,78 +89,157 @@ spec = do \ --port 8080\n\ \ --template mainnet\n" - it "1st process exits with 0, others are cancelled" $ do + it "1st process exits with 0, others are cancelled" $ \MockCommands{..} -> withTestLogging $ \tr -> do let commands = [ mockCommand True (pure ()) , foreverCommand ] - (ProcessHasExited name code) <- launch nullTracer commands + (phs, ProcessHasExited name code) <- launch tr commands name `shouldBe` cmdName (commands !! 0) code `shouldBe` ExitSuccess + assertProcessesExited phs - it "2nd process exits with 0, others are cancelled" $ do + it "2nd process exits with 0, others are cancelled" $ \MockCommands{..} -> withTestLogging $ \tr -> do let commands = [ foreverCommand , mockCommand True (pure ()) ] - (ProcessHasExited name code) <- launch nullTracer commands + (phs, ProcessHasExited name code) <- launch tr commands name `shouldBe` cmdName (commands !! 1) code `shouldBe` ExitSuccess + assertProcessesExited phs - it "1st process exits with 3, others are cancelled" $ do + it "1st process exits with 1, others are cancelled" $ \MockCommands{..} -> withTestLogging $ \tr -> do let commands = [ mockCommand False (pure ()) , foreverCommand ] - (ProcessHasExited name code) <- launch nullTracer commands + (phs, ProcessHasExited name code) <- launch tr commands name `shouldBe` cmdName (commands !! 0) - code `shouldBe` (ExitFailure 3) + code `shouldBe` (ExitFailure 1) + assertProcessesExited phs - it "2nd process exits with 3, others are cancelled" $ do + it "2nd process exits with 1, others are cancelled" $ \MockCommands{..} -> withTestLogging $ \tr -> do let commands = [ foreverCommand , mockCommand False (pure ()) ] - (ProcessHasExited name code) <- launch nullTracer commands + (phs, ProcessHasExited name code) <- launch tr commands name `shouldBe` cmdName (commands !! 1) - code `shouldBe` (ExitFailure 3) + code `shouldBe` (ExitFailure 1) + assertProcessesExited phs - it "Process executes a command before they start" $ do + it "Process executes a command before they start" $ \MockCommands{..} -> withTestLogging $ \tr -> do mvar <- newEmptyMVar let before = putMVar mvar "executed" let commands = [ mockCommand True before ] - (ProcessHasExited _ code) <- launch nullTracer commands + (phs, ProcessHasExited _ code) <- launch tr commands code `shouldBe` ExitSuccess tryReadMVar mvar `shouldReturn` (Just @String "executed") + assertProcessesExited phs - it "Handles command not found" $ do + it "Handles command not found" $ \MockCommands{..} -> withTestLogging $ \tr -> do let commands = [ Command "foobar" [] (pure ()) Inherit ] - ProcessDidNotStart name _exc <- launch nullTracer commands + (phs, ProcessDidNotStart name _exc) <- launch tr commands name `shouldBe` "foobar" + assertProcessesExited phs - it "Sanity check System.Info.os" $ + it "Backend process is terminated when Async thread is cancelled" $ \MockCommands{..} -> withTestLogging $ \tr -> do + mvar <- newEmptyMVar + let backend = withBackendProcessHandle tr foreverCommand $ \ph -> do + putMVar mvar ph + forever $ threadDelay maxBound + before <- getCurrentTime + race_ backend (threadDelay 1000000) + after <- getCurrentTime + ph <- takeMVar mvar + assertProcessesExited [ph] + -- the total time taken should be about 1 second (the delay), definitely + -- never more that 2 seconds. + diffUTCTime after before `shouldSatisfy` (< 2) + + it "Sanity check System.Info.os" $ \_ -> ["linux", "darwin", "mingw32"] `shouldContain` [os] --- | A command that will run for a short time. -mockCommand :: Bool -> IO () -> Command -mockCommand success before - | isWindows && success = - Command "TIMEOUT" ["1"] before Inherit - | isWindows && not success = - Command "CHOICE" ["/T", "1", "/C", "wat", "/D", "t"] before Inherit - | otherwise = - Command "sh" ["-c", "sleep 1; exit " ++ show exitStatus] before Inherit - where exitStatus = if success then 0 else 3 :: Int - --- | A command that will run for longer than the other commands. -foreverCommand :: Command -foreverCommand - | isWindows = Command "TIMEOUT" ["30"] (pure ()) Inherit - | otherwise = Command "sleep" ["30"] (pure ()) Inherit - -isWindows :: Bool -isWindows = os == "mingw32" +data MockCommands = MockCommands + { mockCommand :: Bool -> IO () -> Command + -- ^ A command that will run for a short time. + , foreverCommand :: Command + -- ^ A command that will run for longer than the other commands. + } + +setupMockCommands :: IO MockCommands +setupMockCommands + | isWindows = setupWin <$> getIsWine + | otherwise = pure mockCommandsShell + where + mockCommandsShell = MockCommands + { mockCommand = \success before -> + let exitStatus = if success then 0 else 1 :: Int + in Command "sh" ["-c", "sleep 1; exit " ++ show exitStatus] before Inherit + , foreverCommand = Command "sleep" ["20"] (pure ()) Inherit + } + setupWin False = MockCommands + { mockCommand = \success before -> if success + then Command "TIMEOUT" ["1"] before Inherit + else Command "CHOICE" ["/T", "1", "/C", "wat", "/D", "w"] before Inherit + , foreverCommand = Command "TIMEOUT" ["20"] (pure ()) Inherit + } + setupWin True = MockCommands + { mockCommand = \success before -> if success + then Command "PING" ["127.0.0.1", "-n", "1", "-w", "1000"] before Inherit + else Command "START" ["/wait", "xyzzy"] before Inherit + , foreverCommand = Command "ping" ["127.0.0.1", "-n", "20", "-w", "1000"] (pure ()) Inherit + } + +-- | Use the presence of @winepath.exe@ to detect when running tests under Wine. +getIsWine :: IO Bool +getIsWine = handle (\(_ :: IOException) -> pure False) $ do + (code, _, _) <- readProcessWithExitCode "winepath" ["--version"] mempty + pure (code == ExitSuccess) + +-- | 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 (constantDelay 100) + test _ = do + statuses <- mapM getProcessExitCode phs + statuses `shouldSatisfy` all isJust + +withTestLogging :: (Trace IO LauncherLog -> IO a) -> IO a +withTestLogging action = + bracket before after (action . transformLauncherTrace . fst) + where + before = do + cfg <- defaultConfigStdout + setMinSeverity cfg Debug + setupTrace_ cfg "tests" + after (tr, sb) = do + logDebug tr "Logging shutdown." + shutdown sb diff --git a/lib/test-utils/src/Test/Utils/Windows.hs b/lib/test-utils/src/Test/Utils/Windows.hs index f3eaf8215ce..5c802f058d1 100644 --- a/lib/test-utils/src/Test/Utils/Windows.hs +++ b/lib/test-utils/src/Test/Utils/Windows.hs @@ -10,6 +10,7 @@ module Test.Utils.Windows ( skipOnWindows , pendingOnWindows , whenWindows + , isWindows ) where import Prelude @@ -32,4 +33,7 @@ pendingOnWindows :: HasCallStack => String -> Expectation pendingOnWindows reason = whenWindows $ pendingWith reason whenWindows :: IO () -> IO () -whenWindows = when (os == "mingw32") +whenWindows = when isWindows + +isWindows :: Bool +isWindows = os == "mingw32" diff --git a/nix/.stack.nix/cardano-wallet-launcher.nix b/nix/.stack.nix/cardano-wallet-launcher.nix index edf640d228a..f2b007bc14c 100644 --- a/nix/.stack.nix/cardano-wallet-launcher.nix +++ b/nix/.stack.nix/cardano-wallet-launcher.nix @@ -75,11 +75,16 @@ 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."cardano-wallet-test-utils" or (buildDepError "cardano-wallet-test-utils")) (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")) + (hsPkgs."time" or (buildDepError "time")) ]; build-tools = [ (hsPkgs.buildPackages.hspec-discover or (pkgs.buildPackages.hspec-discover or (buildToolDepError "hspec-discover")))