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