packages feed

cli-extras (empty) → 0.1.0.0

raw patch · 13 files changed

+1091/−0 lines, 13 filesdep +aesondep +ansi-terminaldep +basesetup-changed

Dependencies added: aeson, ansi-terminal, base, bytestring, containers, exceptions, io-streams, lens, logging-effect, monad-loops, mtl, process, terminal-size, text, time, transformers, which

Files

+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# Revision history for cli-extras++## 0.1.0.0+* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020 Obsidian Systems LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Obsidian Systems LLC nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cli-extras.cabal view
@@ -0,0 +1,55 @@+cabal-version: >=1.10+name: cli-extras+version: 0.1.0.0+license: BSD3+license-file: LICENSE+copyright: Obsidian Systems LLC 2020+maintainer: maintainer@obsidian.systems+author: Obsidian Systems LLC+stability: Unstable+bug-reports: https://github.com/obsidiansystems/cli-extras/issues+synopsis: Miscellaneous utilities for building and working with command line interfaces+description:+    This library was created to hold code that is shared among multiple command line apps.+category: Command Line+build-type: Simple+extra-source-files:+    CHANGELOG.md++source-repository head+    type: git+    location: https://github.com/obsidiansystems/cli-extras++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+        Cli.Extras.TerminalString+        Cli.Extras.Theme+        Cli.Extras.Types+    default-language: Haskell2010+    ghc-options: -Wall -fobject-code+    build-depends:+        aeson >=1.4.4.0 && <1.5,+        ansi-terminal >=0.9.1 && <0.10,+        base >=4.12.0.0 && <4.13,+        bytestring >=0.10.8.2 && <0.11,+        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.18,+        logging-effect >=1.3.4 && <1.4,+        monad-loops >=0.4.3 && <0.5,+        mtl >=2.2.2 && <2.3,+        process >=1.6.5.0 && <1.7,+        terminal-size >=0.3.2.1 && <0.4,+        text >=1.2.3.1 && <1.3,+        time >=1.8.0.2 && <1.9,+        transformers >=0.5.6.2 && <0.6,+        which >=0.1.0.0 && <0.2
+ src/Bindings/Cli/Coreutils.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module Bindings.Cli.Coreutils where++import System.Which (staticWhich)++cp :: FilePath+cp = $(staticWhich "cp")
+ src/Cli/Extras.hs view
@@ -0,0 +1,63 @@+-- | Package for writing great CLI apps.+--+-- See Demo.hs for an example+--+-- This package should eventually be made its own library.+module Cli.Extras+  (+  -- .Types+    CliLog+  , CliThrow+  , CliT(..)+  , runCli+  , CliConfig+  , HasCliConfig+  , getCliConfig+  , Output++  -- .Spinner+  , withSpinner+  , withSpinnerNoTrail+  , withSpinner'++  -- .Logging+  , AsUnstructuredError (..)+  , newCliConfig+  , mkDefaultCliConfig+  , getLogLevel+  , putLog+  , failWith+  , withExitFailMessage++  -- Control.Monad.Log+  , Severity (..)++  -- .Process+  , AsProcessFailure (..)+  , ProcessFailure (..)+  , prettyProcessFailure+  , ProcessSpec (..)+  , callCommand+  , callProcess+  , callProcessAndLogOutput+  , createProcess_+  , overCreateProcess+  , proc+  , readCreateProcessWithExitCode+  , readProcessAndLogOutput+  , readProcessAndLogStderr+  , readProcessJSONAndLogStderr+  , reconstructCommand+  , setCwd+  , setDelegateCtlc+  , setEnvOverride+  , shell+  , waitForProcess+  ) where++import Control.Monad.Log (Severity (..))++import Cli.Extras.Logging+import Cli.Extras.Process+import Cli.Extras.Spinner+import Cli.Extras.Types
+ src/Cli/Extras/Logging.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Provides a logging handler that facilitates safe ouputting to terminal using MVar based locking.+-- | Spinner.hs and Process.hs work on this guarantee.+module Cli.Extras.Logging+  ( AsUnstructuredError (..)+  , newCliConfig+  , mkDefaultCliConfig+  , runCli+  , verboseLogLevel+  , isOverwrite+  , getSeverity+  , getLogLevel+  , setLogLevel+  , putLog+  , putLogRaw+  , failWith+  , withExitFailMessage+  , writeLog+  , allowUserToMakeLoggingVerbose+  , getChars+  , handleLog+  ) where++import Control.Concurrent (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.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),+                            ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),+                            SGR (SetColor, SetConsoleIntensity), clearLine)+import System.Environment+import System.Exit (ExitCode (..))+import System.IO++import qualified Cli.Extras.TerminalString as TS+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+  cliConf <- newCliConfig logLevel notInteractive notInteractive++  return cliConf+  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++newCliConfig+  :: Severity+  -> Bool+  -> Bool+  -> IO (CliConfig)+newCliConfig sev noColor noSpinner = do+  level <- newIORef sev+  lock <- newMVar False+  tipDisplayed <- newIORef False+  stack <- newIORef ([], [])+  textEncoding <- hGetEncoding stdout+  let theme = if maybe False supportsUnicode textEncoding+        then unicodeTheme+        else noUnicodeTheme+  return $ CliConfig level noColor noSpinner lock tipDisplayed stack theme++runCli :: MonadIO m => CliConfig -> CliT e m a -> m (Either e a)+runCli c =+    runExceptT+  . flip runLoggingT (handleLog c)+  . flip runReaderT c+  . unCliT++verboseLogLevel :: Severity+verboseLogLevel = Debug++isOverwrite :: Output -> Bool+isOverwrite = \case+  Output_Overwrite _ -> True+  _ -> False++getSeverity :: Output -> Maybe Severity+getSeverity = \case+  Output_Log (WithSeverity sev _) -> Just sev+  Output_LogRaw (WithSeverity sev _) -> Just sev+  _ -> Nothing++getLogLevel :: (MonadIO m, HasCliConfig m) => m Severity+getLogLevel = getLogLevel' =<< getCliConfig++getLogLevel' :: MonadIO m => CliConfig -> m Severity+getLogLevel' = liftIO . readIORef . _cliConfig_logLevel++setLogLevel :: (MonadIO m, HasCliConfig 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++handleLog :: MonadIO m => CliConfig -> Output -> m ()+handleLog conf output = do+  level <- getLogLevel' conf+  liftIO $ modifyMVar_ (_cliConfig_lock conf) $ \wasOverwriting -> do+    let noColor = _cliConfig_noColor conf+    case getSeverity output of+      Nothing -> handleLog' noColor output+      Just sev -> if sev > level+        then return wasOverwriting  -- Discard if sev is above configured log level+        else do+          -- If the last output was an overwrite (with cursor on same line), ...+          when wasOverwriting $+            void $ handleLog' noColor Output_ClearLine  -- first clear it,+          handleLog' noColor output  -- then, actually write the msg.++handleLog' :: MonadIO m => Bool -> Output -> m Bool+handleLog' noColor output = do+  case output of+    Output_Log m -> liftIO $ do+      writeLog True noColor m+    Output_LogRaw m -> liftIO $ do+      writeLog False noColor m+      hFlush stdout  -- Explicitly flush, as there is no newline+    Output_Write ts -> liftIO $ do+      T.putStrLn $ TS.render (not noColor) Nothing ts+      hFlush stdout+    Output_Overwrite ts -> liftIO $ do+      width <- TS.getTerminalWidth+      T.putStr $ "\r" <> TS.render (not noColor) width ts+      hFlush stdout+    Output_ClearLine -> liftIO $ do+      -- Go to the first column and clear the whole line+      putStr "\r"+      clearLine+      hFlush stdout+  return $ isOverwrite output++-- | Like `putLog` but without the implicit newline added.+putLogRaw :: CliLog m => Severity -> Text -> m ()+putLogRaw sev = logMessage . Output_LogRaw . WithSeverity sev++-- | Indicates unstructured errors form one variant (or conceptual projection)+-- of the error type.+--+-- Shouldn't really use this, but who has time to clean up that much!+class AsUnstructuredError e where+  asUnstructuredError :: Prism' e Text++instance AsUnstructuredError Text where+  asUnstructuredError = id++-- | Like `putLog Alert` but also abrupts the program.+failWith :: (CliThrow e m, AsUnstructuredError e) => Text -> m a+failWith = throwError . review asUnstructuredError++-- | Intercept ExitFailure exceptions and log the given alert before exiting.+--+-- This is useful when you want to provide contextual information to a deeper failure.+withExitFailMessage :: (CliLog m, MonadCatch m) => Text -> m a -> m a+withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do+  case e of+    ExitFailure _ -> putLog Alert msg+    ExitSuccess -> pure ()+  throwM e++-- | Write log to stdout, with colors (unless `noColor`)+writeLog :: (MonadIO m, MonadMask m) => Bool -> Bool -> WithSeverity Text -> 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 >= Debug = TS.putStrWithSGR debugColors h withNewLine s+      | otherwise = liftIO $ putFn s++    putFn = if withNewLine then T.hPutStrLn h else T.hPutStr h+    h = if severity <= Error then stderr else stdout+    errorColors = [SetColor Foreground Vivid Red]+    warningColors = [SetColor Foreground Vivid Yellow]+    debugColors = [SetConsoleIntensity FaintIntensity]++-- | Allow the user to immediately switch to verbose logging upon pressing a particular key.+--+-- 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++-- | Like `getChar` but also retrieves the subsequently pressed keys.+--+-- Allowing, for example, the ↑ key, which consists of the three characters+-- ['\ESC','[','A'] to be distinguished from an actual \ESC character input.+getChars :: IO String+getChars = reverse <$> f mempty+  where+    f xs = do+      x <- getChar+      hReady stdin >>= \case+        True -> f (x:xs)+        False -> return (x:xs)++-- | Conservatively determines whether the encoding supports Unicode.+--+-- Currently this uses a whitelist of known-to-work encodings. In principle it+-- could test dynamically by opening a file with this encoding, but it doesn't+-- look like base exposes any way to determine this in a pure fashion.+supportsUnicode :: TextEncoding -> Bool+supportsUnicode enc = any ((textEncodingName enc ==) . textEncodingName)+  [ utf8+  , utf8_bom+  , utf16+  , utf16be+  , utf16le+  , utf32+  , utf32be+  , utf32le+  ]
+ src/Cli/Extras/Process.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`)+-- and is thus spinner friendly.+module Cli.Extras.Process+  ( AsProcessFailure (..)+  , ProcessFailure (..)+  , ProcessSpec (..)+  , callCommand+  , callProcess+  , callProcessAndLogOutput+  , createProcess+  , createProcess_+  , overCreateProcess+  , proc+  , readCreateProcessWithExitCode+  , readProcessAndLogOutput+  , readProcessAndLogStderr+  , readProcessJSONAndLogStderr+  , reconstructCommand+  , setCwd+  , setDelegateCtlc+  , setEnvOverride+  , shell+  , waitForProcess+  , prettyProcessFailure+  ) where++import Control.Monad ((<=<), join, void)+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 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+import Data.Text.Encoding.Error (lenientDecode)+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..))+import System.IO (Handle)+import System.IO.Streams (InputStream, handleToInputStream)+import qualified System.IO.Streams as Streams+import System.IO.Streams.Concurrent (concurrentMerge)+import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), std_err, std_out)+import qualified System.Process as Process+import qualified Data.Aeson as Aeson++import Control.Monad.Log (Severity (..))+import Cli.Extras.Logging (putLog, putLogRaw)+import Cli.Extras.Types (CliLog, CliThrow)++data ProcessSpec = ProcessSpec+  { _processSpec_createProcess :: !CreateProcess+  , _processSpec_overrideEnv :: !(Maybe (Map String String -> Map String String))+  }++proc :: FilePath -> [String] -> ProcessSpec+proc cmd args = ProcessSpec (Process.proc cmd args) Nothing++shell :: String -> ProcessSpec+shell cmd = ProcessSpec (Process.shell cmd) Nothing++setEnvOverride :: (Map String String -> Map String String) -> ProcessSpec -> ProcessSpec+setEnvOverride f p = p { _processSpec_overrideEnv = Just f }++overCreateProcess :: (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec+overCreateProcess f (ProcessSpec p x) = ProcessSpec (f p) x++setDelegateCtlc :: Bool -> ProcessSpec -> ProcessSpec+setDelegateCtlc b = overCreateProcess (\p -> p { Process.delegate_ctlc = b })++setCwd :: Maybe FilePath -> ProcessSpec -> ProcessSpec+setCwd fp = overCreateProcess (\p -> p { Process.cwd = fp })+++-- TODO put back in `Cli.Extras.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+  asProcessFailure :: Prism' e ProcessFailure++instance AsProcessFailure ProcessFailure where+  asProcessFailure = id++readProcessAndLogStderr+  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)+  => Severity -> ProcessSpec -> m Text+readProcessAndLogStderr sev process = do+  (out, _err) <- withProcess process $ \_out err -> do+    streamToLog =<< liftIO (streamHandle sev err)+  liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out++readProcessJSONAndLogStderr+  :: (Aeson.FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)+  => Severity -> ProcessSpec -> m a+readProcessJSONAndLogStderr sev process = do+  (out, _err) <- withProcess process $ \_out err -> do+    streamToLog =<< liftIO (streamHandle sev err)+  json <- liftIO $ BS.hGetContents out+  case Aeson.eitherDecodeStrict json of+    Right a -> pure a+    Left err -> do+      putLog Error $ "Could not decode process output as JSON: " <> T.pack err+      throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) 0++readCreateProcessWithExitCode+  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)+  => 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)+-- 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)`.+readProcessAndLogOutput+  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)+  => (Severity, Severity) -> 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++  -- TODO interleave stdout and stderr in log correctly+  streamToLog =<< liftIO (streamHandle sev_err err)+  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++-- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)+-- 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)`.+callProcessAndLogOutput+  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)+  => (Severity, Severity) -> ProcessSpec -> m ()+callProcessAndLogOutput (sev_out, sev_err) process =+  void $ withProcess process $ \out err -> do+    stream <- liftIO $ join $ combineStream+      <$> streamHandle sev_out out+      <*> streamHandle sev_err err+    streamToLog stream+  where+    combineStream s1 s2 = concurrentMerge [s1, s2]++-- | Like 'System.Process.createProcess' but also logs (debug) the process being run+createProcess+  :: (MonadIO m, CliLog m)+  => ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess procSpec = do+  p <- mkCreateProcess procSpec+  putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec+  liftIO $ Process.createProcess p++-- | Like `System.Process.createProcess_` but also logs (debug) the process being run+createProcess_+  :: (MonadIO m, CliLog m)+  => String -> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess_ name procSpec = do+  p <- mkCreateProcess procSpec+  putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructProcSpec procSpec+  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) }++-- | Like `System.Process.callProcess` but also logs (debug) the process being run+callProcess+  :: (MonadIO m, CliLog m)+  => String -> [String] -> m ()+callProcess exe args = do+  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+callCommand+  :: (MonadIO m, CliLog m)+  => String -> m ()+callCommand cmd = do+  putLog Debug $ "Calling command " <> T.pack cmd+  liftIO $ Process.callCommand cmd++withProcess+  :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail 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++  waitForProcess p >>= \case+    ExitSuccess -> return (out, err)+    ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code++-- Create an input stream from the file handle, associating each item with the given severity.+streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))+streamHandle sev = Streams.map (sev,) <=< handleToInputStream++-- | Read from an input stream and log its contents+streamToLog+  :: (MonadIO m, CliLog m)+  => InputStream (Severity, BSC.ByteString) -> m ()+streamToLog stream = fix $ \loop -> do+  liftIO (Streams.read stream) >>= \case+    Nothing -> return ()+    Just (sev, line) -> putLogRaw sev (T.decodeUtf8With lenientDecode line) >> loop++-- | Wrapper around `System.Process.waitForProcess`+waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode+waitForProcess = liftIO . Process.waitForProcess++-- | 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) <> "'"++reconstructProcSpec :: ProcessSpec -> Text+reconstructProcSpec = reconstructCommand . Process.cmdspec . _processSpec_createProcess
+ src/Cli/Extras/Spinner.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Provides a simple CLI spinner that interoperates cleanly with the rest of the logging output.+module Cli.Extras.Spinner+  ( withSpinner+  , withSpinnerNoTrail+  , withSpinner'+  ) where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Monad (forM_, (>=>))+import Control.Monad.Catch (MonadMask, mask, onException)+import Control.Monad.IO.Class+import Control.Monad.Log (Severity (..), logMessage)+import Data.IORef+import qualified Data.List as L+import Data.Maybe (isNothing)+import Data.Text (Text)+import System.Console.ANSI (Color (Blue, Cyan, Green, Red))++import Cli.Extras.Logging (allowUserToMakeLoggingVerbose, putLog, handleLog)+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)+  => Text -> m a -> m a+withSpinner s = withSpinner' s $ Just $ const s++-- | A spinner that leaves no trail after a successful run.+--+-- Use if you wish the spinner to be ephemerally visible to the user.+--+-- 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)+  => 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)+  => Text+  -> Maybe (a -> Text) -- ^ Leave an optional trail with the given message creator+  -> m a+  -> m a+withSpinner' msg mkTrail action = do+  cliConf <- getCliConfig+  let noSpinner = _cliConfig_noSpinner cliConf+  if noSpinner+    then putLog Notice msg >> action+    else bracket' run cleanup $ const action+  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+          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+          pure [ctrleThread, spinnerThread]+        False -> -- Sub-spinner; nothing to do.+          pure []+    cleanup tids resultM = do+      liftIO $ mapM_ killThread tids+      logMessage Output_ClearLine+      cliConf <- getCliConfig+      let theme = _cliConfig_theme cliConf+      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.+          )+        Just result ->+          ( TerminalString_Colorized Green $ _cliTheme_done $ _cliConfig_theme cliConf+          , mkTrail <*> pure result+          )+      -- Last message, finish off with newline.+      forM_ logsM $ logMessage . Output_Write+    pushSpinner (flag, old) =+      ( (isTemporary : flag, TerminalString_Normal msg : old)+      , null old -- Is empty?+      )+      where+        isTemporary = isNothing mkTrail+    popSpinner theme (mark, trailMsgM) (flag, old) =+      ( (newFlag, new)+      -- With final trail spinner message to render+      , renderSpinnerStack theme mark . (: new) . TerminalString_Normal <$> (+          if inTemporarySpinner then Nothing else trailMsgM+          )+      )+      where+        inTemporarySpinner = or newFlag  -- One of our parent spinners is temporary+        newFlag = drop 1 flag+        new = L.delete (TerminalString_Normal msg) old+    modifyStack f = liftIO . flip atomicModifyIORef' f+      =<< fmap _cliConfig_spinnerStack getCliConfig++-- | How nested spinner logs should be displayed+renderSpinnerStack+  :: CliTheme+  -> TerminalString  -- ^ That which comes before the final element in stack+  -> [TerminalString]  -- ^ Spinner elements in reverse order+  -> [TerminalString]+renderSpinnerStack theme mark = L.intersperse space . go . L.reverse+  where+    go [] = []+    go (x:[]) = mark : [x]+    go (x:xs) = arrow : x : go xs+    arrow = TerminalString_Colorized Blue $ _cliTheme_arrow theme+    space = TerminalString_Normal " "++-- | A spinner is simply an infinite list of strings that supplant each other in a delayed loop, creating the+-- animation of a "spinner".+type Spinner = [TerminalString]++coloredSpinner :: SpinnerTheme -> Spinner+coloredSpinner = cycle . fmap (TerminalString_Colorized Cyan)++-- | Run a spinner with a monadic function that defines how to represent the individual spinner characters.+runSpinner :: MonadIO m => Spinner -> (TerminalString -> m ()) -> m ()+runSpinner spinner f = forM_ spinner $ f >=> const delay+  where+    delay = liftIO $ threadDelay 100000  -- A shorter delay ensures that we update promptly.++-- | Like `bracket` but the `release` function can know whether an exception was raised+bracket' :: MonadMask m => m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c+bracket' acquire release use = mask $ \unmasked -> do+  resource <- acquire+  result <- unmasked (use resource) `onException` release resource Nothing+  _ <- release resource $ Just result+  return result
+ src/Cli/Extras/SubExcept.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+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)+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 }++newtype SubExceptT e eSub m a = SubExceptT { unSubExceptT :: ReaderT (WrappedPrism' e eSub) m a }+  deriving (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask, MonadIO, MonadFail)++deriving instance MonadLog o m => MonadLog o (SubExceptT e eSub m)++instance MonadTrans (SubExceptT e eSub) where+  lift = SubExceptT . lift++instance MonadError e m => MonadError eSub (SubExceptT e eSub m) where+  throwError e = SubExceptT $ do+    WrappedPrism' p <- ask+    throwError $ review p e+  catchError a h = SubExceptT $ do+    WrappedPrism' p <- ask+    lift $ catchError (runSubExceptT p a) $ \e -> case preview p e of+      Nothing -> throwError e+      Just eSub -> runSubExceptT p $ h eSub++runSubExceptT :: Prism' e eSub -> SubExceptT e eSub m a -> m a+runSubExceptT p a = runReaderT (unSubExceptT a) (WrappedPrism' p)
+ src/Cli/Extras/TerminalString.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Types and functions dealing with strings to be printed on terminal.+module Cli.Extras.TerminalString+  ( TerminalString(..)+  , render+  , putStrWithSGR+  , getTerminalWidth+  , enquiryCode+  ) where++import Control.Monad (when)+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+import System.Console.ANSI+import qualified System.Console.Terminal.Size as TerminalSize+import System.IO (Handle)++-- | Printable text on terminals+--+-- Represents text with an optional color code.+data TerminalString+  = TerminalString_Normal Text+  | TerminalString_Colorized Color Text+  deriving (Eq, Show, Ord)++printableLength :: [TerminalString] -> Int+printableLength = T.length . toText False++-- Render a list of TerminalString as Text that can be directly putStr'ed.+render+  :: Bool -- ^ with color+  -> Maybe Int -- ^ optionally, trim to maximum width+  -> [TerminalString]+  -> Text+render withColor w ts = trim w $ toText withColor ts+  where+    trim = \case+      Nothing -> id+      Just n -> \s -> if printableLength ts > n+        then T.take (n-3) s <> "..." <> T.pack resetCode+        else s++toText :: Bool -> [TerminalString] -> Text+toText withColor = mconcat . map (toText' withColor)++-- | Convert to Text, controlling whether colorization should happen.+toText' :: Bool -> TerminalString -> Text+toText' withColor = \case+  TerminalString_Normal s -> s+  TerminalString_Colorized c s -> if withColor then colorizeText c s else s++-- | Colorize the given text so that it is printed in color when using putStr.+colorizeText :: Color -> Text -> Text+colorizeText color s = mconcat+  [ T.pack $ setSGRCode [SetColor Foreground Vivid color]+  , s+  , T.pack resetCode+  ]++-- | Safely print the string with the given ANSI control codes, resetting in the end.+putStrWithSGR :: MonadIO m => [SGR] -> Handle -> Bool -> Text -> m ()+putStrWithSGR sgr h withNewLine s = liftIO $ bracket_ (hSetSGR h sgr) reset $ T.hPutStr h s+  where+    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+enquiryCode :: String+enquiryCode = "\ENQ"++-- | Code to reset ANSI colors+resetCode :: String+resetCode = setSGRCode [Reset]++getTerminalWidth :: IO (Maybe Int)+getTerminalWidth = fmap TerminalSize.width <$> TerminalSize.size+
+ src/Cli/Extras/Theme.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Cli.Extras.Theme where++import Data.Text (Text)++data CliTheme = CliTheme+  { _cliTheme_done :: Text+  , _cliTheme_failed :: Text+  , _cliTheme_arrow :: Text+  , _cliTheme_spinner :: SpinnerTheme+  }++type SpinnerTheme = [Text]++unicodeTheme :: CliTheme+unicodeTheme = CliTheme+  { _cliTheme_done = "✔"+  , _cliTheme_failed = "✖"+  , _cliTheme_arrow = "⇾"+  , _cliTheme_spinner = ["◐", "◓", "◑", "◒"]+  }++noUnicodeTheme :: CliTheme+noUnicodeTheme = CliTheme+  { _cliTheme_done = "DONE"+  , _cliTheme_failed = "FAILED"+  , _cliTheme_arrow = "->"+  , _cliTheme_spinner = ["|", "/", "-", "\\"]+  }
+ src/Cli/Extras/Types.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+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.Writer (WriterT)+import Control.Monad.State (StateT)+import Control.Monad.Except (ExceptT, MonadError (..))+import Control.Monad.Trans (MonadTrans, lift)+import Data.IORef (IORef)+import Data.Text (Text)++import Cli.Extras.TerminalString (TerminalString)+import Cli.Extras.Theme (CliTheme)+import Cli.Extras.SubExcept++--------------------------------------------------------------------------------++data Output+  = Output_Log (WithSeverity Text)  -- Regular logging message (with colors and newlines)+  | Output_LogRaw (WithSeverity Text)  -- Like `Output_Log` but without the implicit newline added.+  | Output_Write [TerminalString]  -- Render and write a TerminalString using putstrLn+  | Output_Overwrite [TerminalString]  -- Overwrite the current line (i.e. \r followed by `putStr`)+  | Output_ClearLine  -- Clear the line+  deriving (Eq, Show, Ord)++type CliLog m = MonadLog Output m++type CliThrow e m = MonadError e m++deriving instance MonadFail m => MonadFail (LoggingT Output m)++--------------------------------------------------------------------------------++data CliConfig = CliConfig+  { -- | We are capable of changing the log level at runtime+    _cliConfig_logLevel :: IORef Severity+  , -- | Disallow coloured output+    _cliConfig_noColor :: Bool+  , -- | Disallow spinners+    _cliConfig_noSpinner :: Bool+  , -- | Whether the last message was an Overwrite output+    _cliConfig_lock :: MVar Bool+  , -- | Whether the user tip (to make verbose) was already displayed+    _cliConfig_tipDisplayed :: IORef Bool+  , -- | Stack of logs from nested spinners+    _cliConfig_spinnerStack :: IORef ([Bool], [TerminalString])+  , -- | 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++instance (Monoid w, HasCliConfig m) => HasCliConfig (WriterT w m) where+  getCliConfig = lift getCliConfig++instance HasCliConfig m => HasCliConfig (StateT s m) where+  getCliConfig = lift getCliConfig++instance HasCliConfig m => HasCliConfig (ExceptT e m) where+  getCliConfig = lift getCliConfig++instance HasCliConfig m => HasCliConfig (SubExceptT e eSub m) where+  getCliConfig = lift getCliConfig++--------------------------------------------------------------------------------++newtype CliT e m a = CliT+  { unCliT :: ReaderT CliConfig (LoggingT Output (ExceptT e m)) a+  }+  deriving+    ( Functor, Applicative, Monad, MonadIO, MonadFail+    , MonadThrow, MonadCatch, MonadMask+    , MonadLog Output -- CliLog+    , MonadError e -- CliThrow+    )++instance MonadTrans (CliT e) where+  lift = CliT . lift . lift . lift++instance Monad m => HasCliConfig (CliT e m)where+  getCliConfig = CliT ask