diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,18 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## Unreleased + +## 0.0.4.0 - 2024-01-26 + +- [#14](https://github.com/parsonsmatt/hotel-california/pull/14/) + - Add the `--set-sigint-status` to control how `Ctrl-C` and `SIGINT` are + reported. +- [#16](https://github.com/parsonsmatt/hotel-california/pull/16) + - You can now provide attributes for the span that `hotel-california` + creates by passing the CLI argument `--attribute KEY=VALUE`. Only string + attributes are currently supported. + ## 0.0.3.0 - 2023-09-18 - [#13](https://github.com/parsonsmatt/hotel-california/pull/13) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,6 +11,8 @@ ```sh $ hotel exec --help Usage: hotel exec [-s|--span-name SPAN_NAME] + [-i|--set-sigint-status SPAN_STATUS] + [-a|--attribute KEY=VALUE]... (COMMAND [ARGUMENT]... | --shell SCRIPT) Execute the given command with tracing enabled @@ -19,6 +21,10 @@ -h,--help Show this help text -s,--span-name SPAN_NAME The name of the span that the program reports. By default, this is the script you pass in. + -i,--set-sigint-status SPAN_STATUS + The status reported when the process is killed with + SIGINT. + -a,--attribute KEY=VALUE A string attribute to add to the span. --shell SCRIPT Run an arbitrary shell script instead of running an executable command ``` diff --git a/hotel-california.cabal b/hotel-california.cabal --- a/hotel-california.cabal +++ b/hotel-california.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.35.4. -- -- see: https://github.com/sol/hpack name: hotel-california -version: 0.0.3.0 +version: 0.0.4.0 description: Please see the README on GitHub at homepage: https://github.com/parsonsmatt/hotel-california#readme bug-reports: https://github.com/parsonsmatt/hotel-california/issues @@ -87,6 +87,7 @@ , time , typed-process , unliftio + , unordered-containers default-language: Haskell2010 executable hotel @@ -150,6 +151,7 @@ , time , typed-process , unliftio + , unordered-containers default-language: Haskell2010 test-suite hotel-california-test @@ -214,4 +216,5 @@ , time , typed-process , unliftio + , unordered-containers default-language: Haskell2010 diff --git a/src/HotelCalifornia/Exec.hs b/src/HotelCalifornia/Exec.hs --- a/src/HotelCalifornia/Exec.hs +++ b/src/HotelCalifornia/Exec.hs @@ -2,17 +2,23 @@ -- enabled. module HotelCalifornia.Exec where +import qualified Control.Exception as Exception +import qualified Data.Char as Char import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe) -import Data.Text (Text) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text +import Data.Text (Text) import HotelCalifornia.Tracing import HotelCalifornia.Tracing.TraceParent -import System.Environment (getEnvironment) -import qualified System.Posix.Escape.Unicode as Escape +import qualified OpenTelemetry.Trace.Core as Otel +import OpenTelemetry.Trace (Attribute(..), PrimitiveAttribute(..)) import Options.Applicative hiding (command) +import System.Environment (getEnvironment) import System.Exit +import qualified System.Posix.Escape.Unicode as Escape import System.Process.Typed data Subprocess = Proc (NonEmpty String) | Shell String @@ -28,8 +34,24 @@ data ExecArgs = ExecArgs { execArgsSubprocess :: Subprocess , execArgsSpanName :: Maybe Text + , execArgsSigintStatus :: SpanStatus' + , execArgsAttributes :: HashMap Text Attribute } +-- | A variant of 'SpanStatus' that does not include a 'Text' for error. +data SpanStatus' + = SpanUnset + | SpanOk + | SpanError + +parseSpanStatus' :: ReadM SpanStatus' +parseSpanStatus' = eitherReader \s -> + case map Char.toLower s of + "unset" -> Right SpanUnset + "ok" -> Right SpanOk + "error" -> Right SpanError + _ -> Left $ mconcat ["Expected one of `unset`, `ok`, or `error` for SPAN_STATUS. Got: ", s] + parseProc :: Parser (NonEmpty String) parseProc = do command <- argument str (metavar "COMMAND") @@ -47,6 +69,14 @@ parseSubprocess :: Parser Subprocess parseSubprocess = fmap Proc parseProc <|> fmap Shell parseShell +-- | Parse a `key=value` string into an attribute. +parseAttribute :: String -> Either String (Text, Attribute) +parseAttribute input = do + let (key, value') = Text.breakOn "=" $ Text.pack input + if Text.null value' || Text.null key + then Left $ "Attributes must contain a non-empty key and value separated by `=`: " <> input + else pure $ (key, AttributeValue $ TextAttribute $ Text.drop 1 value') + parseExecArgs :: Parser ExecArgs parseExecArgs = do execArgsSpanName <- optional do @@ -56,6 +86,21 @@ , short 's' , help "The name of the span that the program reports. By default, this is the script you pass in." ] + execArgsSigintStatus <- + option parseSpanStatus' $ mconcat + [ metavar "SPAN_STATUS" + , long "set-sigint-status" + , short 'i' + , help "The status reported when the process is killed with SIGINT." + , value SpanUnset + ] + execArgsAttributes <- + HashMap.fromList <$> (many $ option (eitherReader parseAttribute) $ mconcat + [ metavar "KEY=VALUE" + , long "attribute" + , short 'a' + , help "A string attribute to add to the span." + ]) execArgsSubprocess <- parseSubprocess pure ExecArgs{..} @@ -64,16 +109,34 @@ let script = commandToString execArgsSubprocess spanName = fromMaybe (Text.pack script) execArgsSpanName + spanArguments = defaultSpanArguments { Otel.attributes = execArgsAttributes } - inSpan' spanName \span_ -> do + inSpanWith' spanName spanArguments \span_ -> do newEnv <- spanContextToEnvironment span_ fullEnv <- mappend newEnv <$> getEnvironment let processConfig = commandToProcessConfig execArgsSubprocess - exitCode <- runProcess $ setEnv fullEnv processConfig - case exitCode of - ExitSuccess -> + let handleSigInt = + \case + Exception.UserInterrupt -> + case execArgsSigintStatus of + SpanUnset -> + pure Nothing + SpanOk -> do + Otel.setStatus span_ Otel.Ok + pure Nothing + SpanError -> do + Exception.throwIO Exception.UserInterrupt + other -> + Exception.throwIO other + + mexitCode <- Exception.handle handleSigInt $ fmap Just $ runProcess $ setEnv fullEnv processConfig + + case mexitCode of + Just ExitSuccess -> pure () - _ -> + Just exitCode -> exitWith exitCode + Nothing -> + pure ()