Environment.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Effectful.OpenTelemetry.Protocol.Environment {-# WARNING in "x-unstable-interface" "This is an unstable interface." #-} where

import Control.Applicative ((<|>))
import Control.Exception (Exception (..))
import Data.Aeson.Types (Pair, Value (String))
import Data.Functor ((<&>))
import Data.List (intercalate)
import Data.List.Extra (splitOn, trim)
import Data.Maybe (fromMaybe)
import Data.String (IsString (fromString))
import Data.Text qualified as Text
import Effectful
import Effectful.Environment (Environment, lookupEnv)
import Effectful.Error.Static (Error, runErrorNoCallStackWith, throwError)
import Effectful.Exception (throwIO)
import Effectful.OpenTelemetry.Protocol.Attributes (Attributes)
import Effectful.OpenTelemetry.Protocol.Attributes qualified as Attributes
import Effectful.OpenTelemetry.Protocol.Exception
    ( SomeOTLPException (..)
    , otlpExceptionFromException
    , otlpExceptionToException
    )
import Effectful.OpenTelemetry.Protocol.Export (Request (..))
import Effectful.OpenTelemetry.Protocol.Export qualified as Export
import Effectful.OpenTelemetry.Protocol.GRPC qualified as GRPC
import Effectful.OpenTelemetry.Protocol.HTTP qualified as HTTP
import Effectful.OpenTelemetry.Protocol.Resource (Resource (Resource))
import Effectful.OpenTelemetry.Protocol.Transport
    ( Compression (..)
    , Encoding (..)
    , Protocol (..)
    , Transport (..)
    )
import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)
import Network.URI qualified as URI
import Numeric.Natural (Natural)
import Safe (readMay)
import Text.Read (readMaybe)
import Prelude

data OTLPConfig = OTLPConfig {variable :: String, value :: String}
    deriving stock (Show, Eq)

data ConfigError
    = ParseEnvConfigError OTLPConfig
    | InvalidPort String
    | InvalidTimeout String
    | UnknownProtocol String
    | UnknownExporter String
    | InvalidOTLPEndpointURI String
    | OTLPEndpointMissingAuthority URI
    | UnsupportedOTLPCompression String
    | InvalidResourceAttribute String
    deriving stock (Show, Eq)

instance Exception ConfigError where
    toException = otlpExceptionToException
    fromException = otlpExceptionFromException
    displayException (ParseEnvConfigError OTLPConfig{..}) =
        "Error parsing " <> variable <> ". Invalid value: " <> value
    displayException (InvalidPort port) = "Invalid port number: " <> port
    displayException (InvalidTimeout timeout) = "Invalid timeout: " <> timeout
    displayException (UnknownProtocol protocol) =
        "Unknown OTEL_EXPORTER_OTLP_PROTOCOL: " <> protocol
    displayException (UnknownExporter name) =
        "Unknown exporter in OTEL_*_EXPORTER: " <> name
    displayException (InvalidOTLPEndpointURI uri) =
        "Invalid OTLP endpoint URI: " <> uri
    displayException (OTLPEndpointMissingAuthority uri) =
        "OTLP endpoint missing authority: " <> show uri
    displayException (UnsupportedOTLPCompression compression) =
        "Unsupported OTLP compression: " <> compression
    displayException (InvalidResourceAttribute pair) =
        "Invalid OTEL_RESOURCE_ATTRIBUTES entry (expected key=value): " <> pair

isSdkDisabled :: (Environment :> es) => Eff es Bool
isSdkDisabled = lookupEnv "OTEL_SDK_DISABLED" <&> (== Just "true")

runConfigError :: Eff (Error ConfigError ': es) a -> Eff es a
runConfigError = runErrorNoCallStackWith (throwIO . SomeOTLPException @ConfigError)

-- | The name of the signal-specific @OTEL_EXPORTER_OTLP_\<SIGNAL\>_*@ variable
-- for signal @a@.
signalEnvName :: forall a. (Export.Request a) => String -> String
signalEnvName suffix = intercalate "_" [exporterEnvPrefix, transportSignalEnvName @a, suffix]

-- | The name of the signal-agnostic @OTEL_EXPORTER_OTLP_*@ variable.
globalEnvName :: String -> String
globalEnvName suffix = intercalate "_" [exporterEnvPrefix, suffix]

exporterEnvPrefix :: String
exporterEnvPrefix = "OTEL_EXPORTER_OTLP"

-- | Read an @OTEL_EXPORTER_OTLP_*@ setting for signal @a@, preferring the
-- signal-specific variable over the global one.
lookupSignalOrGlobal
    :: forall a es
     . (Export.Request a, Environment :> es)
    => String
    -> Eff es (Maybe String)
lookupSignalOrGlobal suffix = do
    signal <- lookupEnv $ signalEnvName @a suffix
    global <- lookupEnv $ globalEnvName suffix
    pure $ signal <|> global

-- | The configured 'Compression' for signal @a@, from
-- @OTEL_EXPORTER_OTLP_<SIGNAL>_COMPRESSION@ or @OTEL_EXPORTER_OTLP_COMPRESSION@.
-- Defaults to 'NoCompression'.
lookupCompression
    :: forall a es
     . (Export.Request a, Environment :> es, Error ConfigError :> es)
    => Eff es Compression
lookupCompression =
    lookupSignalOrGlobal @a "COMPRESSION" >>= \case
        Nothing -> pure NoCompression
        Just name -> maybe (throwError $ UnsupportedOTLPCompression name) pure $ readMaybe name

-- | Detect a 'Resource' from the standard OpenTelemetry environment variables:
-- @OTEL_SERVICE_NAME@ and @OTEL_RESOURCE_ATTRIBUTES@.
-- @OTEL_SERVICE_NAME@ takes precedence over a @service.name@ set via @OTEL_RESOURCE_ATTRIBUTES@.
--
-- See <https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#general-sdk-configuration the OpenTelemetry spec>.
detectResource :: (Environment :> es, Error ConfigError :> es) => Eff es Resource
detectResource = do
    fromAttributes <-
        lookupEnv "OTEL_RESOURCE_ATTRIBUTES"
            >>= \case
                Just (trim -> s) | not (null s) -> either throwError (pure . Resource) $ parseResourceAttributes s
                _ -> pure mempty
    fromServiceName <-
        lookupEnv "OTEL_SERVICE_NAME"
            <&> \case
                Just (trim -> s) | not (null s) -> Resource $ Attributes.fromList [("service.name", String $ Text.pack s)]
                _ -> mempty
    pure $ fromServiceName <> fromAttributes
  where
    parseResourceAttributes :: String -> Either ConfigError Attributes
    parseResourceAttributes =
        fmap Attributes.fromList
            . mapM parsePair
            . filter (not . null)
            . map trim
            . splitOn ","
    parsePair :: String -> Either ConfigError Pair
    parsePair s = case break (== '=') s of
        (key, '=' : value) -> Right (decode key, decode value)
        _ -> Left $ InvalidResourceAttribute s
    decode :: (IsString s) => String -> s
    decode = fromString . URI.unEscapeString . trim

lookupTransport
    :: forall a es
     . ( Export.Request a
       , Error ConfigError :> es
       , Environment :> es
       )
    => Eff es Transport
lookupTransport = do
    protocol <- lookupProtocol
    compression <- lookupCompression @a
    timeoutStr <- lookupWithFallback "TIMEOUT" "30000"
    timeoutMs <- maybe (throwError $ InvalidTimeout timeoutStr) pure $ readMay timeoutStr
    pure Transport{..}
  where
    lookupProtocol =
        lookupWithFallback "PROTOCOL" "http/protobuf" >>= \case
            "http/protobuf" -> do
                HTTP Proto <$> lookupHttpUri
            "http/json" -> do
                HTTP Json <$> lookupHttpUri
            "grpc" -> do
                uri <- lookupGrpcUri
                (host, port) <- case uri of
                    URI{uriAuthority = Just URIAuth{uriRegName, ..}}
                        | ':' : (readMay -> Just port) <- uriPort -> pure (uriRegName, port)
                        | otherwise -> throwError $ InvalidPort uriPort
                    _ -> throwError $ OTLPEndpointMissingAuthority uri
                pure . GRPC host port $ exportGrpcRPC @a
            other -> throwError $ UnknownProtocol other

    lookupEndpoint :: Eff es (Maybe URI, Maybe URI)
    lookupEndpoint = do
        signal <- parseOrFail =<< lookupEnv (signalEnvName @a "ENDPOINT")
        global <- parseOrFail =<< lookupEnv (globalEnvName "ENDPOINT")
        pure (signal, global)

    lookupHttpUri :: Eff es URI
    lookupHttpUri = do
        lookupEndpoint <&> \case
            (Just endpoint, _) -> rootPathIfEmpty endpoint
            (_, Just endpoint) -> appendExportPath @a endpoint
            _ -> appendExportPath @a HTTP.defaultEndpoint

    lookupGrpcUri :: Eff es URI
    lookupGrpcUri = do
        lookupEndpoint <&> \case
            (Just endpoint, _) -> endpoint
            (_, Just endpoint) -> endpoint
            _ -> GRPC.defaultEndpoint

    lookupWithFallback :: String -> String -> Eff es String
    lookupWithFallback suffix fallback =
        fromMaybe fallback <$> lookupSignalOrGlobal @a suffix

    rootPathIfEmpty :: URI -> URI
    rootPathIfEmpty uri
        | null (uriPath uri) = uri{uriPath = "/"}
        | otherwise = uri

    parseOrFail :: Maybe String -> Eff es (Maybe URI)
    parseOrFail Nothing = pure Nothing
    parseOrFail (Just s) = maybe (throwError $ InvalidOTLPEndpointURI s) (pure . pure) $ parseAbsoluteURI s

lookupExportConfig
    :: forall a es
     . ( Export.Request a
       , Environment :> es
       , Error ConfigError :> es
       )
    => Export.Config
    -> Eff es Export.Config
lookupExportConfig Export.Config{..} = do
    batch <-
        maybe (pure Nothing) (fmap Just . uncurry lookupBatchConfig) $
            (,) <$> batchEnvPrefix @a <*> batch
    exportTimeoutMs <- envNatural "EXPORT_TIMEOUT" exportTimeoutMs
    pure Export.Config{..}
  where
    envNatural :: String -> Natural -> Eff es Natural
    envNatural name fallback = lookupEnv variable >>= maybe (pure fallback) parse
      where
        variable = intercalate "_" ["OTEL", exportSignalEnvName @a, name]
        parse value = maybe (throwError $ ParseEnvConfigError OTLPConfig{..}) pure $ readMay value

    lookupBatchConfig :: String -> Export.BatchConfig -> Eff es Export.BatchConfig
    lookupBatchConfig batchEnvPrefix Export.BatchConfig{..} = do
        maxQueueSize <- envNatural "MAX_QUEUE_SIZE" maxQueueSize
        scheduledDelayMs <- envNatural "SCHEDULE_DELAY" scheduledDelayMs
        maxBatchSize <- envNatural "MAX_EXPORT_BATCH_SIZE" maxBatchSize
        pure Export.BatchConfig{..}
      where
        envNatural :: String -> Natural -> Eff es Natural
        envNatural name fallback = lookupEnv variable >>= maybe (pure fallback) parse
          where
            variable = intercalate "_" ["OTEL", batchEnvPrefix, name]
            parse value = maybe (throwError $ ParseEnvConfigError OTLPConfig{..}) pure $ readMay value