-- | This module defines the code for actually executing a command with tracing
-- enabled.
module HotelCalifornia.Exec where

import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import HotelCalifornia.Tracing
import HotelCalifornia.Tracing.TraceParent
import System.Environment (getEnvironment)
import qualified System.Posix.Escape.Unicode as Escape
import Options.Applicative hiding (command)
import System.Exit
import System.Process.Typed

data Subprocess = Proc (NonEmpty String) | Shell String

commandToString :: Subprocess -> String
commandToString :: Subprocess -> String
commandToString (Proc NonEmpty String
tokens) = [String] -> String
Escape.escapeMany (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty String
tokens)
commandToString (Shell String
line) = String
line

commandToProcessConfig :: Subprocess -> ProcessConfig () () ()
commandToProcessConfig :: Subprocess -> ProcessConfig () () ()
commandToProcessConfig (Proc (String
command :| [String]
args)) = String -> [String] -> ProcessConfig () () ()
proc String
command [String]
args
commandToProcessConfig (Shell String
line) = String -> ProcessConfig () () ()
shell String
line

data ExecArgs = ExecArgs
    { ExecArgs -> Subprocess
execArgsSubprocess :: Subprocess
    , ExecArgs -> Maybe Text
execArgsSpanName :: Maybe Text
    }

parseProc :: Parser (NonEmpty String)
parseProc :: Parser (NonEmpty String)
parseProc = do
    String
command <- forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument forall s. IsString s => ReadM s
str (forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"COMMAND")
    [String]
arguments <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument forall s. IsString s => ReadM s
str (forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"ARGUMENT"))
    return (String
command forall a. a -> [a] -> NonEmpty a
:| [String]
arguments)

parseShell :: Parser String
parseShell :: Parser String
parseShell =
    forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall s. IsString s => ReadM s
str
        (   forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"SCRIPT"
        forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"shell"
        forall a. Semigroup a => a -> a -> a
<>  forall (f :: * -> *) a. String -> Mod f a
help String
"Run an arbitrary shell script instead of running an executable command"
        )

parseSubprocess :: Parser Subprocess
parseSubprocess :: Parser Subprocess
parseSubprocess = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty String -> Subprocess
Proc Parser (NonEmpty String)
parseProc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Subprocess
Shell Parser String
parseShell

parseExecArgs :: Parser ExecArgs
parseExecArgs :: Parser ExecArgs
parseExecArgs = do
    Maybe Text
execArgsSpanName <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional do
        forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall s. IsString s => ReadM s
str forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"SPAN_NAME"
            , forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"span-name"
            , forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's'
            , forall (f :: * -> *) a. String -> Mod f a
help String
"The name of the span that the program reports. By default, this is the script you pass in."
            ]
    Subprocess
execArgsSubprocess <- Parser Subprocess
parseSubprocess
    pure ExecArgs{Maybe Text
Subprocess
execArgsSubprocess :: Subprocess
execArgsSpanName :: Maybe Text
execArgsSpanName :: Maybe Text
execArgsSubprocess :: Subprocess
..}

runExecArgs :: ExecArgs -> IO ()
runExecArgs :: ExecArgs -> IO ()
runExecArgs ExecArgs {Maybe Text
Subprocess
execArgsSpanName :: Maybe Text
execArgsSubprocess :: Subprocess
execArgsSpanName :: ExecArgs -> Maybe Text
execArgsSubprocess :: ExecArgs -> Subprocess
..} = do
    let script :: String
script = Subprocess -> String
commandToString Subprocess
execArgsSubprocess
        spanName :: Text
spanName =
            forall a. a -> Maybe a -> a
fromMaybe (String -> Text
Text.pack String
script) Maybe Text
execArgsSpanName

    forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> (Span -> m a) -> m a
inSpan' Text
spanName \Span
span_ -> do
        [(String, String)]
newEnv <- Span -> IO [(String, String)]
spanContextToEnvironment Span
span_
        [(String, String)]
fullEnv <- forall a. Monoid a => a -> a -> a
mappend [(String, String)]
newEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment

        let processConfig :: ProcessConfig () () ()
processConfig = Subprocess -> ProcessConfig () () ()
commandToProcessConfig Subprocess
execArgsSubprocess

        ExitCode
exitCode <- forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess forall a b. (a -> b) -> a -> b
$ forall stdin stdout stderr.
[(String, String)]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnv [(String, String)]
fullEnv ProcessConfig () () ()
processConfig
        case ExitCode
exitCode of
            ExitCode
ExitSuccess ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ExitCode
_ ->
                forall a. ExitCode -> IO a
exitWith ExitCode
exitCode