sandwich 0.1.5.0 → 0.1.5.1

raw patch · 6 files changed

+107/−17 lines, 6 filesdep +deepseqPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: deepseq

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• sandwich.cabal +6/−1
• src/Test/Sandwich/Logging.hs +96/−13
• unix-src/Test/Sandwich/Formatters/TerminalUI.hs +1/−1
• unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs +0/−1
• unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +0/−1

@@ -2,6 +2,10 @@  ## Unreleased changes +## 0.1.5.1++* Logging: add readCreateProcessWithLogging+ ## 0.1.5.0  * GHC 9.6 support

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           sandwich-version:        0.1.5.0+version:        0.1.5.1 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing@@ -101,6 +101,7 @@     , bytestring     , colour     , containers+    , deepseq     , directory     , exceptions     , filepath@@ -178,6 +179,7 @@     , bytestring     , colour     , containers+    , deepseq     , directory     , exceptions     , filepath@@ -236,6 +238,7 @@     , bytestring     , colour     , containers+    , deepseq     , directory     , exceptions     , filepath@@ -299,6 +302,7 @@     , bytestring     , colour     , containers+    , deepseq     , directory     , exceptions     , filepath@@ -363,6 +367,7 @@     , bytestring     , colour     , containers+    , deepseq     , directory     , exceptions     , filepath

@@ -2,9 +2,23 @@  -- | Logging functions. -module Test.Sandwich.Logging where+module Test.Sandwich.Logging (+  debug+  , info+  , warn+  , Test.Sandwich.Logging.logError+  , Test.Sandwich.Logging.logOther +  -- * Process functions with logging+  , createProcessWithLogging+  , readCreateProcessWithLogging+  , createProcessWithLoggingAndStdin+  , callCommandWithLogging+  ) where++import Control.Concurrent import Control.Concurrent.Async.Lifted+import Control.DeepSeq (rnf) import qualified Control.Exception as C import Control.Exception.Safe import Control.Monad@@ -17,6 +31,7 @@ import GHC.IO.Exception import GHC.Stack import System.IO+import System.IO.Error (mkIOError) import System.Process  #if !MIN_VERSION_base(4,13,0)@@ -52,8 +67,8 @@ -- -- | Functions for launching processes while capturing their output in the logs. --- | 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.+-- | 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   (hRead, hWrite) <- liftIO createPipe@@ -69,8 +84,58 @@   (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })   return p --- | 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.+-- | 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+  (hReadErr, hWriteErr) <- liftIO createPipe++  let name = case cmdspec cp of+        ShellCommand {} -> "shell"+        RawCommand path _ -> path++  _ <- async $ forever $ do+    line <- liftIO $ hGetLine hReadErr+    debug [i|#{name}: #{line}|]++  -- Do this just like 'readCreateProcess'+  -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess+  (ex, output) <- liftIO $ withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) $ \sin sout _ p -> do+    case (sin, sout) of+      (Just hIn, Just hOut) -> do+        output  <- hGetContents hOut+        withForkWait (C.evaluate $ rnf output) $ \waitOut -> do+          -- now write any input+          unless (Prelude.null input) $+            ignoreSigPipe $ hPutStr hIn input+          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE+          ignoreSigPipe $ hClose hIn++          -- wait on the output+          waitOut+          hClose hOut++        -- wait on the process+        ex <- waitForProcess p+        return (ex, output)+      (Nothing, _) -> liftIO $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."+      (_, Nothing) -> liftIO $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."++  case ex of+    ExitSuccess -> return output+    ExitFailure r -> liftIO $ processFailedException "readCreateProcessWithLogging" cmd args r++  where+    cmd = case cp of+            CreateProcess { cmdspec = ShellCommand sc } -> sc+            CreateProcess { cmdspec = RawCommand fp _ } -> fp+    args = case cp of+             CreateProcess { cmdspec = ShellCommand _ } -> []+             CreateProcess { cmdspec = RawCommand _ args' } -> args'+++-- | 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   (hRead, hWrite) <- liftIO createPipe@@ -96,14 +161,6 @@    return p -  where-    -- Copied from System.Process-    ignoreSigPipe :: IO () -> IO ()-    ignoreSigPipe = C.handle $ \case-      IOError { ioe_type  = ResourceVanished, ioe_errno = Just ioe } | Errno ioe == ePIPE -> return ()-      e -> throwIO e-- -- | Higher level version of 'createProcessWithLogging', accepting a shell command. callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m () callCommandWithLogging cmd = do@@ -122,3 +179,29 @@   liftIO (waitForProcess p) >>= \case     ExitSuccess -> return ()     ExitFailure r -> liftIO $ throw $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]+++-- * Util++-- Copied from System.Process+withForkWait :: IO () -> (IO () ->  IO a) -> IO a+withForkWait async body = do+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))+  mask $ \restore -> do+    tid <- forkIO $ try (restore async) >>= putMVar waitVar+    let wait = takeMVar waitVar >>= either throwIO return+    restore (body wait) `C.onException` killThread tid++-- Copied from System.Process+ignoreSigPipe :: IO () -> IO ()+ignoreSigPipe = C.handle $ \case+  IOError { ioe_type  = ResourceVanished, ioe_errno = Just ioe } | Errno ioe == ePIPE -> return ()+  e -> throwIO e++-- Copied from System.Process+processFailedException :: String -> String -> [String] -> Int -> IO a+processFailedException fun cmd args exit_code =+      ioError (mkIOError OtherError (fun ++ ": " ++ cmd +++                                     Prelude.concatMap ((' ':) . show) args +++                                     " (exit " ++ show exit_code ++ ")")+                                 Nothing Nothing)

@@ -313,7 +313,7 @@       & appShowFileLocations %~ not     V.EvKey c [] | c == toggleVisibilityThresholdsKey -> continue $ s       & appShowVisibilityThresholds %~ not-    V.EvKey c [] | c `elem` [V.KEsc, exitKey]-> do+    V.EvKey c [] | c `elem` [V.KEsc, exitKey] -> do       -- Cancel everything and wait for cleanups       liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)       forM_ (s ^. appRunTreeBase) (liftIO . waitForTree)

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}--- |  module Test.Sandwich.Formatters.TerminalUI.Draw.Util where 

@@ -1,4 +1,3 @@--- |  module Test.Sandwich.Formatters.TerminalUI.Keys where