{-# LANGUAGE QuasiQuotes #-}

module RunCommand where

import Control.Monad.Logger.CallStack (MonadLogger, logError, logInfo)
import Data.ByteString qualified as ByteString
import Data.ByteString.Lazy qualified as Lazy
import Data.Char qualified as Char
import Data.List qualified as List
import Data.Text qualified as Text
import PossehlAnalyticsPrelude
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import System.Exit qualified as Exit
import System.Exit qualified as System
import System.IO (Handle)
import System.Process.Typed qualified as Process

-- | Given a a command, the executable and arguments,
-- spawn the tool as subprocess and collect its stdout (stderr will go to our stderr).
--
-- Will strip the stdout of trailing newlines.
--
-- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
runCommand :: (MonadLogger m, MonadIO m) => FilePath -> [Text] -> m (Exit.ExitCode, ByteString)
runCommand :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> m (ExitCode, ByteString)
runCommand FilePath
executable [Text]
args = do
  let bashArgs :: Text
bashArgs = [Text] -> Text
prettyArgsForBash ((FilePath
executable forall a b. a -> (a -> b) -> b
& FilePath -> Text
stringToText) forall a. a -> [a] -> [a]
: [Text]
args)
  forall (m :: Type -> Type).
(HasCallStack, MonadLogger m) =>
Text -> m ()
logInfo [fmt|Running: $ {bashArgs}|]
  FilePath -> [FilePath] -> ProcessConfig () () ()
Process.proc
    FilePath
executable
    ([Text]
args forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> FilePath
textToString)
    forall a b. a -> (a -> b) -> b
& forall (m :: Type -> Type) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr
-> m (ExitCode, ByteString)
Process.readProcessStdout
    forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> ByteString
toStrictBytes
    forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> ByteString
stripWhitespaceFromEnd

-- | Given a a command, the executable and arguments,
-- spawn the tool as subprocess and run it to conclusion.
--
-- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
runCommandNoStdout :: (MonadLogger m, MonadIO m) => FilePath -> [Text] -> m Exit.ExitCode
runCommandNoStdout :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> m ExitCode
runCommandNoStdout FilePath
executable [Text]
args = do
  let bashArgs :: Text
bashArgs = [Text] -> Text
prettyArgsForBash ((FilePath
executable forall a b. a -> (a -> b) -> b
& FilePath -> Text
stringToText) forall a. a -> [a] -> [a]
: [Text]
args)
  forall (m :: Type -> Type).
(HasCallStack, MonadLogger m) =>
Text -> m ()
logInfo [fmt|Running: $ {bashArgs}|]
  FilePath -> [FilePath] -> ProcessConfig () () ()
Process.proc
    FilePath
executable
    ([Text]
args forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> FilePath
textToString)
    forall a b. a -> (a -> b) -> b
& forall (m :: Type -> Type) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
Process.runProcess

-- TODO: This is reversing the whole string *twice*. Can we strip from end without doing that?
stripWhitespaceFromEnd :: ByteString -> ByteString
stripWhitespaceFromEnd :: ByteString -> ByteString
stripWhitespaceFromEnd = ByteString -> ByteString
ByteString.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
ByteString.dropWhile (\Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
== Char -> Word8
charToWordUnsafe Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
ByteString.reverse

-- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin.
runCommandWithStdin :: (MonadLogger m, MonadIO m) => FilePath -> [Text] -> Lazy.ByteString -> m (Exit.ExitCode, ByteString)
runCommandWithStdin :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> ByteString -> m (ExitCode, ByteString)
runCommandWithStdin FilePath
executable [Text]
args ByteString
stdin = do
  let bashArgs :: Text
bashArgs = [Text] -> Text
prettyArgsForBash ((FilePath
executable forall a b. a -> (a -> b) -> b
& FilePath -> Text
stringToText) forall a. a -> [a] -> [a]
: [Text]
args)
  forall (m :: Type -> Type).
(HasCallStack, MonadLogger m) =>
Text -> m ()
logInfo [fmt|Running: $ {bashArgs}|]
  FilePath -> [FilePath] -> ProcessConfig () () ()
Process.proc
    FilePath
executable
    ([Text]
args forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> FilePath
textToString)
    forall a b. a -> (a -> b) -> b
& forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
Process.setStdin (ByteString -> StreamSpec 'STInput ()
Process.byteStringInput ByteString
stdin)
    forall a b. a -> (a -> b) -> b
& forall (m :: Type -> Type) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr
-> m (ExitCode, ByteString)
Process.readProcessStdout
    forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> ByteString
toStrictBytes
    forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> ByteString
stripWhitespaceFromEnd

-- | Like 'runCommandExpect0', but don’t capture stdout,
-- connect stdin and stdout to the command until it returns.
--
-- This is for interactive subcommands.
runCommandInteractiveExpect0 :: (MonadLogger m, MonadIO m) => FilePath -> [Text] -> m ()
runCommandInteractiveExpect0 :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> m ()
runCommandInteractiveExpect0 FilePath
executable [Text]
args = do
  let bashArgs :: Text
bashArgs = [Text] -> Text
prettyArgsForBash ((FilePath
executable forall a b. a -> (a -> b) -> b
& FilePath -> Text
stringToText) forall a. a -> [a] -> [a]
: [Text]
args)
  forall (m :: Type -> Type).
(HasCallStack, MonadLogger m) =>
Text -> m ()
logInfo [fmt|Running interactively: $ {bashArgs}|]
  ( forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall (m :: Type -> Type) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
Process.runProcess forall a b. (a -> b) -> a -> b
$
        FilePath -> [FilePath] -> ProcessConfig () () ()
Process.proc
          FilePath
executable
          ([Text]
args forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> FilePath
textToString)
    )
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> ExitCode -> m ()
checkStatus0 FilePath
executable

-- | Given a name of a command, the executable and arguments,
-- spawn the tool as subprocess and pipe its stdout to the given 'Handle'.
--
-- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
runCommandPipeToHandle :: (MonadLogger m, MonadIO m) => FilePath -> [Text] -> Handle -> m Exit.ExitCode
runCommandPipeToHandle :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> Handle -> m ExitCode
runCommandPipeToHandle FilePath
executable [Text]
args Handle
handle = do
  -- TODO log the output file?
  let bashArgs :: Text
bashArgs = [Text] -> Text
prettyArgsForBash ((FilePath
executable forall a b. a -> (a -> b) -> b
& FilePath -> Text
stringToText) forall a. a -> [a] -> [a]
: [Text]
args)
  forall (m :: Type -> Type).
(HasCallStack, MonadLogger m) =>
Text -> m ()
logInfo [fmt|Running: $ {bashArgs}|]
  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    forall (m :: Type -> Type) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
Process.runProcess
      ( FilePath -> [FilePath] -> ProcessConfig () () ()
Process.proc
          FilePath
executable
          ([Text]
args forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> FilePath
textToString)
          forall a b. a -> (a -> b) -> b
& forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
Process.setStdout (forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
Process.useHandleClose Handle
handle)
      )

-- | Like 'runCommand' but exit if the command returns a non-0 status.
runCommandExpect0 :: (MonadLogger m, MonadIO m) => FilePath -> [Text] -> m ByteString
runCommandExpect0 :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> m ByteString
runCommandExpect0 FilePath
executable [Text]
args =
  forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> m (ExitCode, ByteString)
runCommand FilePath
executable [Text]
args forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (ExitCode
ex, ByteString
stdout) -> do
      forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> ExitCode -> m ()
checkStatus0 FilePath
executable ExitCode
ex
      pure ByteString
stdout

-- | Like 'runCommandNoStdout' but exit if the command returns a non-0 status.
runCommandExpect0NoStdout :: (MonadLogger m, MonadIO m) => FilePath -> [Text] -> m ()
runCommandExpect0NoStdout :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> m ()
runCommandExpect0NoStdout FilePath
executable [Text]
args =
  forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> m ExitCode
runCommandNoStdout FilePath
executable [Text]
args forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitCode
ex -> forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> ExitCode -> m ()
checkStatus0 FilePath
executable ExitCode
ex

-- | Like 'runCommandWithStdin' but exit if the command returns a non-0 status.
runCommandWithStdinExpect0 :: (MonadLogger m, MonadIO m) => FilePath -> [Text] -> Lazy.ByteString -> m ByteString
runCommandWithStdinExpect0 :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> ByteString -> m ByteString
runCommandWithStdinExpect0 FilePath
executable [Text]
args ByteString
stdin =
  forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> [Text] -> ByteString -> m (ExitCode, ByteString)
runCommandWithStdin FilePath
executable [Text]
args ByteString
stdin forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (ExitCode
ex, ByteString
stdout) -> do
      forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> ExitCode -> m ()
checkStatus0 FilePath
executable ExitCode
ex
      pure ByteString
stdout

-- | Check whether a command exited 0 or crash.
checkStatus0 :: (MonadLogger m, MonadIO m) => FilePath -> ExitCode -> m ()
checkStatus0 :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> ExitCode -> m ()
checkStatus0 FilePath
executable = \case
  ExitCode
ExitSuccess -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  ExitFailure Int
status -> do
    forall (m :: Type -> Type) b.
(HasCallStack, MonadLogger m, MonadIO m) =>
Text -> m b
logCritical [fmt|Command `{executable}` did not exit with status 0 (success), but status {status}|]

-- | Log the message with 'logError', and call 'System.exitFailure'.
logCritical :: (HasCallStack, MonadLogger m, MonadIO m) => Text -> m b
logCritical :: forall (m :: Type -> Type) b.
(HasCallStack, MonadLogger m, MonadIO m) =>
Text -> m b
logCritical Text
msg = do
  forall (m :: Type -> Type).
(HasCallStack, MonadLogger m) =>
Text -> m ()
logError Text
msg
  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a
System.exitFailure

-- | Pretty print a command line in a way that can be copied to bash.
prettyArgsForBash :: [Text] -> Text
prettyArgsForBash :: [Text] -> Text
prettyArgsForBash = Text -> [Text] -> Text
Text.intercalate Text
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
simpleBashEscape

-- | Simple escaping for bash words. If they contain anything that’s not ascii chars
-- and a bunch of often-used special characters, put the word in single quotes.
simpleBashEscape :: Text -> Text
simpleBashEscape :: Text -> Text
simpleBashEscape Text
t = do
  case (Char -> Bool) -> Text -> Maybe Char
Text.find (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSimple) Text
t of
    Just Char
_ -> Text -> Text
escapeSingleQuote Text
t
    Maybe Char
Nothing -> Text
t
  where
    -- any word that is just ascii characters is simple (no spaces or control characters)
    -- or contains a few often-used characters like - or .
    isSimple :: Char -> Bool
isSimple Char
c =
      Char -> Bool
Char.isAsciiLower Char
c
        Bool -> Bool -> Bool
|| Char -> Bool
Char.isAsciiUpper Char
c
        Bool -> Bool -> Bool
|| Char -> Bool
Char.isDigit Char
c
        -- These are benign, bash will not interpret them as special characters.
        Bool -> Bool -> Bool
|| forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
List.elem Char
c [Char
'-', Char
'.', Char
':', Char
'/']
    -- Put the word in single quotes
    -- If there is a single quote in the word,
    -- close the single quoted word, add a single quote, open the word again
    escapeSingleQuote :: Text -> Text
escapeSingleQuote Text
t' = Text
"'" forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text -> Text
Text.replace Text
"'" Text
"'\\''" Text
t' forall a. Semigroup a => a -> a -> a
<> Text
"'"