cli-extras 0.1.0.2 → 0.2.0.0

raw patch · 9 files changed

+279/−172 lines, 9 filesdep +shell-escapedep +utf8-stringnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: shell-escape, utf8-string

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• cli-extras.cabal +11/−10
• src/Cli/Extras.hs +4/−2
• src/Cli/Extras/Logging.hs +83/−76
• src/Cli/Extras/Process.hs +85/−50
• src/Cli/Extras/Spinner.hs +13/−11
• src/Cli/Extras/SubExcept.hs +4/−2
• src/Cli/Extras/TerminalString.hs +3/−3
• src/Cli/Extras/Types.hs +60/−18

@@ -1,5 +1,21 @@ # Revision history for cli-extras +## 0.2.0.0++* [#6](https://github.com/obsidiansystems/cli-extras/pull/6) `cli-extras` now depends on `utf8-string` and `shell-escape`+* [#6](https://github.com/obsidiansystems/cli-extras/pull/6) Removed `mkDefaultCliConfig`, `prettyProcessFailure`+* [#6](https://github.com/obsidiansystems/cli-extras/pull/6) `cli-extras` now manages the control flow for exceptions:+  + The type `CliConfig` is now parametrised over the type of errors, and the class `HasCliConfig` was changed accordingly+  + The return type of `runCli` was changed from `m (Either e a)` to `m a`.+  + A new transformer `DieT` was added as an intermediate between the full `CliT` and "`LoggingT` with errors". Errors thrown in `DieT` can not be caught, and abort the program according to the configuration.+  * `newCliConfig` now takes an argument describing how errors should be handled.+* [#6](https://github.com/obsidiansystems/cli-extras/pull/6) Added helper functions:+  + `runProcess_` (run a `ProcessSpec`, aborting if the called process fails)+  + `fork` (lifts `forkIO` to the `CliT` monad)+  + `whenLogLevel` (runs an action iff the current log level matches a predicate)+  + `errorToWarning` (log an error as if it were a warning)+* [#6](https://github.com/obsidiansystems/cli-extras/pull/6) The action `allowUserToMakeLoggingVerbose` now takes an argument specifying how the key combination should be shown to the user. Additionally, the `CliConfig` argument was removed and made into a `HasCliConfig` constraint.+ ## 0.1.0.2  * Loosen aeson, which, ansi-terminal version bounds

@@ -1,9 +1,9 @@ cabal-version:      >=1.10 name:               cli-extras-version:            0.1.0.2+version:            0.2.0.0 license:            BSD3 license-file:       LICENSE-copyright:          Obsidian Systems LLC 2020+copyright:          Obsidian Systems LLC 2020-2022 maintainer:         maintainer@obsidian.systems author:             Obsidian Systems LLC stability:          Unstable@@ -19,16 +19,13 @@ extra-source-files: CHANGELOG.md                     README.md -tested-with: GHC ==8.6.5 || ==8.8.4+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.2  library   exposed-modules:     Bindings.Cli.Coreutils     Cli.Extras     Cli.Extras.SubExcept--  hs-source-dirs:   src-  other-modules:     Cli.Extras.Logging     Cli.Extras.Process     Cli.Extras.Spinner@@ -36,17 +33,19 @@     Cli.Extras.Theme     Cli.Extras.Types +  hs-source-dirs:   src+   default-language: Haskell2010   ghc-options:      -Wall -fobject-code   build-depends:-      aeson           >=1.4.4.0  && <1.6+      aeson           >=1.4.4.0  && <2.1     , ansi-terminal   >=0.9.1    && <0.12-    , base            >=4.12.0.0 && <4.15-    , bytestring      >=0.10.8.2 && <0.11+    , base            >=4.12.0.0 && <4.17+    , bytestring      >=0.10.8.2 && <0.12     , containers      >=0.6.0.1  && <0.7     , exceptions      >=0.10.3   && <0.11     , io-streams      >=1.5.1.0  && <1.6-    , lens            >=4.17.1   && <4.20+    , lens            >=4.17.1   && <5.2     , logging-effect  >=1.3.4    && <1.4     , monad-logger    >=0.3.30   && <0.4     , monad-loops     >=0.4.3    && <0.5@@ -57,6 +56,8 @@     , time            >=1.8.0.2  && <1.12     , transformers    >=0.5.6.2  && <0.6     , which           >=0.1      && <0.3+    , utf8-string     >=1.0.1    && <1.1+    , shell-escape    >=0.2.0    && <0.3  source-repository head   type:     git

@@ -21,10 +21,10 @@   -- .Logging   , AsUnstructuredError (..)   , newCliConfig-  , mkDefaultCliConfig   , getLogLevel   , putLog   , failWith+  , errorToWarning   , withExitFailMessage    -- Control.Monad.Log@@ -33,12 +33,13 @@   -- .Process   , AsProcessFailure (..)   , ProcessFailure (..)-  , prettyProcessFailure   , ProcessSpec (..)   , callCommand   , callProcess   , callProcessAndLogOutput+  , createProcess   , createProcess_+  , throwExitCode   , overCreateProcess   , proc   , readCreateProcessWithExitCode@@ -46,6 +47,7 @@   , readProcessAndLogStderr   , readProcessJSONAndLogStderr   , reconstructCommand+  , runProcess_   , setCwd   , setDelegateCtlc   , setEnvOverride

@@ -11,7 +11,6 @@ module Cli.Extras.Logging   ( AsUnstructuredError (..)   , newCliConfig-  , mkDefaultCliConfig   , runCli   , verboseLogLevel   , isOverwrite@@ -21,34 +20,32 @@   , putLog   , putLogRaw   , failWith+  , errorToWarning   , withExitFailMessage   , writeLog   , allowUserToMakeLoggingVerbose   , getChars-  , handleLog+  , fork   ) where -import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) import Control.Concurrent.MVar (modifyMVar_, newMVar) import Control.Lens (Prism', review) import Control.Monad (unless, void, when) import Control.Monad.Catch (MonadCatch, MonadMask, bracket, catch, throwM)-import Control.Monad.Except (runExceptT, throwError)+import Control.Monad.Except (throwError) import Control.Monad.IO.Class (liftIO) import Control.Monad.Log (Severity (..), WithSeverity (..), logMessage, runLoggingT) import Control.Monad.Loops (iterateUntil) import Control.Monad.Reader (MonadIO, ReaderT (..)) import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)-import Data.List (isInfixOf)-import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Encoding.Types-import System.Console.ANSI (Color (Red, Yellow), ColorIntensity (Vivid),+import System.Console.ANSI (Color (..), ColorIntensity (Vivid),                             ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),                             SGR (SetColor, SetConsoleIntensity), clearLine)-import System.Environment import System.Exit (ExitCode (..)) import System.IO @@ -56,42 +53,19 @@ import Cli.Extras.Theme import Cli.Extras.Types --- | Log a message to the console.------ Logs safely even if there are ongoing spinners.-putLog :: CliLog m => Severity -> Text -> m ()-putLog sev = logMessage . Output_Log . WithSeverity sev--putLog' :: CliConfig -> Severity -> Text -> IO ()-putLog' conf sev t = runLoggingT (putLog sev t) (handleLog conf)----TODO: Use optparse-applicative instead--- Given the program's command line arguments, produce a reasonable CliConfig-mkDefaultCliConfig :: [String] -> IO CliConfig-mkDefaultCliConfig cliArgs = do-  let logLevel = if any (`elem` ["-v", "--verbose"]) cliArgs then Debug else Notice-  notInteractive <- not <$> isInteractiveTerm-  newCliConfig logLevel notInteractive notInteractive-  where-    isInteractiveTerm = do-      isTerm <- hIsTerminalDevice stdout-      -- Running in bash/fish/zsh completion-      let inShellCompletion = isInfixOf "completion" $ unwords cliArgs--      -- Respect the user’s TERM environment variable. Dumb terminals-      -- like Eshell cannot handle lots of control sequences that the-      -- spinner uses.-      termEnv <- lookupEnv "TERM"-      let isDumb = termEnv == Just "dumb"--      return $ isTerm && not inShellCompletion && not isDumb-+-- | Create a new 'CliConfig', initialized with the provided values. newCliConfig   :: Severity-  -> Bool-  -> Bool-  -> IO CliConfig-newCliConfig sev noColor noSpinner = do+  -- ^ The initial log level. Messages below this severity will not be+  -- logged, unless the log level is subsequently altered using+  -- 'setLogLevel'.+  -> Bool -- ^ Should ANSI terminal formatting be disabled?+  -> Bool -- ^ Should spinners be disabled?+  -> (e -> (Text, ExitCode))+  -- ^ How to display errors, and compute the 'ExitCode' corresponding+  -- to each error.+  -> IO (CliConfig e)+newCliConfig sev noColor noSpinner errorLogExitCode = do   level <- newIORef sev   lock <- newMVar False   tipDisplayed <- newIORef False@@ -100,12 +74,13 @@   let theme = if maybe False supportsUnicode textEncoding         then unicodeTheme         else noUnicodeTheme-  return $ CliConfig level noColor noSpinner lock tipDisplayed stack theme+  return $ CliConfig level noColor noSpinner lock tipDisplayed stack errorLogExitCode theme -runCli :: MonadIO m => CliConfig -> CliT e m a -> m (Either e a)+runCli :: MonadIO m => CliConfig e -> CliT e m a -> m a runCli c =-    runExceptT-  . flip runLoggingT (handleLog c)+    flip runLoggingT (handleLog c)+  . flip runReaderT (_cliConfig_errorLogExitCode c)+  . unDieT   . flip runReaderT c   . unCliT @@ -123,21 +98,18 @@   Output_LogRaw (WithSeverity sev _) -> Just sev   _ -> Nothing -getLogLevel :: (MonadIO m, HasCliConfig m) => m Severity+getLogLevel :: (MonadIO m, HasCliConfig e m) => m Severity getLogLevel = getLogLevel' =<< getCliConfig -getLogLevel' :: MonadIO m => CliConfig -> m Severity+getLogLevel' :: MonadIO m => CliConfig e -> m Severity getLogLevel' = liftIO . readIORef . _cliConfig_logLevel -setLogLevel :: (MonadIO m, HasCliConfig m) => Severity -> m ()+setLogLevel :: (MonadIO m, HasCliConfig e m) => Severity -> m () setLogLevel sev = do-  conf <- getCliConfig-  setLogLevel' conf sev--setLogLevel' :: MonadIO m => CliConfig -> Severity -> m ()-setLogLevel' conf sev = liftIO $ writeIORef (_cliConfig_logLevel conf) sev+  l <- _cliConfig_logLevel <$> getCliConfig+  liftIO $ writeIORef l sev -handleLog :: MonadIO m => CliConfig -> Output -> m ()+handleLog :: MonadIO m => CliConfig e -> Output -> m () handleLog conf output = do   level <- getLogLevel' conf   liftIO $ modifyMVar_ (_cliConfig_lock conf) $ \wasOverwriting -> do@@ -192,6 +164,14 @@ failWith :: (CliThrow e m, AsUnstructuredError e) => Text -> m a failWith = throwError . review asUnstructuredError +-- | Log an error as though it were a warning, in a non-fatal way.+errorToWarning+  :: (HasCliConfig e m, CliLog m)+  => e -> m ()+errorToWarning e = do+  c <- getCliConfig+  putLog Warning $ fst $ _cliConfig_errorLogExitCode c e+ -- | Intercept ExitFailure exceptions and log the given alert before exiting. -- -- This is useful when you want to provide contextual information to a deeper failure.@@ -202,14 +182,21 @@     ExitSuccess -> pure ()   throwM e --- | Write log to stdout, with colors (unless `noColor`)-writeLog :: (MonadIO m, MonadMask m) => Bool -> Bool -> WithSeverity Text -> m ()+-- | Log a message to standard output.+writeLog+  :: (MonadIO m)+  => Bool -- ^ Should a new line be printed after the message?+  -> Bool -- ^ Should ANSI terminal formatting be used when printing the message?+  -> WithSeverity Text -- ^ The message to print.+  -> m () writeLog withNewLine noColor (WithSeverity severity s) = if T.null s then pure () else write   where     write       | noColor && severity <= Warning = liftIO $ putFn $ T.pack (show severity) <> ": " <> s       | not noColor && severity <= Error = TS.putStrWithSGR errorColors h withNewLine s       | not noColor && severity <= Warning = TS.putStrWithSGR warningColors h withNewLine s+      | not noColor && severity == Notice = TS.putStrWithSGR noticeColors h withNewLine s+      | not noColor && severity == Informational = TS.putStrWithSGR infoColors h withNewLine s       | not noColor && severity >= Debug = TS.putStrWithSGR debugColors h withNewLine s       | otherwise = liftIO $ putFn s @@ -217,30 +204,43 @@     h = if severity <= Error then stderr else stdout     errorColors = [SetColor Foreground Vivid Red]     warningColors = [SetColor Foreground Vivid Yellow]+    infoColors = [SetColor Foreground Vivid Green]+    noticeColors = [SetColor Foreground Vivid Blue]     debugColors = [SetConsoleIntensity FaintIntensity] --- | Allow the user to immediately switch to verbose logging upon pressing a particular key.+-- | Runs an action only when the current log level matches a given+-- predicate.+whenLogLevel+  :: (MonadIO m, HasCliConfig e m)+  => (Severity -> Bool) -- ^ What severity(ies) should this action run in?+  -> m ()               -- ^ The action to run.+  -> m ()+whenLogLevel level f = do+  l <- getLogLevel+  when (level l) f++-- | Allows the user to immediately switch to verbose logging when a+-- particular sequence of characters is read from the terminal. -- -- Call this function in a thread, and kill it to turn off keystroke monitoring. allowUserToMakeLoggingVerbose-  :: CliConfig-  -> String  -- ^ The key to press in order to make logging verbose-  -> IO ()-allowUserToMakeLoggingVerbose conf keyCode = do-  let unlessVerbose f = do-        l <- getLogLevel' conf-        unless (l == verboseLogLevel) f-      showTip = liftIO $ forkIO $ unlessVerbose $ do-        liftIO $ threadDelay $ 10*1000000  -- Only show tip for actions taking too long (10 seconds or more)-        tipDisplayed <- liftIO $ atomicModifyIORef' (_cliConfig_tipDisplayed conf) $ (,) True-        unless tipDisplayed $ unlessVerbose $ do -- Check again in case the user had pressed Ctrl+e recently-          putLog' conf Notice "Tip: Press Ctrl+e to display full output"-  bracket showTip (liftIO . killThread) $ \_ -> do-    unlessVerbose $ do-      hSetBuffering stdin NoBuffering-      _ <- iterateUntil (== keyCode) getChars-      putLog' conf Warning "Ctrl+e pressed; making output verbose (-v)"-      setLogLevel' conf verboseLogLevel+  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)+  => String  -- ^ The key(s) which should be read to indicate a shift in verbosity.+  -> Text    -- ^ A description of the key that must be pressed.+  -> m ()+allowUserToMakeLoggingVerbose keyCode desc = bracket showTip (liftIO . killThread) $ \_ -> do+  whenLogLevel (/= verboseLogLevel) $ do+    liftIO $ hSetBuffering stdin NoBuffering+    _ <- iterateUntil (== keyCode) $ liftIO getChars+    putLog Warning $ desc <> " pressed; making output verbose (-v)"+    setLogLevel verboseLogLevel+  where+    showTip = fork $ whenLogLevel (/= verboseLogLevel) $ do+      conf <- getCliConfig+      liftIO $ threadDelay $ 10*1000000  -- Only show tip for actions taking too long (10 seconds or more)+      tipDisplayed <- liftIO $ atomicModifyIORef' (_cliConfig_tipDisplayed conf) $ (,) True+      unless tipDisplayed $ whenLogLevel (/= verboseLogLevel) $ do -- Check again in case the user had pressed Ctrl+e recently+        putLog Notice $ "Tip: Press " <> desc <> " to display full output"  -- | Like `getChar` but also retrieves the subsequently pressed keys. --@@ -254,6 +254,13 @@       hReady stdin >>= \case         True -> f (x:xs)         False -> return (x:xs)++-- | Fork a computation in 'CliT', sharing the configuration with the+-- child thread.+fork :: (HasCliConfig e m, MonadIO m) => CliT e IO () -> m ThreadId+fork f = do+  c <- getCliConfig+  liftIO $ forkIO $ runCli c f  -- | Conservatively determines whether the encoding supports Unicode. --

@@ -1,10 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}  -- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`) -- and is thus spinner friendly.@@ -17,6 +17,7 @@   , callProcessAndLogOutput   , createProcess   , createProcess_+  , throwExitCode   , overCreateProcess   , proc   , readCreateProcessWithExitCode@@ -24,25 +25,25 @@   , readProcessAndLogStderr   , readProcessJSONAndLogStderr   , reconstructCommand+  , runProcess_   , setCwd   , setDelegateCtlc   , setEnvOverride   , shell   , waitForProcess-  , prettyProcessFailure   ) where  import Control.Monad ((<=<), join, void)+import Control.Monad.Catch (MonadMask, bracketOnError) import Control.Monad.Except (throwError)-import Control.Monad.Fail import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Lens (Prism', review) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.UTF8 as BSU import Data.Function (fix) import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -55,12 +56,16 @@ import System.IO.Streams.Concurrent (concurrentMerge) import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), std_err, std_out) import qualified System.Process as Process+import Text.ShellEscape (bash, bytes) import qualified Data.Aeson as Aeson- import Control.Monad.Log (Severity (..)) import Cli.Extras.Logging (putLog, putLogRaw) import Cli.Extras.Types (CliLog, CliThrow) +#if !(MIN_VERSION_base(4, 13, 0))+import Control.Monad.Fail (MonadFail)+#endif+ data ProcessSpec = ProcessSpec   { _processSpec_createProcess :: !CreateProcess   , _processSpec_overrideEnv :: !(Maybe (Map String String -> Map String String))@@ -85,13 +90,10 @@ setCwd fp = overCreateProcess (\p -> p { Process.cwd = fp })  --- TODO put back in `Cli.Extras.Process` and use prisms for extensible exceptions+-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions data ProcessFailure = ProcessFailure Process.CmdSpec Int -- exit code   deriving Show -prettyProcessFailure :: ProcessFailure -> Text-prettyProcessFailure (ProcessFailure p code) = "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p- -- | Indicates arbitrary process failures form one variant (or conceptual projection) of -- the error type. class AsProcessFailure e where@@ -101,7 +103,7 @@   asProcessFailure = id  readProcessAndLogStderr-  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)+  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)   => Severity -> ProcessSpec -> m Text readProcessAndLogStderr sev process = do   (out, _err) <- withProcess process $ \_out err -> do@@ -109,7 +111,7 @@   liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out  readProcessJSONAndLogStderr-  :: (Aeson.FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)+  :: (Aeson.FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)   => Severity -> ProcessSpec -> m a readProcessJSONAndLogStderr sev process = do   (out, _err) <- withProcess process $ \_out err -> do@@ -122,23 +124,29 @@       throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) 0  readCreateProcessWithExitCode-  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)+  :: (MonadIO m, CliLog m)   => ProcessSpec -> m (ExitCode, String, String) readCreateProcessWithExitCode procSpec = do   process <- mkCreateProcess procSpec   putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec   liftIO $ Process.readCreateProcessWithExitCode process "" --- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr)+-- | Like 'System.Process.readProcess', but such that each of the child+-- processes' standard output streams (stdout and stderr) is logged, -- with the corresponding severity. ----- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However--- some processes are known to spit out diagnostic or informative messages in stderr, in--- which case it is advisable to call it with a non-Error severity for stderr, like--- `callProcessAndLogOutput (Debug, Debug)`.+-- Usually, this function is called as @readProcessAndLogOutput (Debug,+-- Error)@. If the child process is known to print diagnostic or+-- informative messages to stderr, it is advisable to call+-- 'readProcessAndLogOutput' with a non-Error severity for stderr, for+-- example @readProcessAndLogOutput (Debug, Debug)@. readProcessAndLogOutput   :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)-  => (Severity, Severity) -> ProcessSpec -> m Text+  => (Severity, Severity)+  -- ^ This tuple controls the severity of each output stream. Its @fst@+  -- is the severity of stdout; @snd@ is the severity of stderr.+  -> ProcessSpec+  -> m Text readProcessAndLogOutput (sev_out, sev_err) process = do   (_, Just out, Just err, p) <- createProcess $ overCreateProcess     (\p -> p { std_out = CreatePipe , std_err = CreatePipe }) process@@ -148,20 +156,24 @@   outText <- liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out   putLogRaw sev_out outText -  waitForProcess p >>= \case-    ExitSuccess -> pure outText-    ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code+  outText <$ (throwExitCode process =<< waitForProcess p) --- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)+-- | Like 'System.Process.readProcess', but such that each of the child+-- processes' standard output streams (stdout and stderr) is logged, -- with the corresponding severity. ----- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However--- some processes are known to spit out diagnostic or informative messages in stderr, in--- which case it is advisable to call it with a non-Error severity for stderr, like--- `callProcessAndLogOutput (Debug, Debug)`.+-- Usually, this function is called as @callProcessAndLogOutput (Debug,+-- Error)@. If the child process is known to print diagnostic or+-- informative messages to stderr, it is advisable to call+-- 'callProcessAndLogOutput' with a non-Error severity for stderr, for+-- example @callProcessAndLogOutput (Debug, Debug)@. callProcessAndLogOutput-  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)-  => (Severity, Severity) -> ProcessSpec -> m ()+  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)+  => (Severity, Severity)+  -- ^ This tuple controls the severity of each output stream. Its @fst@+  -- is the severity of stdout; @snd@ is the severity of stderr.+  -> ProcessSpec+  -> m () callProcessAndLogOutput (sev_out, sev_err) process =   void $ withProcess process $ \out err -> do     stream <- liftIO $ join $ combineStream@@ -171,7 +183,8 @@   where     combineStream s1 s2 = concurrentMerge [s1, s2] --- | Like 'System.Process.createProcess' but also logs (debug) the process being run+-- | Like 'System.Process.createProcess', but logging (with 'Debug'+-- severity) the process which was started. createProcess   :: (MonadIO m, CliLog m)   => ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)@@ -180,7 +193,8 @@   putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec   liftIO $ Process.createProcess p --- | Like `System.Process.createProcess_` but also logs (debug) the process being run+-- | Like 'System.Process.createProcess_', but logging (with 'Debug'+-- severity) the process which was started. createProcess_   :: (MonadIO m, CliLog m)   => String -> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)@@ -190,14 +204,14 @@   liftIO $ Process.createProcess_ name p  mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess-mkCreateProcess (ProcessSpec p override') = do-  case override' of-    Nothing -> pure p-    Just override -> do-      procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)-      pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }+mkCreateProcess (ProcessSpec p override') = case override' of+  Nothing -> pure p+  Just override -> do+    procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)+    pure $ p { Process.env = Just $ Map.toAscList (override procEnv) } --- | Like `System.Process.callProcess` but also logs (debug) the process being run+-- | Like 'System.Process.callProcess', but logging (with 'Debug'+-- severity) the process which was started. callProcess   :: (MonadIO m, CliLog m)   => String -> [String] -> m ()@@ -205,7 +219,8 @@   putLog Debug $ "Calling process " <> T.pack exe <> " with args: " <> T.pack (show args)   liftIO $ Process.callProcess exe args --- | Like `System.Process.callCommand` but also logs (debug) the command being run+-- | Like 'System.Process.callCommand', but logging (with 'Debug'+-- severity) the process which was started. callCommand   :: (MonadIO m, CliLog m)   => String -> m ()@@ -214,18 +229,31 @@   liftIO $ Process.callCommand cmd  withProcess-  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)+  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m)   => ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)-withProcess process f = do -- TODO: Use bracket.-  -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.-  (_, Just out, Just err, p) <- createProcess $ overCreateProcess-    (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process--  f out err  -- Pass the handles to the passed function+withProcess process f =+  bracketOnError+    (createProcess $ overCreateProcess+      (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process+    )+    (liftIO . Process.cleanupProcess)+    (\case+      (_, Just out, Just err, p) -> do+        f out err+        (out, err) <$ (throwExitCode process =<< waitForProcess p)+      _ -> error "withProcess: createProcess did not provide handles for CreatePipe as expected"+    ) -  waitForProcess p >>= \case-    ExitSuccess -> return (out, err)-    ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code+-- | Runs a process to completion, aborting the computation (using+-- 'throwExitCode') in case of a non-'ExitSuccess' exit status.+runProcess_+  :: (MonadIO m, CliLog m, CliThrow e m, MonadMask m, AsProcessFailure e)+  => ProcessSpec -> m ()+runProcess_ process =+  bracketOnError+    (createProcess process)+    (liftIO . Process.cleanupProcess)+    (\(_, _, _, ph) -> throwExitCode process =<< waitForProcess ph)  -- Create an input stream from the file handle, associating each item with the given severity. streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))@@ -244,14 +272,21 @@ waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode waitForProcess = liftIO . Process.waitForProcess +-- | Aborts the computation (using 'throwError') when given a+-- non-'ExitSuccess' 'ExitCode'.+throwExitCode :: (CliThrow e m, AsProcessFailure e) => ProcessSpec -> ExitCode -> m ()+throwExitCode spec = \case+  ExitSuccess -> pure ()+  ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess spec) code+ -- | Pretty print a 'CmdSpec' reconstructCommand :: Process.CmdSpec -> Text reconstructCommand p = case p of   Process.ShellCommand str -> T.pack str   Process.RawCommand c as -> processToShellString c as   where-    processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)-    quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"+    processToShellString cmd args = T.pack $ unwords $+      map (BSU.toString . bytes . bash . BSU.fromString) (cmd : args)  reconstructProcSpec :: ProcessSpec -> Text reconstructProcSpec = reconstructCommand . Process.cmdspec . _processSpec_createProcess

@@ -10,7 +10,7 @@   , withSpinner'   ) where -import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent (killThread, threadDelay) import Control.Monad (forM_, (>=>)) import Control.Monad.Catch (MonadMask, mask, onException) import Control.Monad.IO.Class@@ -21,14 +21,14 @@ import Data.Text (Text) import System.Console.ANSI (Color (Blue, Cyan, Green, Red)) -import Cli.Extras.Logging (allowUserToMakeLoggingVerbose, putLog, handleLog)+import Cli.Extras.Logging (allowUserToMakeLoggingVerbose, fork, putLog) import Cli.Extras.TerminalString (TerminalString (..), enquiryCode) import Cli.Extras.Theme import Cli.Extras.Types (CliLog, CliConfig (..), HasCliConfig, Output (..), getCliConfig)  -- | Run an action with a CLI spinner. withSpinner-  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig m)+  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)   => Text -> m a -> m a withSpinner s = withSpinner' s $ Just $ const s @@ -39,13 +39,13 @@ -- The 'no trail' property automatically carries over to sub-spinners (in that -- they won't leave a trail either). withSpinnerNoTrail-  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig m)+  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)   => Text -> m a -> m a withSpinnerNoTrail s = withSpinner' s Nothing  -- | Advanced version that controls the display and content of the trail message. withSpinner'-  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig m)+  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)   => Text   -> Maybe (a -> Text) -- ^ Leave an optional trail with the given message creator   -> m a@@ -59,15 +59,15 @@   where     run = do       -- Add this log to the spinner stack, and start a spinner if it is top-level.-      cliConf <- getCliConfig       modifyStack pushSpinner >>= \case         True -> do -- Top-level spinner; fork a thread to manage output of anything on the stack-          ctrleThread <- liftIO $ forkIO $ allowUserToMakeLoggingVerbose cliConf enquiryCode+          ctrleThread <- fork $ allowUserToMakeLoggingVerbose enquiryCode "Ctrl+E"+          cliConf <- getCliConfig           let theme = _cliConfig_theme cliConf               spinner = coloredSpinner $ _cliTheme_spinner theme-          spinnerThread <- liftIO $ forkIO $ runSpinner spinner $ \c -> do-            logs <- renderSpinnerStack theme c . snd <$> readIORef (_cliConfig_spinnerStack cliConf)-            handleLog cliConf $ Output_Overwrite logs+          spinnerThread <- fork $ runSpinner spinner $ \c -> do+            logs <- renderSpinnerStack theme c . snd <$> readStack+            logMessage $ Output_Overwrite logs           pure [ctrleThread, spinnerThread]         False -> -- Sub-spinner; nothing to do.           pure []@@ -76,7 +76,7 @@       logMessage Output_ClearLine       cliConf <- getCliConfig       let theme = _cliConfig_theme cliConf-      logsM <- modifyStack $ popSpinner theme $ case resultM of+      logsM <- modifyStack $ (popSpinner theme) $ case resultM of         Nothing ->           ( TerminalString_Colorized Red $ _cliTheme_failed $ _cliConfig_theme cliConf           , Just msg  -- Always display final message if there was an exception.@@ -104,6 +104,8 @@         inTemporarySpinner = or newFlag  -- One of our parent spinners is temporary         newFlag = drop 1 flag         new = L.delete (TerminalString_Normal msg) old+    readStack = liftIO . readIORef+      =<< fmap _cliConfig_spinnerStack getCliConfig     modifyStack f = liftIO . flip atomicModifyIORef' f       =<< fmap _cliConfig_spinnerStack getCliConfig 

@@ -8,15 +8,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} module Cli.Extras.SubExcept where  import Control.Lens (Prism', preview, review) import Control.Monad.Error.Class (MonadError (..))-import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+#if !(MIN_VERSION_base(4, 13, 0))+import Control.Monad.Fail (MonadFail)+#endif import Control.Monad.Log-import Control.Monad.Fail  -- | Wrap a Prism' in a newtype to avoid impredicativity problems newtype WrappedPrism' a b = WrappedPrism' { unWrappedPrism' :: Prism' a b }

@@ -14,7 +14,6 @@ import Control.Monad.Catch (bracket_) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (MonadIO)-import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T@@ -71,7 +70,9 @@     reset = hSetSGR h [Reset] >> newline -- New line should come *after* reset (to reset cursor color).     newline = when withNewLine $ T.hPutStrLn h "" --- | Code for https://en.wikipedia.org/wiki/Enquiry_character+-- | Code for https://en.wikipedia.org/wiki/Enquiry_character. On VT-100+-- descendants (most modern UNIX terminal emulators), an ENQ character+-- can be generated by pressing Ctrl+E. enquiryCode :: String enquiryCode = "\ENQ" @@ -81,4 +82,3 @@  getTerminalWidth :: IO (Maybe Int) getTerminalWidth = fmap TerminalSize.width <$> TerminalSize.size-

@@ -1,28 +1,36 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-} module Cli.Extras.Types where  import Control.Concurrent.MVar (MVar) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)-import Control.Monad.Fail (MonadFail)-import Control.Monad.Log (LoggingT(..), MonadLog, Severity (..), WithSeverity (..))-import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask)+import Control.Monad.Log (LoggingT(..), MonadLog, Severity (..), WithSeverity (..), logMessage)+import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT) import Control.Monad.Writer (WriterT) import Control.Monad.State (StateT) import Control.Monad.Except (ExceptT, MonadError (..))+import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans (MonadTrans, lift) import Data.IORef (IORef) import Data.Text (Text)+import System.Exit (ExitCode (..), exitWith)  import Cli.Extras.TerminalString (TerminalString) import Cli.Extras.Theme (CliTheme)-import Cli.Extras.SubExcept +#if !(MIN_VERSION_base(4, 13, 0))+import Control.Monad.Fail (MonadFail)+#endif+ --------------------------------------------------------------------------------  data Output@@ -37,9 +45,42 @@  type CliThrow e m = MonadError e m +-- | Log a message to the console.+--+-- The message is guaranteed to be logged uninterrupted, even if there+-- are ongoing spinners.+putLog :: CliLog m => Severity -> Text -> m ()+putLog sev = logMessage . Output_Log . WithSeverity sev++newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a }+  deriving+    ( Functor, Applicative, Monad, MonadIO, MonadFail+    , MonadThrow, MonadCatch, MonadMask+    , MonadLog Output+    )++instance MonadTrans (DieT e) where+  lift = DieT . lift . lift++instance MonadReader r m => MonadReader r (DieT e m) where+  ask = DieT $ lift $ ask+  local = (\f (DieT a) -> DieT $ f a) . mapReaderT . local+  reader = DieT . lift . lift . reader++-- TODO generalize to bigger error types+instance MonadIO m => MonadError e (DieT e m) where+  throwError e = do+    handler <- DieT ask+    let (output, exitCode) = handler e+    putLog Alert output+    liftIO $ exitWith $ exitCode++  -- Cannot catch+  catchError m _ = m+ -------------------------------------------------------------------------------- -data CliConfig = CliConfig+data CliConfig e = CliConfig   { -- | We are capable of changing the log level at runtime     _cliConfig_logLevel :: IORef Severity   , -- | Disallow coloured output@@ -52,42 +93,43 @@     _cliConfig_tipDisplayed :: IORef Bool   , -- | Stack of logs from nested spinners     _cliConfig_spinnerStack :: IORef ([Bool], [TerminalString])+  , -- | Handler for failures. Determines, given an error, what message+    -- should be printed, and what the exit status should be.+    _cliConfig_errorLogExitCode :: e -> (Text, ExitCode)   , -- | Theme strings for spinners     _cliConfig_theme :: CliTheme   } -class Monad m => HasCliConfig m where-  getCliConfig :: m CliConfig--instance HasCliConfig m => HasCliConfig (ReaderT r m) where-  getCliConfig = lift getCliConfig+class Monad m => HasCliConfig e m | m -> e where+  getCliConfig :: m (CliConfig e) -instance (Monoid w, HasCliConfig m) => HasCliConfig (WriterT w m) where+instance HasCliConfig e m => HasCliConfig e (ReaderT r m) where   getCliConfig = lift getCliConfig -instance HasCliConfig m => HasCliConfig (StateT s m) where+instance (Monoid w, HasCliConfig e m) => HasCliConfig e (WriterT w m) where   getCliConfig = lift getCliConfig -instance HasCliConfig m => HasCliConfig (ExceptT e m) where+instance HasCliConfig e m => HasCliConfig e (StateT s m) where   getCliConfig = lift getCliConfig -instance HasCliConfig m => HasCliConfig (SubExceptT e eSub m) where+instance HasCliConfig e m => HasCliConfig e (ExceptT e m) where   getCliConfig = lift getCliConfig  --------------------------------------------------------------------------------  newtype CliT e m a = CliT-  { unCliT :: ReaderT CliConfig (LoggingT Output (ExceptT e m)) a+  { unCliT :: ReaderT (CliConfig e) (DieT e m) a   }   deriving     ( Functor, Applicative, Monad, MonadIO, MonadFail     , MonadThrow, MonadCatch, MonadMask     , MonadLog Output -- CliLog     , MonadError e -- CliThrow+    , MonadReader (CliConfig e) -- HasCliConfig     )  instance MonadTrans (CliT e) where-  lift = CliT . lift . lift . lift+  lift = CliT . lift . lift -instance Monad m => HasCliConfig (CliT e m)where-  getCliConfig = CliT ask+instance Monad m => HasCliConfig e (CliT e m)where+  getCliConfig = ask