diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs index 7a4caab8..c022fe3e 100644 --- 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 index d7a700af..777a49b4 100644 --- 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 index f1c920cf..a008b902 100644 --- 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 index e0919ebb..93ec8359 100644 --- 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 index b8bff12b..6d980514 100644 --- 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 new file mode 100644 index 00000000..736fcb69 --- /dev/null +++ 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