@@ -9,8 +9,10 @@
99-- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`)
1010-- and is thus spinner friendly.
1111module Obelisk.CliApp.Process
12− ( ProcessFailed (..)
12+ ( ProcessFailure (..)
13+ , AsProcessFailure (..)
1314 , readProcessAndLogStderr
15+ , readProcessAndLogOutput
1416 , callProcessAndLogOutput
1517 , createProcess
1618 , createProcess_
@@ -18,16 +20,18 @@ module Obelisk.CliApp.Process
1820 , callCommand
1921 ) where
2022
21−import Control.Applicative (liftA2)
22−import Control.Monad (void, (<=<))
23−import Control.Monad.Catch (Exception(..), MonadMask, throwM)
23+import Control.Monad ((<=<), join, void)
24+import Control.Monad.Except (throwError)
2425import Control.Monad.IO.Class (MonadIO, liftIO)
26+import Control.Lens (Prism', review)
27+import qualified Data.ByteString as BS
2528import qualified Data.ByteString.Char8 as BSC
2629import Data.Function (fix)
2730import Data.Monoid ((<>))
31+import Data.Text (Text)
2832import qualified Data.Text as T
29−import Data.Text.Encoding (decodeUtf8)
30−import qualified Data.Text.IO as T
33+import qualified Data.Text.Encoding as T
34+--import qualified Data.Text.IO as T
3135import System.Exit (ExitCode (..))
3236import System.IO (Handle)
3337import System.IO.Streams (InputStream, handleToInputStream)
@@ -39,60 +43,90 @@ import qualified System.Process as Process
3943
4044import Control.Monad.Log (Severity (..))
4145import Obelisk.CliApp.Logging (putLog, putLogRaw)
42−import Obelisk.CliApp.Types (Cli)
46+import Obelisk.CliApp.Types (CliLog, CliThrow)
4347
44−data ProcessFailed = ProcessFailed Process.CmdSpec Int -- exit code
48+-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions
49+data ProcessFailure = ProcessFailure Process.CmdSpec Int -- exit code
4550 deriving Show
4651
47−instance Exception ProcessFailed where
48− displayException (ProcessFailed spec exitCode) =
49− unwords ["ProcessFailed", reconstructCommand spec, show exitCode]
52+-- | Indicates arbitrary process failures form one variant (or conceptual projection) of
53+-- the error type.
54+class AsProcessFailure e where
55+ asProcessFailure :: Prism' e ProcessFailure
56+
57+instance AsProcessFailure ProcessFailure where
58+ asProcessFailure = id
5059
5160readProcessAndLogStderr
52− :: (MonadIO m, MonadMask m, Cli m)
53− => Severity -> CreateProcess -> m String
61+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
62+ => Severity -> CreateProcess -> m Text
5463readProcessAndLogStderr sev process = do
5564 (out, _err) <- withProcess process $ \_out err -> do
5665 streamToLog =<< liftIO (streamHandle sev err)
57− -- TODO: Why are we using Text here?
58− liftIO $ T.unpack . T.strip <$> T.hGetContents out
66+ liftIO $ T.decodeUtf8 <$> BS.hGetContents out
5967
60−-- | Like `System.Process.callProcess` but logs the combined output--stdout and stderr with the corresponding
61−-- severity.
68+-- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr)
69+-- with the corresponding severity.
6270--
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)`.
71+-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
72+-- some processes are known to spit out diagnostic or informative messages in stderr, in
73+-- which case it is advisable to call it with a non-Error severity for stderr, like
74+-- `callProcessAndLogOutput (Debug, Debug)`.
75+readProcessAndLogOutput
76+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
77+ => (Severity, Severity) -> CreateProcess -> m Text
78+readProcessAndLogOutput (sev_out, sev_err) process = do
79+ (_, Just out, Just err, p) <- createProcess $ process
80+ { std_out = CreatePipe , std_err = CreatePipe }
81+
82+ -- TODO interleave stdout and stderr in log correctly
83+ streamToLog =<< liftIO (streamHandle sev_err err)
84+ outText <- liftIO $ T.decodeUtf8 <$> BS.hGetContents out
85+ putLogRaw sev_out outText
86+
87+ liftIO (waitForProcess p) >>= \case
88+ ExitSuccess -> pure outText
89+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code
90+
91+-- | Like `System.Process.callProcess` but logs the combined output (stdout and stderr)
92+-- with the corresponding severity.
93+--
94+-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
95+-- some processes are known to spit out diagnostic or informative messages in stderr, in
96+-- which case it is advisable to call it with a non-Error severity for stderr, like
97+-- `callProcessAndLogOutput (Debug, Debug)`.
6698callProcessAndLogOutput
67− :: (MonadIO m, MonadMask m, Cli m)
99+
100+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
68101 => (Severity, Severity) -> CreateProcess -> m ()
69−callProcessAndLogOutput (sev_out, sev_err) process = do
102+callProcessAndLogOutput (sev_out, sev_err) process =
70103 void $ withProcess process $ \out err -> do
71− stream <- liftIO $ do
72− uncurry combineStream =<< liftA2 (,) (streamHandle sev_out out) (streamHandle sev_err err)
104+ stream <- liftIO $ join $ combineStream
105+ <$> streamHandle sev_out out
106+ <*> streamHandle sev_err err
73107 streamToLog stream
74108 where
75109 combineStream s1 s2 = concurrentMerge [s1, s2]
76110
77111-- | Like `System.Process.createProcess` but also logs (debug) the process being run
78112createProcess
79− :: (MonadIO m, Cli m)
113+ :: (MonadIO m, CliLog m)
80114 => CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
81115createProcess p = do
82− putLog Debug $ "Creating process: " <> T.pack (reconstructCommand (cmdspec p))
116+ putLog Debug $ "Creating process: " <> reconstructCommand (cmdspec p)
83117 liftIO $ Process.createProcess p
84118
85119-- | Like `System.Process.createProcess_` but also logs (debug) the process being run
86120createProcess_
87− :: (MonadIO m, Cli m)
121+ :: (MonadIO m, CliLog m)
88122 => String -> CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
89123createProcess_ name p = do
90− putLog Debug $ "Creating process " <> T.pack name <> ": " <> T.pack (reconstructCommand (cmdspec p))
124+ putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructCommand (cmdspec p)
91125 liftIO $ Process.createProcess p
92126
93127-- | Like `System.Process.callProcess` but also logs (debug) the process being run
94128callProcess
95− :: (MonadIO m, Cli m)
129+ :: (MonadIO m, CliLog m)
96130 => String -> [String] -> m ()
97131callProcess exe args = do
98132 putLog Debug $ "Calling process " <> T.pack exe <> " with args: " <> T.pack (show args)
@@ -100,14 +134,14 @@ callProcess exe args = do
100134
101135-- | Like `System.Process.callCommand` but also logs (debug) the command being run
102136callCommand
103− :: (MonadIO m, Cli m)
137+ :: (MonadIO m, CliLog m)
104138 => String -> m ()
105139callCommand cmd = do
106140 putLog Debug $ "Calling command " <> T.pack cmd
107141 liftIO $ Process.callCommand cmd
108142
109143withProcess
110− :: (MonadIO m, MonadMask m, Cli m)
144+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
111145 => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
112146withProcess process f = do -- TODO: Use bracket.
113147 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.
@@ -118,7 +152,7 @@ withProcess process f = do -- TODO: Use bracket.
118152
119153 liftIO (waitForProcess p) >>= \case
120154 ExitSuccess -> return (out, err)
121− ExitFailure code -> throwM $ ProcessFailed (cmdspec process) code
155+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code
122156
123157-- Create an input stream from the file handle, associating each item with the given severity.
124158streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))
@@ -126,16 +160,16 @@ streamHandle sev = Streams.map (sev,) <=< handleToInputStream
126160
127161-- | Read from an input stream and log its contents
128162streamToLog
129− :: (MonadIO m, MonadMask m, Cli m)
163+ :: (MonadIO m, CliLog m)
130164 => InputStream (Severity, BSC.ByteString) -> m ()
131165streamToLog stream = fix $ \loop -> do
132166 liftIO (Streams.read stream) >>= \case
133167 Nothing -> return ()
134− Just (sev, line) -> putLogRaw sev (decodeUtf8 line) >> loop
168+ Just (sev, line) -> putLogRaw sev (T.decodeUtf8 line) >> loop
135169
136−reconstructCommand :: Process.CmdSpec -> String
137−reconstructCommand (Process.ShellCommand str) = str
170+reconstructCommand :: Process.CmdSpec -> Text
171+reconstructCommand (Process.ShellCommand str) = T.pack str
138172reconstructCommand (Process.RawCommand c as) = processToShellString c as
139173 where
140− processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)
141− quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"
174+ processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)
175+ quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"