@@ -0,0 +1,80 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE MultiWayIf #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+
7+-- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`)
8+-- and is thus spinner friendly.
9+module Obelisk.CLI.Process
10+ ( readProcessAndLogStderr
11+ , callProcessAndLogOutput
12+ ) where
13+
14+import Control.Applicative (liftA2)
15+import Control.Monad (void)
16+import Control.Monad.Catch (MonadMask)
17+import Control.Monad.Fix (fix)
18+import Control.Monad.IO.Class (liftIO)
19+import Control.Monad.Log (MonadLog)
20+import Control.Monad.Reader (MonadIO)
21+import qualified Data.ByteString.Char8 as BSC
22+import Data.Monoid ((<>))
23+import qualified Data.Text as T
24+import Data.Text.Encoding (decodeUtf8)
25+import qualified Data.Text.IO as T
26+import System.Exit (ExitCode (..))
27+import System.IO (Handle)
28+import System.IO.Streams (InputStream, handleToInputStream)
29+import qualified System.IO.Streams as Streams
30+import System.IO.Streams.Concurrent (concurrentMerge)
31+import System.Process
32+
33+import Obelisk.CLI.Logging (Output, Severity (..), failWith, putLogRaw)
34+
35+-- | Like `System.Process.readProcess` but logs the stderr instead of letting the external process inherit it.
36+readProcessAndLogStderr
37+ :: (MonadIO m, MonadMask m, MonadLog Output m)
38+ => Severity -> CreateProcess -> m String
39+readProcessAndLogStderr sev process = do
40+ (out, _err) <- withProcess process $ \_out err -> do
41+ streamToLog sev =<< liftIO (handleToInputStream err)
42+ -- TODO: Why are we using Text here?
43+ liftIO $ T.unpack . T.strip <$> T.hGetContents out
44+
45+-- | Like `System.Process.callProcess` but logs the combined output (stdout and stderr)
46+callProcessAndLogOutput
47+ :: (MonadIO m, MonadMask m, MonadLog Output m)
48+ => Severity -> CreateProcess -> m ()
49+callProcessAndLogOutput sev process = do
50+ void $ withProcess process $ \out err -> do
51+ stream <- liftIO $ do
52+ uncurry combineStream =<< liftA2 (,) (handleToInputStream out) (handleToInputStream err)
53+ streamToLog sev stream
54+ where
55+ combineStream s1 s2 = concurrentMerge [s1, s2]
56+
57+withProcess
58+ :: (MonadIO m, MonadMask m, MonadLog Output m)
59+ => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
60+withProcess process action = do
61+ (_, Just out, Just err, p) <- liftIO $ createProcess $ process
62+ { std_out = CreatePipe
63+ , std_err = CreatePipe
64+ }
65+ action out err -- Pass the handles to the custom action
66+ liftIO (waitForProcess p) >>= \case
67+ ExitSuccess -> return ()
68+ ExitFailure code -> do
69+ -- Log an error. We also fail immediately; however we should probably let the caller control that.
70+ failWith $ T.pack $ "Process " <> show process <> " failed with exit code: " <> show code
71+ return (out, err) -- Return the handles
72+
73+-- | Read from an input stream and log its contents
74+streamToLog
75+ :: (MonadIO m, MonadMask m, MonadLog Output m)
76+ => Severity -> InputStream BSC.ByteString -> m ()
77+streamToLog sev stream = fix $ \loop -> do
78+ liftIO (Streams.read stream) >>= \case
79+ Nothing -> return ()
80+ Just line -> putLogRaw sev (decodeUtf8 line) >> loop