Expose Test.Sandwich.Util.Process

codedownio · Jan 7, 2024 · 711d25e · 711d25e
1 parent 557515b
commit 711d25e
Show file tree

Hide file tree

Showing 6 changed files with 85 additions and 56 deletions.
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/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

diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs b/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
diff --git a/sandwich/CHANGELOG.md b/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
 

diff --git a/sandwich/package.yaml b/sandwich/package.yaml
@@ -14,14 +14,15 @@ extra-source-files:
 - CHANGELOG.md
 
 default-extensions:
+- FlexibleContexts
+- FlexibleInstances
+- LambdaCase
+- NamedFieldPuns
+- NumericUnderscores
 - OverloadedStrings
 - QuasiQuotes
-- NamedFieldPuns
 - RecordWildCards
 - ScopedTypeVariables
-- FlexibleContexts
-- FlexibleInstances
-- LambdaCase
 - ViewPatterns
 
 dependencies:
@@ -47,6 +48,7 @@ dependencies:
 - optparse-applicative
 - pretty-show
 - process
+- retry
 - safe
 - safe-exceptions
 - stm
@@ -89,6 +91,7 @@ library:
   - Test.Sandwich.Formatters.TerminalUI
   - Test.Sandwich.Internal
   - Test.Sandwich.TH
+  - Test.Sandwich.Util.Process
   when:
   - condition: "os(windows)"
     dependencies:

diff --git a/sandwich/sandwich.cabal b/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
@@ -96,14 +97,15 @@ library
   hs-source-dirs:
       src
   default-extensions:
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+      NamedFieldPuns
+      NumericUnderscores
       OverloadedStrings
       QuasiQuotes
-      NamedFieldPuns
       RecordWildCards
       ScopedTypeVariables
-      FlexibleContexts
-      FlexibleInstances
-      LambdaCase
       ViewPatterns
   ghc-options: -W
   build-depends:
@@ -130,6 +132,7 @@ library
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , stm
@@ -158,14 +161,15 @@ executable sandwich-demo
   hs-source-dirs:
       app
   default-extensions:
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+      NamedFieldPuns
+      NumericUnderscores
       OverloadedStrings
       QuasiQuotes
-      NamedFieldPuns
       RecordWildCards
       ScopedTypeVariables
-      FlexibleContexts
-      FlexibleInstances
-      LambdaCase
       ViewPatterns
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
@@ -192,6 +196,7 @@ executable sandwich-demo
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , sandwich
@@ -218,14 +223,15 @@ executable sandwich-discover
   hs-source-dirs:
       discover
   default-extensions:
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+      NamedFieldPuns
+      NumericUnderscores
       OverloadedStrings
       QuasiQuotes
-      NamedFieldPuns
       RecordWildCards
       ScopedTypeVariables
-      FlexibleContexts
-      FlexibleInstances
-      LambdaCase
       ViewPatterns
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
@@ -252,6 +258,7 @@ executable sandwich-discover
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , sandwich
@@ -283,14 +290,15 @@ executable sandwich-test
   hs-source-dirs:
       test
   default-extensions:
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+      NamedFieldPuns
+      NumericUnderscores
       OverloadedStrings
       QuasiQuotes
-      NamedFieldPuns
       RecordWildCards
       ScopedTypeVariables
-      FlexibleContexts
-      FlexibleInstances
-      LambdaCase
       ViewPatterns
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
@@ -317,6 +325,7 @@ executable sandwich-test
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , sandwich
@@ -349,14 +358,15 @@ test-suite sandwich-test-suite
   hs-source-dirs:
       test
   default-extensions:
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+      NamedFieldPuns
+      NumericUnderscores
       OverloadedStrings
       QuasiQuotes
-      NamedFieldPuns
       RecordWildCards
       ScopedTypeVariables
-      FlexibleContexts
-      FlexibleInstances
-      LambdaCase
       ViewPatterns
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
@@ -383,6 +393,7 @@ test-suite sandwich-test-suite
     , optparse-applicative
     , pretty-show
     , process
+    , retry
     , safe
     , safe-exceptions
     , sandwich

diff --git a/sandwich/src/Test/Sandwich/Util/Process.hs b/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