Expose Test.Sandwich.Util.Process

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs

@@ -32,6 +32,7 @@ import System.FilePath
 import System.IO
 import System.Process
 import Test.Sandwich
+import Test.Sandwich.Util.Process
 import Test.Sandwich.WebDriver.Internal.Binaries
 import Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (detectChromeVersion)
 import Test.Sandwich.WebDriver.Internal.Ports

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs

@@ -6,16 +6,12 @@ import Control.Exception
 import qualified Control.Exception.Lifted as E
 import Control.Monad
 import Control.Monad.IO.Class
-import Control.Monad.Logger
 import Control.Monad.Trans.Control (MonadBaseControl)
-import Control.Retry
-import Data.Maybe
 import Data.String.Interpolate
 import qualified Data.Text as T
 import System.Directory
 import System.Process
 import qualified System.Random as R
-import Test.Sandwich.Logging
 
 #ifdef mingw32_HOST_OS
 import System.IO
@@ -67,31 +63,3 @@ whenRight (Right x) action = action x
 
 makeUUID :: IO T.Text
 makeUUID = (T.pack . take 10 . R.randomRs ('a','z')) <$> R.newStdGen
-
--- * Stopping processes
-
-gracefullyStopProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()
-gracefullyStopProcess p gracePeriodUs = do
-  liftIO $ interruptProcessGroupOf p
-  gracefullyWaitForProcess p gracePeriodUs
-
-gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()
-gracefullyWaitForProcess p gracePeriodUs = do
-  let waitForExit = do
-        let policy = limitRetriesByCumulativeDelay gracePeriodUs $ capDelay 200_000 $ exponentialBackoff 1_000
-        retrying policy (\_ x -> return $ isNothing x) $ \_ -> do
-          liftIO $ getProcessExitCode p
-
-  waitForExit >>= \case
-    Just _ -> return ()
-    Nothing -> do
-      pid <- liftIO $ getPid p
-      warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|]
-
-      liftIO $ interruptProcessGroupOf p
-      waitForExit >>= \case
-        Just _ -> return ()
-        Nothing -> void $ do
-          warn [i|(#{pid}) Process didn't stop after a further #{gracePeriodUs}us; going to kill|]
-          liftIO $ terminateProcess p
-          liftIO $ waitForProcess p

sandwich/CHANGELOG.md

@@ -3,6 +3,7 @@
 ## Unreleased changes
 
 * Add primed versions of createProcessWithLogging etc. with customizable log level
+* Add `Test.Sandwich.Util.Process` with `gracefullyStopProcess` and `gracefullyWaitForProcess` (and remove these from an internal `sandwich-webdriver` module).
 
 ## 0.2.1.0
 

sandwich/package.yaml

@@ -47,6 +47,7 @@ dependencies:
 - optparse-applicative
 - pretty-show
 - process
+- retry
 - safe
 - safe-exceptions
 - stm
@@ -89,6 +90,7 @@ library:
   - Test.Sandwich.Formatters.TerminalUI
   - Test.Sandwich.Internal
   - Test.Sandwich.TH
+  - Test.Sandwich.Util.Process
   when:
   - condition: "os(windows)"
     dependencies:

sandwich/sandwich.cabal

@@ -41,6 +41,7 @@ library
       Test.Sandwich.Formatters.TerminalUI
       Test.Sandwich.Internal
       Test.Sandwich.TH
+      Test.Sandwich.Util.Process
   other-modules:
       Test.Sandwich.ArgParsing
       Test.Sandwich.Formatters.Common.Count
@@ -130,6 +131,7 @@ library
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , stm
@@ -192,6 +194,7 @@ executable sandwich-demo
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , sandwich
@@ -252,6 +255,7 @@ executable sandwich-discover
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , sandwich
@@ -317,6 +321,7 @@ executable sandwich-test
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , sandwich
@@ -383,6 +388,7 @@ test-suite sandwich-test-suite
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , sandwich

sandwich/src/Test/Sandwich/Util/Process.hs

@@ -0,0 +1,45 @@
+
+module Test.Sandwich.Util.Process (
+  gracefullyStopProcess
+  , gracefullyWaitForProcess
+  ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Control.Retry
+import Data.Maybe
+import Data.String.Interpolate
+import System.Process
+import Test.Sandwich.Logging
+
+
+-- | Interrupt a process and wait for it to terminate.
+gracefullyStopProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()
+gracefullyStopProcess p gracePeriodUs = do
+  liftIO $ interruptProcessGroupOf p
+  gracefullyWaitForProcess p gracePeriodUs
+
+-- | Wait for a process to terminate. If it doesn't terminate within 'gracePeriodUs' microseconds,
+-- send it an interrupt signal and wait for another 'gracePeriodUs' microseconds.
+-- After this time elapses send a terminate signal and wait for the process to die.
+gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()
+gracefullyWaitForProcess p gracePeriodUs = do
+  let waitForExit = do
+        let policy = limitRetriesByCumulativeDelay gracePeriodUs $ capDelay 200_000 $ exponentialBackoff 1_000
+        retrying policy (\_ x -> return $ isNothing x) $ \_ -> do
+          liftIO $ getProcessExitCode p
+
+  waitForExit >>= \case
+    Just _ -> return ()
+    Nothing -> do
+      pid <- liftIO $ getPid p
+      warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|]
+
+      liftIO $ interruptProcessGroupOf p
+      waitForExit >>= \case
+        Just _ -> return ()
+        Nothing -> void $ do
+          warn [i|(#{pid}) Process didn't stop after a further #{gracePeriodUs}us; going to kill|]
+          liftIO $ terminateProcess p
+          liftIO $ waitForProcess p