diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,14 @@ ## Unreleased +## 0.0.5.0 - 2024-02-29 + +- [#19](https://github.com/parsonsmatt/hotel-california/pull/19/) + - Record the command's exit status (`process.exit_status`) and command + attributes. + - This replaces the default `process.executable.name` and related attributes + set by `hs-opentelemetry`. + ## 0.0.4.0 - 2024-01-26 - [#14](https://github.com/parsonsmatt/hotel-california/pull/14/) 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.4. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack name: hotel-california -version: 0.0.4.0 +version: 0.0.5.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 @@ -31,6 +31,7 @@ HotelCalifornia.Tracing.TraceParent other-modules: Paths_hotel_california + HotelCalifornia.Which hs-source-dirs: src default-extensions: @@ -74,6 +75,8 @@ build-depends: base >=4.7 && <5 , bytestring + , directory + , filepath , hs-opentelemetry-api >=0.1.0.0 , hs-opentelemetry-exporter-otlp , hs-opentelemetry-propagator-w3c @@ -137,6 +140,8 @@ build-depends: base >=4.7 && <5 , bytestring + , directory + , filepath , hotel-california , hs-opentelemetry-api >=0.1.0.0 , hs-opentelemetry-exporter-otlp @@ -202,6 +207,8 @@ build-depends: base >=4.7 && <5 , bytestring + , directory + , filepath , hotel-california , hs-opentelemetry-api >=0.1.0.0 , hs-opentelemetry-exporter-otlp diff --git a/src/HotelCalifornia/Exec.hs b/src/HotelCalifornia/Exec.hs --- a/src/HotelCalifornia/Exec.hs +++ b/src/HotelCalifornia/Exec.hs @@ -20,6 +20,7 @@ import System.Exit import qualified System.Posix.Escape.Unicode as Escape import System.Process.Typed +import HotelCalifornia.Which (which) data Subprocess = Proc (NonEmpty String) | Shell String @@ -95,7 +96,7 @@ , value SpanUnset ] execArgsAttributes <- - HashMap.fromList <$> (many $ option (eitherReader parseAttribute) $ mconcat + HashMap.fromList <$> many (option (eitherReader parseAttribute) $ mconcat [ metavar "KEY=VALUE" , long "attribute" , short 'a' @@ -104,29 +105,51 @@ execArgsSubprocess <- parseSubprocess pure ExecArgs{..} +makeInitialAttributes :: Subprocess -> HashMap Text Attribute -> IO (HashMap Text Attribute) +makeInitialAttributes subprocess extraAttributes = do + processAttributes <- + case subprocess of + Proc (command :| args) -> do + pathAttribute <- + (foldMap (\path -> [(executablePathName, Otel.toAttribute $ Text.pack path)])) + <$> which command + pure $ HashMap.fromList $ + [ (commandArgsName, Otel.toAttribute $ map Text.pack args) + , (executableName, Otel.toAttribute $ Text.pack command) + ] <> pathAttribute + Shell _command -> pure mempty + + pure $ processAttributes <> extraAttributes + runExecArgs :: ExecArgs -> IO () runExecArgs ExecArgs {..} = do + initialAttributes <- makeInitialAttributes execArgsSubprocess execArgsAttributes + let script = commandToString execArgsSubprocess spanName = fromMaybe (Text.pack script) execArgsSpanName - spanArguments = defaultSpanArguments { Otel.attributes = execArgsAttributes } + spanArguments = defaultSpanArguments { Otel.attributes = initialAttributes } - inSpanWith' spanName spanArguments \span_ -> do - newEnv <- spanContextToEnvironment span_ + inSpanWith' spanName spanArguments \span' -> do + newEnv <- spanContextToEnvironment span' fullEnv <- mappend newEnv <$> getEnvironment let processConfig = commandToProcessConfig execArgsSubprocess let handleSigInt = \case - Exception.UserInterrupt -> + Exception.UserInterrupt -> do + Otel.addAttribute span' exitStatusName (-2 :: Int) -- SIGINT case execArgsSigintStatus of SpanUnset -> pure Nothing SpanOk -> do - Otel.setStatus span_ Otel.Ok + Otel.setStatus span' Otel.Ok pure Nothing SpanError -> do + -- `hs-opentelemetry` will automatically mark a + -- span as an error if it ends with an + -- exception. Exception.throwIO Exception.UserInterrupt other -> Exception.throwIO other @@ -134,9 +157,25 @@ mexitCode <- Exception.handle handleSigInt $ fmap Just $ runProcess $ setEnv fullEnv processConfig case mexitCode of - Just ExitSuccess -> - pure () - Just exitCode -> - exitWith exitCode + Just exitCode -> do + Otel.addAttribute span' exitStatusName + case exitCode of + ExitSuccess -> 0 + ExitFailure status -> status + case exitCode of + ExitSuccess -> pure () + ExitFailure _ -> exitWith exitCode Nothing -> pure () + +exitStatusName :: Text +exitStatusName = "process.exit_status" + +executablePathName :: Text +executablePathName = "process.executable.path" + +executableName :: Text +executableName = "process.executable.path" + +commandArgsName :: Text +commandArgsName = "process.command_args" diff --git a/src/HotelCalifornia/Which.hs b/src/HotelCalifornia/Which.hs new file mode 100644 --- /dev/null +++ b/src/HotelCalifornia/Which.hs @@ -0,0 +1,81 @@ +-- | Like @which(1)@ but portable. +-- +-- Modified from @shelly@. +module HotelCalifornia.Which (which) where + +import Data.Text qualified as Text +import System.FilePath (splitDirectories, (), isAbsolute, searchPathSeparator) +import System.Directory (doesFileExist, getPermissions, getPermissions, executable) +import System.Environment (getEnv) +import Control.Exception (catch) +import Data.Maybe (isJust) + +-- | Get a full path to an executable by looking at the @PATH@ environement +-- variable. Windows normally looks in additional places besides the +-- @PATH@: this does not duplicate that behavior. +which :: FilePath -> IO (Maybe FilePath) +which path = + if isAbsolute path || startsWithDot splitOnDirs + then checkFile + else lookupPath + where + splitOnDirs = splitDirectories path + + -- 'startsWithDot' receives as input the result of 'splitDirectories', + -- which will include the dot (\".\") as its first element only if this + -- is a path of the form \"./foo/bar/baz.sh\". Check for example: + -- + -- > import System.FilePath as FP + -- > FP.splitDirectories "./test/data/hello.sh" + -- [".","test","data","hello.sh"] + -- > FP.splitDirectories ".hello.sh" + -- [".hello.sh"] + -- > FP.splitDirectories ".test/hello.sh" + -- [".test","hello.sh"] + -- > FP.splitDirectories ".foo" + -- [".foo"] + -- + -- Note that earlier versions of Shelly used + -- \"system-filepath\" which also has a 'splitDirectories' + -- function, but it returns \"./\" as its first argument, + -- so we pattern match on both for backward-compatibility. + startsWithDot (".":_) = True + startsWithDot _ = False + + checkFile :: IO (Maybe FilePath) + checkFile = do + exists <- doesFileExist path + pure $ + if exists + then Just path + else Nothing + + lookupPath :: IO (Maybe FilePath) + lookupPath = (pathDirs >>=) $ findMapM $ \dir -> do + let fullPath = dir path + isExecutable' <- isExecutable fullPath + pure $ + if isExecutable' + then Just fullPath + else Nothing + + pathDirs = + (map Text.unpack + . filter (not . Text.null) + . Text.split (== searchPathSeparator) + . Text.pack) + `fmap` getEnv "PATH" + + +isExecutable :: FilePath -> IO Bool +isExecutable f = (executable `fmap` getPermissions f) `catch` (\(_ :: IOError) -> return False) + + +-- | A monadic @findMap@, taken from the @MissingM@ package +findMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +findMapM _ [] = return Nothing +findMapM f (x:xs) = do + mb <- f x + if (isJust mb) + then return mb + else findMapM f xs