Launcher: Fix backend process concurrency issue on Windows

- Fix backend process concurrency issue on Windows

- Also get the LauncherSpec working on wine.
  It needs to detect Wine, then use commands which are available on wine.

- LauncherSpec: Add an assertion that withCreateProcess does not block

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))
@@ -67,12 +68,14 @@ test-suite unit
       base
     , async
     , cardano-wallet-launcher
+    , cardano-wallet-test-utils
     , fmt
     , hspec
     , iohk-monitoring
     , process
     , retry
     , text
+    , time
   build-tools:
       hspec-discover
   type:

lib/launcher/src/Cardano/Launcher.hs

@@ -33,12 +33,16 @@ import Cardano.BM.Data.Severity
     ( Severity (..) )
 import Cardano.BM.Trace
     ( Trace, appendName, traceNamedItem )
+import Control.Concurrent
+    ( forkIO )
 import Control.Concurrent.Async
     ( race )
+import Control.Concurrent.MVar
+    ( newEmptyMVar, putMVar, takeMVar )
 import Control.Exception
-    ( Exception, IOException, tryJust )
+    ( Exception, IOException, onException, tryJust )
 import Control.Monad
-    ( join )
+    ( join, void )
 import Control.Monad.IO.Class
     ( MonadIO (..) )
 import Control.Tracer
@@ -173,8 +177,14 @@ withBackendProcessHandle 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 h <* 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
@@ -187,14 +197,39 @@ withBackendProcessHandle 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
 -------------------------------------------------------------------------------}
 
 data LauncherLog
     = MsgLauncherStart Command
     | MsgLauncherStarted String Text
+    | MsgLauncherWaitBefore
+    | MsgLauncherWaitAfter Int
+    | MsgLauncherCancel
     | MsgLauncherFinish ProcessHasExited
+    | MsgLauncherAction
     | MsgLauncherCleanup
     deriving (Generic, ToJSON)
 
@@ -220,21 +255,29 @@ 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
 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"
 
 {-------------------------------------------------------------------------------

lib/launcher/test/unit/Cardano/LauncherSpec.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Cardano.LauncherSpec
@@ -7,13 +9,22 @@ 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
-    ( Trace, nullTracer )
+    ( Trace, logDebug )
 import Cardano.Launcher
     ( Command (..)
     , LauncherLog
     , ProcessHasExited (..)
     , StdStream (..)
+    , transformLauncherTrace
     , withBackendProcessHandle
     )
 import Control.Concurrent
@@ -29,6 +40,8 @@ import Control.Concurrent.MVar
     , takeMVar
     , tryReadMVar
     )
+import Control.Exception
+    ( IOException, bracket, handle )
 import Control.Monad
     ( forever )
 import Control.Retry
@@ -37,21 +50,32 @@ 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 )
+    ( ProcessHandle, getProcessExitCode, readProcessWithExitCode )
 import Test.Hspec
-    ( Spec, it, shouldBe, shouldContain, shouldReturn, shouldSatisfy )
+    ( 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"
@@ -65,96 +89,116 @@ 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
               ]
-        (phs, 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 ())
               ]
-        (phs, 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
               ]
-        (phs, 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 ())
               ]
-        (phs, 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
                 ]
-        (phs, 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
                 ]
-        (phs, ProcessDidNotStart name _exc) <- launch nullTracer commands
+        (phs, ProcessDidNotStart name _exc) <- launch tr commands
         name `shouldBe` "foobar"
         assertProcessesExited phs
 
-    it "Backend process is terminated when Async thread is cancelled" $ do
+    it "Backend process is terminated when Async thread is cancelled" $ \MockCommands{..} -> withTestLogging $ \tr -> do
         mvar <- newEmptyMVar
-        let backend =  withBackendProcessHandle nullTracer foreverCommand $ \ph -> do
+        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]
+        diffUTCTime after before `shouldSatisfy` (< 2)
 
-    it "Sanity check System.Info.os" $
+    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.
@@ -185,3 +229,15 @@ assertProcessesExited phs = recoverAll policy test
     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

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"