diff --git a/api/hs-opentelemetry-api.cabal b/api/hs-opentelemetry-api.cabal index 65d71da9..76cb67fe 100644 --- a/api/hs-opentelemetry-api.cabal +++ b/api/hs-opentelemetry-api.cabal @@ -52,7 +52,7 @@ library OpenTelemetry.Resource.Service OpenTelemetry.Resource.Telemetry OpenTelemetry.Resource.Webengine - OpenTelemetry.SemConvStabilityOptIn + OpenTelemetry.SemanticsConfig OpenTelemetry.Trace.Core OpenTelemetry.Trace.Id OpenTelemetry.Trace.Id.Generator @@ -84,6 +84,7 @@ library , http-types , memory , mtl + , safe-exceptions , template-haskell , text , thread-utils-context ==0.3.* @@ -126,6 +127,7 @@ test-suite hs-opentelemetry-api-test , http-types , memory , mtl + , safe-exceptions , template-haskell , text , thread-utils-context ==0.3.* diff --git a/api/package.yaml b/api/package.yaml index 77dce81d..980cf238 100644 --- a/api/package.yaml +++ b/api/package.yaml @@ -44,6 +44,7 @@ dependencies: - ghc-prim - unliftio-core - vector-builder +- safe-exceptions library: source-dirs: src diff --git a/api/src/OpenTelemetry/SemConvStabilityOptIn.hs b/api/src/OpenTelemetry/SemConvStabilityOptIn.hs deleted file mode 100644 index b865f01c..00000000 --- a/api/src/OpenTelemetry/SemConvStabilityOptIn.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module OpenTelemetry.SemConvStabilityOptIn ( - getSemConvStabilityOptIn, - SemConvStabilityOptIn (Stable, Both, Old), -) where - -import qualified Data.Text as T -import System.Environment (lookupEnv) - - -data SemConvStabilityOptIn = Stable | Both | Old deriving (Show, Eq) - - -parseSemConvStabilityOptIn :: Maybe String -> SemConvStabilityOptIn -parseSemConvStabilityOptIn Nothing = Old -parseSemConvStabilityOptIn (Just env) - | "http/dup" `elem` envs = Both - | "http" `elem` envs = Stable - | otherwise = Old - where - envs = fmap T.strip . T.splitOn "," . T.pack $ env - - -getSemConvStabilityOptIn :: IO SemConvStabilityOptIn -getSemConvStabilityOptIn = parseSemConvStabilityOptIn <$> lookupEnv "OTEL_SEMCONV_STABILITY_OPT_IN" diff --git a/api/src/OpenTelemetry/SemanticsConfig.hs b/api/src/OpenTelemetry/SemanticsConfig.hs new file mode 100644 index 00000000..58860abd --- /dev/null +++ b/api/src/OpenTelemetry/SemanticsConfig.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module OpenTelemetry.SemanticsConfig ( + SemanticsOptions, + useStableHttpSemantics, + useOldHttpSemantics, + getSemanticsOptions, + getSemanticsOptions', +) where + +import Control.Exception.Safe (throwIO, tryAny) +import qualified Data.HashSet as HS +import Data.Hashable (Hashable) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import GHC.Generics (Generic) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) + + +data SemanticsOption + = HttpStableSemantics + | HttpOldAndStableSemantics + deriving (Show, Eq, Generic) + + +instance Hashable SemanticsOption + + +newtype SemanticsOptions = SemanticsOptions (HS.HashSet SemanticsOption) + + +semanticsOptionIsSet :: SemanticsOption -> SemanticsOptions -> Bool +semanticsOptionIsSet option (SemanticsOptions options) = HS.member option options + + +useStableHttpSemantics :: SemanticsOptions -> Bool +useStableHttpSemantics options = + semanticsOptionIsSet HttpStableSemantics options + || semanticsOptionIsSet HttpOldAndStableSemantics options + + +useOldHttpSemantics :: SemanticsOptions -> Bool +useOldHttpSemantics options = + semanticsOptionIsSet HttpOldAndStableSemantics options + || not (semanticsOptionIsSet HttpStableSemantics options) + + +parseSemanticsOption :: T.Text -> Maybe SemanticsOption +parseSemanticsOption "http/dup" = Just HttpOldAndStableSemantics +parseSemanticsOption "http" = Just HttpStableSemantics +parseSemanticsOption _ = Nothing + + +parseSemanticsOptions :: Maybe String -> SemanticsOptions +parseSemanticsOptions Nothing = SemanticsOptions HS.empty +parseSemanticsOptions (Just env) = SemanticsOptions $ HS.fromList $ mapMaybe parseSemanticsOption envs + where + envs = fmap T.strip . T.splitOn "," . T.pack $ env + + +getSemanticsOptions' :: IO SemanticsOptions +getSemanticsOptions' = parseSemanticsOptions <$> lookupEnv "OTEL_SEMCONV_STABILITY_OPT_IN" + + +{- | Create a new memoized IO action using an 'IORef' under the surface. Note that +the action may be run in multiple threads simultaneously, so this may not be +thread safe (depending on the underlying action). For the sake of reading an environment +variable and parsing some stuff, we don't have to be concerned about thread-safety. +-} +memoize :: IO a -> IO (IO a) +memoize action = do + ref <- newIORef Nothing + pure $ do + mres <- readIORef ref + res <- case mres of + Just res -> pure res + Nothing -> do + res <- tryAny action + writeIORef ref $ Just res + pure res + either throwIO pure res + + +-- This uses the global IORef trick: +-- https://www.parsonsmatt.org/2021/04/21/global_ioref_in_template_haskell.html +getSemanticsOptions :: IO SemanticsOptions +getSemanticsOptions = unsafePerformIO $ memoize getSemanticsOptions +{-# NOINLINE getSemanticsOptions #-}