git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/cliapp/src/Obelisk/CliApp/Process.hs
185 lines 7.6 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.CliApp.Process
12 ( ProcessFailure (..)
13 , AsProcessFailure (..)
14 , readProcessAndLogStderr
15 , readProcessAndLogOutput
16 , readCreateProcessWithExitCode
17 , callProcessAndLogOutput
18 , createProcess
19 , createProcess_
20 , callProcess
21 , callCommand
22 , reconstructCommand
23 ) where
25import Control.Monad ((<=<), join, void)
26import Control.Monad.Except (throwError)
27import Control.Monad.IO.Class (MonadIO, liftIO)
28import Control.Lens (Prism', review)
29import qualified Data.ByteString as BS
30import qualified Data.ByteString.Char8 as BSC
31import Data.Function (fix)
32import Data.Monoid ((<>))
33import Data.Text (Text)
34import qualified Data.Text as T
35import qualified Data.Text.Encoding as T
36import Data.Text.Encoding.Error (lenientDecode)
37import System.Exit (ExitCode (..))
38import System.IO (Handle)
39import System.IO.Streams (InputStream, handleToInputStream)
40import qualified System.IO.Streams as Streams
41import System.IO.Streams.Concurrent (concurrentMerge)
42import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), cmdspec, std_err, std_out,
43 waitForProcess)
44import qualified System.Process as Process
46import Control.Monad.Log (Severity (..))
47import Obelisk.CliApp.Logging (putLog, putLogRaw)
48import Obelisk.CliApp.Types (CliLog, CliThrow)
50-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions
51data ProcessFailure = ProcessFailure Process.CmdSpec Int -- exit code
52 deriving Show
54-- | Indicates arbitrary process failures form one variant (or conceptual projection) of
55-- the error type.
56class AsProcessFailure e where
57 asProcessFailure :: Prism' e ProcessFailure
59instance AsProcessFailure ProcessFailure where
60 asProcessFailure = id
62readProcessAndLogStderr
63 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
64 => Severity -> CreateProcess -> m Text
65readProcessAndLogStderr sev process = do
66 (out, _err) <- withProcess process $ \_out err -> do
67 streamToLog =<< liftIO (streamHandle sev err)
68 liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out
70readCreateProcessWithExitCode
71 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
72 => CreateProcess -> m (ExitCode, String, String)
73readCreateProcessWithExitCode process = do
74 putLog Debug $ "Creating process: " <> reconstructCommand (cmdspec process)
75 liftIO $ Process.readCreateProcessWithExitCode process ""
77-- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr)
78-- with the corresponding severity.
79--
80-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
81-- some processes are known to spit out diagnostic or informative messages in stderr, in
82-- which case it is advisable to call it with a non-Error severity for stderr, like
83-- `callProcessAndLogOutput (Debug, Debug)`.
84readProcessAndLogOutput
85 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
86 => (Severity, Severity) -> CreateProcess -> m Text
87readProcessAndLogOutput (sev_out, sev_err) process = do
88 (_, Just out, Just err, p) <- createProcess $ process
89 { std_out = CreatePipe , std_err = CreatePipe }
91 -- TODO interleave stdout and stderr in log correctly
92 streamToLog =<< liftIO (streamHandle sev_err err)
93 outText <- liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out
94 putLogRaw sev_out outText
96 liftIO (waitForProcess p) >>= \case
97 ExitSuccess -> pure outText
98 ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code
100-- | Like `System.Process.callProcess` but logs the combined output (stdout and stderr)
101-- with the corresponding severity.
102--
103-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However
104-- some processes are known to spit out diagnostic or informative messages in stderr, in
105-- which case it is advisable to call it with a non-Error severity for stderr, like
106-- `callProcessAndLogOutput (Debug, Debug)`.
107callProcessAndLogOutput
109 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
110 => (Severity, Severity) -> CreateProcess -> m ()
111callProcessAndLogOutput (sev_out, sev_err) process =
112 void $ withProcess process $ \out err -> do
113 stream <- liftIO $ join $ combineStream
114 <$> streamHandle sev_out out
115 <*> streamHandle sev_err err
116 streamToLog stream
117 where
118 combineStream s1 s2 = concurrentMerge [s1, s2]
120-- | Like `System.Process.createProcess` but also logs (debug) the process being run
121createProcess
122 :: (MonadIO m, CliLog m)
123 => CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
124createProcess p = do
125 putLog Debug $ "Creating process: " <> reconstructCommand (cmdspec p)
126 liftIO $ Process.createProcess p
128-- | Like `System.Process.createProcess_` but also logs (debug) the process being run
129createProcess_
130 :: (MonadIO m, CliLog m)
131 => String -> CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
132createProcess_ name p = do
133 putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructCommand (cmdspec p)
134 liftIO $ Process.createProcess p
136-- | Like `System.Process.callProcess` but also logs (debug) the process being run
137callProcess
138 :: (MonadIO m, CliLog m)
139 => String -> [String] -> m ()
140callProcess exe args = do
141 putLog Debug $ "Calling process " <> T.pack exe <> " with args: " <> T.pack (show args)
142 liftIO $ Process.callProcess exe args
144-- | Like `System.Process.callCommand` but also logs (debug) the command being run
145callCommand
146 :: (MonadIO m, CliLog m)
147 => String -> m ()
148callCommand cmd = do
149 putLog Debug $ "Calling command " <> T.pack cmd
150 liftIO $ Process.callCommand cmd
152withProcess
153 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)
154 => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)
155withProcess process f = do -- TODO: Use bracket.
156 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.
157 (_, Just out, Just err, p) <- createProcess $ process
158 { std_out = CreatePipe , std_err = CreatePipe }
160 f out err -- Pass the handles to the passed function
162 liftIO (waitForProcess p) >>= \case
163 ExitSuccess -> return (out, err)
164 ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code
166-- Create an input stream from the file handle, associating each item with the given severity.
167streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))
168streamHandle sev = Streams.map (sev,) <=< handleToInputStream
170-- | Read from an input stream and log its contents
171streamToLog
172 :: (MonadIO m, CliLog m)
173 => InputStream (Severity, BSC.ByteString) -> m ()
174streamToLog stream = fix $ \loop -> do
175 liftIO (Streams.read stream) >>= \case
176 Nothing -> return ()
177 Just (sev, line) -> putLogRaw sev (T.decodeUtf8With lenientDecode line) >> loop
179-- | Pretty print a 'CmdSpec'
180reconstructCommand :: Process.CmdSpec -> Text
181reconstructCommand (Process.ShellCommand str) = T.pack str
182reconstructCommand (Process.RawCommand c as) = processToShellString c as
183 where
184 processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)
185 quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"