diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,11 @@ ## Unreleased +## 0.0.6.2 - 2026-06-25 + +- [#25](https://github.com/parsonsmatt/hotel-california/pull/25) + - Support `hs-optenelemetry` sdk 1.0 + ## 0.0.6.1 - 2025-03-07 - [#21](https://github.com/parsonsmatt/hotel-california/pull/21) 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.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: hotel-california -version: 0.0.6.1 +version: 0.0.6.2 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 diff --git a/src/HotelCalifornia/Exec.hs b/src/HotelCalifornia/Exec.hs --- a/src/HotelCalifornia/Exec.hs +++ b/src/HotelCalifornia/Exec.hs @@ -2,25 +2,25 @@ -- 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 Control.Exception qualified as Exception +import Data.Char qualified as Char import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as Text +import Data.HashMap.Strict qualified as HashMap +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NEL +import Data.Maybe (fromMaybe) import Data.Text (Text) +import Data.Text qualified as Text import HotelCalifornia.Tracing import HotelCalifornia.Tracing.TraceParent -import qualified OpenTelemetry.Trace.Core as Otel -import OpenTelemetry.Trace (Attribute(..), PrimitiveAttribute(..)) +import HotelCalifornia.Which (which) +import OpenTelemetry.Trace (Attribute (..), PrimitiveAttribute (..)) +import OpenTelemetry.Trace.Core qualified as Otel import Options.Applicative hiding (command) import System.Environment (getEnvironment) import System.Exit -import qualified System.Posix.Escape.Unicode as Escape +import System.Posix.Escape.Unicode qualified as Escape import System.Process.Typed -import HotelCalifornia.Which (which) data Subprocess = Proc (NonEmpty String) | Shell String @@ -51,7 +51,9 @@ "unset" -> Right SpanUnset "ok" -> Right SpanOk "error" -> Right SpanError - _ -> Left $ mconcat ["Expected one of `unset`, `ok`, or `error` for SPAN_STATUS. Got: ", s] + _ -> + Left $ + mconcat ["Expected one of `unset`, `ok`, or `error` for SPAN_STATUS. Got: ", s] parseProc :: Parser (NonEmpty String) parseProc = do @@ -61,10 +63,11 @@ parseShell :: Parser String parseShell = - option str - ( metavar "SCRIPT" - <> long "shell" - <> help "Run an arbitrary shell script instead of running an executable command" + option + str + ( metavar "SCRIPT" + <> long "shell" + <> help "Run an arbitrary shell script instead of running an executable command" ) parseSubprocess :: Parser Subprocess @@ -73,77 +76,94 @@ -- | 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 + 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') + 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 - option str $ mconcat - [ metavar "SPAN_NAME" - , long "span-name" - , short 's' - , help "The name of the span that the program reports. By default, this is the script you pass in." - ] + option str $ + mconcat + [ metavar "SPAN_NAME" + , long "span-name" + , 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 - ] + 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." - ]) + 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{..} -makeInitialAttributes :: Subprocess -> HashMap Text Attribute -> IO (HashMap Text Attribute) +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 + 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 runNoTracing :: Subprocess -> IO () runNoTracing subproc = do - let processConfig = commandToProcessConfig subproc + let + processConfig = commandToProcessConfig subproc userEnv <- getEnvironment exitCode <- runProcess $ setEnv userEnv processConfig exitWith exitCode runExecArgs :: ExecArgs -> IO () -runExecArgs ExecArgs {..} = do +runExecArgs ExecArgs{..} = do initialAttributes <- makeInitialAttributes execArgsSubprocess execArgsAttributes - let script = commandToString execArgsSubprocess + let + script = commandToString execArgsSubprocess spanName = fromMaybe (Text.pack script) execArgsSpanName - spanArguments = defaultSpanArguments { Otel.attributes = initialAttributes } + spanArguments = defaultSpanArguments{Otel.attributes = initialAttributes} inSpanWith' spanName spanArguments \span' -> do newEnv <- spanContextToEnvironment span' fullEnv <- mappend newEnv <$> getEnvironment - let processConfig = commandToProcessConfig execArgsSubprocess + let + processConfig = commandToProcessConfig execArgsSubprocess - let handleSigInt = + let + handleSigInt = \case Exception.UserInterrupt -> do Otel.addAttribute span' exitStatusName (-2 :: Int) -- SIGINT @@ -161,14 +181,20 @@ other -> Exception.throwIO other - mexitCode <- Exception.handle handleSigInt $ fmap Just $ runProcess $ setEnv fullEnv processConfig + mexitCode <- + Exception.handle handleSigInt $ + fmap Just $ + runProcess $ + setEnv fullEnv processConfig case mexitCode of Just exitCode -> do - Otel.addAttribute span' exitStatusName + Otel.addAttribute + span' + exitStatusName case exitCode of - ExitSuccess -> 0 - ExitFailure status -> status + ExitSuccess -> 0 + ExitFailure status -> status case exitCode of ExitSuccess -> pure () ExitFailure _ -> exitWith exitCode diff --git a/src/HotelCalifornia/Tracing.hs b/src/HotelCalifornia/Tracing.hs --- a/src/HotelCalifornia/Tracing.hs +++ b/src/HotelCalifornia/Tracing.hs @@ -1,27 +1,29 @@ +{-# LANGUAGE CPP #-} + module HotelCalifornia.Tracing ( module HotelCalifornia.Tracing , defaultSpanArguments ) where import Control.Monad -import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Char8 qualified as BS8 import Data.Text (Text) import Data.Time import HotelCalifornia.Tracing.TraceParent import OpenTelemetry.Context as Context hiding (lookup) import OpenTelemetry.Context.ThreadLocal (attachContext) import OpenTelemetry.Trace hiding - ( SpanKind(..) - , SpanStatus(..) - , addAttribute - , addAttributes - , createSpan - , inSpan - , inSpan' - , inSpan'' - ) -import qualified OpenTelemetry.Trace as Trace -import qualified OpenTelemetry.Vendor.Honeycomb as Honeycomb + ( SpanKind (..) + , SpanStatus (..) + , addAttribute + , addAttributes + , createSpan + , inSpan + , inSpan' + , inSpan'' + ) +import OpenTelemetry.Trace qualified as Trace +import OpenTelemetry.Vendor.Honeycomb qualified as Honeycomb import UnliftIO -- | Initialize the global tracing provider for the application and run an action @@ -29,30 +31,33 @@ -- up the provider afterwards. -- -- This also sets up an empty context (creating a new trace ID). -withGlobalTracing :: MonadUnliftIO m => (Maybe Honeycomb.HoneycombTarget -> m a) -> m a +withGlobalTracing + :: (MonadUnliftIO m) => (Maybe Honeycomb.HoneycombTarget -> m a) -> m a withGlobalTracing act = do void $ attachContext Context.empty liftIO setParentSpanFromEnvironment - bracket (liftIO initializeGlobalTracerProvider) shutdownTracerProvider $ \_ -> do + withTracer $ \_ -> do -- note: this is not in a span since we don't have a root span yet so it -- would not wind up in the trace in a helpful way anyway mTarget <- - Honeycomb.getOrInitializeHoneycombTargetInContext initializationTimeout - `catch` \(e :: SomeException) -> do - -- we are too early in initialization to be able to use a normal logger, - -- but this needs to get out somehow. - -- - -- honeycomb links are not load-bearing, so we let them just not come - -- up if the API fails. - liftIO . BS8.hPutStrLn stderr $ "error setting up Honeycomb trace links: " <> (BS8.pack $ displayException e) - pure Nothing + Honeycomb.getOrInitializeHoneycombTargetInContext initializationTimeout + `catch` \(e :: SomeException) -> do + -- we are too early in initialization to be able to use a normal logger, + -- but this needs to get out somehow. + -- + -- honeycomb links are not load-bearing, so we let them just not come + -- up if the API fails. + liftIO . BS8.hPutStrLn stderr $ + "error setting up Honeycomb trace links: " <> (BS8.pack $ displayException e) + pure Nothing act mTarget where initializationTimeout = secondsToNominalDiffTime 1 -globalTracer :: MonadIO m => m Tracer -globalTracer = getGlobalTracerProvider >>= \tp -> pure $ makeTracer tp "hotel-california" tracerOptions +globalTracer :: (MonadIO m) => m Tracer +globalTracer = + getGlobalTracerProvider >>= \tp -> pure $ makeTracer tp "hotel-california" tracerOptions inSpan' :: (MonadUnliftIO m) => Text -> (Span -> m a) -> m a inSpan' spanName = @@ -62,7 +67,8 @@ inSpanWith spanName args action = inSpanWith' spanName args \_ -> action -inSpanWith' :: (MonadUnliftIO m) => Text -> SpanArguments -> (Span -> m a) -> m a +inSpanWith' + :: (MonadUnliftIO m) => Text -> SpanArguments -> (Span -> m a) -> m a inSpanWith' spanName args action = do tr <- globalTracer Trace.inSpan'' tr spanName args action @@ -70,3 +76,13 @@ inSpan :: (MonadUnliftIO m) => Text -> m a -> m a inSpan spanName = inSpanWith spanName defaultSpanArguments + +withTracer :: (MonadUnliftIO m) => (TracerProvider -> m a) -> m a +withTracer = + bracket (liftIO initializeGlobalTracerProvider) shutdown + where +#if MIN_VERSION_hs_opentelemetry_api(1,0,0) + shutdown tp = shutdownTracerProvider tp Nothing +#else + shutdown tp = shutdownTracerProvider tp +#endif diff --git a/src/HotelCalifornia/Which.hs b/src/HotelCalifornia/Which.hs --- a/src/HotelCalifornia/Which.hs +++ b/src/HotelCalifornia/Which.hs @@ -3,21 +3,30 @@ -- 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) +import Data.Text qualified as Text +import System.Directory + ( doesFileExist + , executable + , getPermissions + ) +import System.Environment (getEnv) +import System.FilePath + ( isAbsolute + , searchPathSeparator + , splitDirectories + , () + ) -- | 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 + if isAbsolute path || startsWithDot splitOnDirs + then checkFile + else lookupPath where splitOnDirs = splitDirectories path @@ -39,7 +48,7 @@ -- \"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 ("." : _) = True startsWithDot _ = False checkFile :: IO (Maybe FilePath) @@ -47,35 +56,36 @@ exists <- doesFileExist path pure $ if exists - then Just path - else Nothing + then Just path + else Nothing lookupPath :: IO (Maybe FilePath) lookupPath = (pathDirs >>=) $ findMapM $ \dir -> do - let fullPath = dir path + let + fullPath = dir path isExecutable' <- isExecutable fullPath pure $ if isExecutable' - then Just fullPath - else Nothing + then Just fullPath + else Nothing pathDirs = - (map Text.unpack - . filter (not . Text.null) - . Text.split (== searchPathSeparator) - . Text.pack) - `fmap` getEnv "PATH" - + ( 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) - +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 :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b) findMapM _ [] = return Nothing -findMapM f (x:xs) = do +findMapM f (x : xs) = do mb <- f x if (isJust mb) - then return mb - else findMapM f xs + then return mb + else findMapM f xs