git.iko.soy/obelisk
on 3caa3db help sign in
obelisk/lib/command/src/Obelisk/CLI/Process.hs
113 lines 4.7 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiWayIf #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TupleSections #-}
9-- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`)
10-- and is thus spinner friendly.
11module Obelisk.CLI.Process
12 ( readProcessAndLogStderr
13 , callProcessAndLogOutput
14 , createProcess
15 , createProcess_
16 ) where
18import Control.Applicative (liftA2)
19import Control.Monad (void, (<=<))
20import Control.Monad.Catch (MonadMask)
21import Control.Monad.IO.Class (liftIO)
22import Control.Monad.Log (MonadLog)
23import Control.Monad.Reader (MonadIO)
24import qualified Data.ByteString.Char8 as BSC
25import Data.Function (fix)
26import Data.Monoid ((<>))
27import qualified Data.Text as T
28import Data.Text.Encoding (decodeUtf8)
29import qualified Data.Text.IO as T
30import System.Exit (ExitCode (..))
31import System.IO (Handle)
32import System.IO.Streams (InputStream, handleToInputStream)
33import qualified System.IO.Streams as Streams
34import System.IO.Streams.Concurrent (concurrentMerge)
35import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), cmdspec, std_err, std_out,
36 waitForProcess)
37import qualified System.Process as Process
39import Obelisk.CLI.Logging (Output, Severity (..), failWith, putLog, putLogRaw)
41-- | Like `System.Process.readProcess` but logs the stderr instead of letting the external process inherit it.
42readProcessAndLogStderr
43 :: (MonadIO m, MonadMask m, MonadLog Output m)
44 => Severity -> CreateProcess -> m String
45readProcessAndLogStderr sev process = do
46 (out, _err) <- withProcess process $ \_out err -> do
47 streamToLog =<< liftIO (streamHandle sev err)
48 -- TODO: Why are we using Text here?
49 liftIO $ T.unpack . T.strip <$> T.hGetContents out
51-- | Like `System.Process.callProcess` but logs the combined output--stdout and stderr with the corresponding
52-- severity.
53--
54-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However some processes
55-- are known to spit out diagnostic or informative messages in stderr, in which case it is advisable to call
56-- it with a non-Error severity for stderr, like `callProcessAndLogOutput (Debug, Debug)`.
57callProcessAndLogOutput
58 :: (MonadIO m, MonadMask m, MonadLog Output m)
59 => (Severity, Severity) -> CreateProcess -> m ()
60callProcessAndLogOutput (sev_out, sev_err) process = do
61 void $ withProcess process $ \out err -> do
62 stream <- liftIO $ do
63 uncurry combineStream =<< liftA2 (,) (streamHandle sev_out out) (streamHandle sev_err err)
64 streamToLog stream
65 where
66 combineStream s1 s2 = concurrentMerge [s1, s2]
68-- | Like `System.Process.createProcess` but also logs (debug) the process being run
69createProcess
70 :: (MonadIO m, MonadLog Output m)
71 => CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
72createProcess p = do
73 putLog Debug $ "Creating process: " <> T.pack (show p)
74 liftIO $ Process.createProcess p
76-- | Like `System.Process.createProcess_` but also logs (debug) the process being run
77createProcess_
78 :: (MonadIO m, MonadLog Output m)
79 => String -> CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
80createProcess_ name p = do
81 putLog Debug $ "Creating process " <> T.pack name <> ": " <> T.pack (show p)
82 liftIO $ Process.createProcess p
85withProcess
86 :: (MonadIO m, MonadMask m, MonadLog Output m)
87 => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
88withProcess process f = do
89 let procTitle = T.pack $ show $ cmdspec process
90 (_, Just out, Just err, p) <- createProcess $ process
91 { std_out = CreatePipe
92 , std_err = CreatePipe
93 }
94 f out err -- Pass the handles to the passed function
95 liftIO (waitForProcess p) >>= \case
96 ExitSuccess -> return ()
97 ExitFailure code -> do
98 -- Log an error. We also fail immediately; however we should probably let the caller control that.
99 failWith $ procTitle <> " failed with exit code: " <> T.pack (show code)
100 return (out, err) -- Return the handles
102-- Create an input stream from the file handle, associating each item with the given severity.
103streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))
104streamHandle sev = Streams.map (sev,) <=< handleToInputStream
106-- | Read from an input stream and log its contents
107streamToLog
108 :: (MonadIO m, MonadMask m, MonadLog Output m)
109 => InputStream (Severity, BSC.ByteString) -> m ()
110streamToLog stream = fix $ \loop -> do
111 liftIO (Streams.read stream) >>= \case
112 Nothing -> return ()
113 Just (sev, line) -> putLogRaw sev (decodeUtf8 line) >> loop