hotel-california 0.0.6.1 → 0.0.6.2
raw patch · 5 files changed
+168/−111 lines, 5 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ HotelCalifornia.Tracing: withTracer :: MonadUnliftIO m => (TracerProvider -> m a) -> m a
Files
- CHANGELOG.md +5/−0
- hotel-california.cabal +2/−2
- src/HotelCalifornia/Exec.hs +84/−58
- src/HotelCalifornia/Tracing.hs +42/−26
- src/HotelCalifornia/Which.hs +35/−25
CHANGELOG.md view
@@ -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)
hotel-california.cabal view
@@ -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 <https://github.com/parsonsmatt/hotel-california#readme> homepage: https://github.com/parsonsmatt/hotel-california#readme bug-reports: https://github.com/parsonsmatt/hotel-california/issues
src/HotelCalifornia/Exec.hs view
@@ -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
src/HotelCalifornia/Tracing.hs view
@@ -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
src/HotelCalifornia/Which.hs view
@@ -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