@@ -11,6 +11,7 @@
1111module Obelisk.CliApp.Process
1212 ( ProcessFailed (..)
1313 , readProcessAndLogStderr
14+ , readProcessAndLogOutput
1415 , callProcessAndLogOutput
1516 , createProcess
1617 , createProcess_
@@ -18,16 +19,18 @@ module Obelisk.CliApp.Process
1819 , callCommand
1920 ) where
2021
21−import Control.Applicative (liftA2)
22−import Control.Monad (void, (<=<))
22+import Control.Monad ((<=<), join, void)
2323import Control.Monad.Catch (Exception(..), MonadMask, throwM)
24+import Control.Monad.Except (throwError)
2425import Control.Monad.IO.Class (MonadIO, liftIO)
26+import qualified Data.ByteString as BS
2527import qualified Data.ByteString.Char8 as BSC
2628import Data.Function (fix)
2729import Data.Monoid ((<>))
30+import Data.Text (Text)
2831import qualified Data.Text as T
29−import Data.Text.Encoding (decodeUtf8)
30−import qualified Data.Text.IO as T
32+import qualified Data.Text.Encoding as T
33+--import qualified Data.Text.IO as T
3134import System.Exit (ExitCode (..))
3235import System.IO (Handle)
3336import System.IO.Streams (InputStream, handleToInputStream)
@@ -50,26 +53,52 @@ instance Exception ProcessFailed where
5053
5154readProcessAndLogStderr
5255 :: (MonadIO m, MonadMask m, Cli m)
53− => Severity -> CreateProcess -> m String
56+ => Severity -> CreateProcess -> m Text
5457readProcessAndLogStderr sev process = do
5558 (out, _err) <- withProcess process $ \_out err -> do
5659 streamToLog =<< liftIO (streamHandle sev err)
57− -- TODO: Why are we using Text here?
58− liftIO $ T.unpack . T.strip <$> T.hGetContents out
60+ liftIO $ T.decodeUtf8 <$> BS.hGetContents out
5961
60−-- | Like `System.Process.callProcess` but logs the combined output--stdout and stderr with the corresponding
61−-- severity.
62+-- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr)
63+-- with the corresponding severity.
6264--
63−-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However some processes
64−-- are known to spit out diagnostic or informative messages in stderr, in which case it is advisable to call
65−-- it with a non-Error severity for stderr, like `callProcessAndLogOutput (Debug, Debug)`.
65+-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
66+-- some processes are known to spit out diagnostic or informative messages in stderr, in
67+-- which case it is advisable to call it with a non-Error severity for stderr, like
68+-- `callProcessAndLogOutput (Debug, Debug)`.
69+
70+readProcessAndLogOutput
71+ :: (MonadIO m, MonadMask m, Cli m)
72+ => (Severity, Severity) -> CreateProcess -> m Text
73+readProcessAndLogOutput (sev_out, sev_err) process = do
74+ (_, Just out, Just err, p) <- createProcess $ process
75+ { std_out = CreatePipe , std_err = CreatePipe }
76+
77+ -- TODO interleave stdout and stderr in log correctly
78+ streamToLog =<< liftIO (streamHandle sev_err err)
79+ outText <- liftIO $ T.decodeUtf8 <$> BS.hGetContents out
80+ putLogRaw sev_out outText
81+
82+ liftIO (waitForProcess p) >>= \case
83+ ExitSuccess -> pure outText
84+ ExitFailure code -> throwError $ T.pack $ show $ ProcessFailed (cmdspec process) code
85+
86+-- | Like `System.Process.callProcess` but logs the combined output (stdout and stderr)
87+-- with the corresponding severity.
88+--
89+-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
90+-- some processes are known to spit out diagnostic or informative messages in stderr, in
91+-- which case it is advisable to call it with a non-Error severity for stderr, like
92+-- `callProcessAndLogOutput (Debug, Debug)`.
6693callProcessAndLogOutput
94+
6795 :: (MonadIO m, MonadMask m, Cli m)
6896 => (Severity, Severity) -> CreateProcess -> m ()
69−callProcessAndLogOutput (sev_out, sev_err) process = do
97+callProcessAndLogOutput (sev_out, sev_err) process =
7098 void $ withProcess process $ \out err -> do
71− stream <- liftIO $ do
72− uncurry combineStream =<< liftA2 (,) (streamHandle sev_out out) (streamHandle sev_err err)
99+ stream <- liftIO $ join $ combineStream
100+ <$> streamHandle sev_out out
101+ <*> streamHandle sev_err err
73102 streamToLog stream
74103 where
75104 combineStream s1 s2 = concurrentMerge [s1, s2]
@@ -131,7 +160,7 @@ streamToLog
131160streamToLog stream = fix $ \loop -> do
132161 liftIO (Streams.read stream) >>= \case
133162 Nothing -> return ()
134− Just (sev, line) -> putLogRaw sev (decodeUtf8 line) >> loop
163+ Just (sev, line) -> putLogRaw sev (T.decodeUtf8 line) >> loop
135164
136165reconstructCommand :: Process.CmdSpec -> String
137166reconstructCommand (Process.ShellCommand str) = str