sandwich 0.2.1.0 → 0.2.2.0
raw patch · 4 files changed
+112/−30 lines, 4 filesdep +retryPVP ok
version bump matches the API change (PVP)
Dependencies added: retry
API changes (from Hackage documentation)
+ Test.Sandwich.Logging: callCommandWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()
+ Test.Sandwich.Logging: createProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> m ProcessHandle
+ Test.Sandwich.Logging: createProcessWithLoggingAndStdin' :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m ProcessHandle
+ Test.Sandwich.Logging: readCreateProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m String
+ Test.Sandwich.Util.Process: gracefullyStopProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()
+ Test.Sandwich.Util.Process: gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()
Files
- CHANGELOG.md +5/−0
- sandwich.cabal +32/−21
- src/Test/Sandwich/Logging.hs +30/−9
- src/Test/Sandwich/Util/Process.hs +45/−0
CHANGELOG.md view
@@ -2,6 +2,11 @@ ## Unreleased changes +## 0.2.2.0++* 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 * Improve clock management; don't keep incrementing it when nothing and restart it when r/R are pressed.
sandwich.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sandwich-version: 0.2.1.0+version: 0.2.2.0 synopsis: Yet another test framework for Haskell description: Please see the <https://codedownio.github.io/sandwich documentation>. category: Testing@@ -41,6 +41,7 @@ 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 @@ 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 @@ , optparse-applicative , pretty-show , process+ , retry , safe , safe-exceptions , stm@@ -158,14 +161,15 @@ 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 @@ , optparse-applicative , pretty-show , process+ , retry , safe , safe-exceptions , sandwich@@ -218,14 +223,15 @@ 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 @@ , optparse-applicative , pretty-show , process+ , retry , safe , safe-exceptions , sandwich@@ -283,14 +290,15 @@ 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 @@ , optparse-applicative , pretty-show , process+ , retry , safe , safe-exceptions , sandwich@@ -349,14 +358,15 @@ 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 @@ , optparse-applicative , pretty-show , process+ , retry , safe , safe-exceptions , sandwich
src/Test/Sandwich/Logging.hs view
@@ -14,6 +14,11 @@ , readCreateProcessWithLogging , createProcessWithLoggingAndStdin , callCommandWithLogging++ , createProcessWithLogging'+ , readCreateProcessWithLogging'+ , createProcessWithLoggingAndStdin'+ , callCommandWithLogging' ) where import Control.Concurrent@@ -23,7 +28,7 @@ import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Logger+import Control.Monad.Logger hiding (logOther) import Control.Monad.Trans.Control (MonadBaseControl) import Data.String.Interpolate import Data.Text@@ -70,7 +75,11 @@ -- | Spawn a process with its stdout and stderr connected to the logging system. -- Every line output by the process will be fed to a 'debug' call. createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> m ProcessHandle-createProcessWithLogging cp = do+createProcessWithLogging = createProcessWithLogging' LevelDebug++-- | Spawn a process with its stdout and stderr connected to the logging system.+createProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> m ProcessHandle+createProcessWithLogging' logLevel cp = do (hRead, hWrite) <- liftIO createPipe let name = case cmdspec cp of@@ -79,7 +88,7 @@ _ <- async $ forever $ do line <- liftIO $ hGetLine hRead- debug [i|#{name}: #{line}|]+ logOther logLevel [i|#{name}: #{line}|] (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite }) return p@@ -87,7 +96,11 @@ -- | Like 'readCreateProcess', but capture the stderr output in the logs. -- Every line output by the process will be fed to a 'debug' call. readCreateProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m String-readCreateProcessWithLogging cp input = do+readCreateProcessWithLogging = readCreateProcessWithLogging' LevelDebug++-- | Like 'readCreateProcess', but capture the stderr output in the logs.+readCreateProcessWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m String+readCreateProcessWithLogging' logLevel cp input = do (hReadErr, hWriteErr) <- liftIO createPipe let name = case cmdspec cp of@@ -96,7 +109,7 @@ _ <- async $ forever $ do line <- liftIO $ hGetLine hReadErr- debug [i|#{name}: #{line}|]+ logOther logLevel [i|#{name}: #{line}|] -- Do this just like 'readCreateProcess' -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess@@ -137,7 +150,11 @@ -- | Spawn a process with its stdout and stderr connected to the logging system. -- Every line output by the process will be fed to a 'debug' call. createProcessWithLoggingAndStdin :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m ProcessHandle-createProcessWithLoggingAndStdin cp input = do+createProcessWithLoggingAndStdin = createProcessWithLoggingAndStdin' LevelDebug++-- | Spawn a process with its stdout and stderr connected to the logging system.+createProcessWithLoggingAndStdin' :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m ProcessHandle+createProcessWithLoggingAndStdin' logLevel cp input = do (hRead, hWrite) <- liftIO createPipe let name = case cmdspec cp of@@ -146,7 +163,7 @@ _ <- async $ forever $ do line <- liftIO $ hGetLine hRead- debug [i|#{name}: #{line}|]+ logOther logLevel [i|#{name}: #{line}|] (Just inh, _, _, p) <- liftIO $ createProcess ( cp { std_out = UseHandle hWrite@@ -163,7 +180,11 @@ -- | Higher level version of 'createProcessWithLogging', accepting a shell command. callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()-callCommandWithLogging cmd = do+callCommandWithLogging = callCommandWithLogging' LevelDebug++-- | Higher level version of 'createProcessWithLogging'', accepting a shell command.+callCommandWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()+callCommandWithLogging' logLevel cmd = do (hRead, hWrite) <- liftIO createPipe (_, _, _, p) <- liftIO $ createProcess (shell cmd) {@@ -174,7 +195,7 @@ _ <- async $ forever $ do line <- liftIO $ hGetLine hRead- debug [i|#{cmd}: #{line}|]+ logOther logLevel [i|#{cmd}: #{line}|] liftIO (waitForProcess p) >>= \case ExitSuccess -> return ()
+ src/Test/Sandwich/Util/Process.hs view
@@ -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