-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The exposition handle, the listener address reads, and the WAI application behind
"Ecluse.Runtime.Telemetry.Scrape", which documents the transport and re-exports the curated
surface. Importing this module opts out of that stability promise, the convention @text@ and
@bytestring@ use, so production code imports the public one.
-}
module Ecluse.Runtime.Telemetry.Scrape.Internal (
    -- * The collection handle
    MetricScrape (..),
    metricScrapeFor,
    scrapeSelected,

    -- * The dedicated listener
    ScrapeListener (..),
    scrapeListenerFrom,
    scrapeListenerWarnings,
    scrapeApplication,
    withScrapeListener,
) where

import Data.Vector (Vector)
import Data.Vector qualified as V
import Katip (LogEnv, Severity (ErrorS, InfoS, WarningS))
import Network.HTTP.Types (hContentType, status404)
import Network.Wai (Application, responseLBS)
import Network.Wai.Handler.Warp qualified as Warp
import System.Environment (getEnvironment)
import UnliftIO (catchAny)
import UnliftIO.Async (race, wait, withAsync)

import OpenTelemetry.Environment (MetricsExporterSelection (MetricsExporterPrometheus), lookupMetricsExporterSelection)
import OpenTelemetry.Exporter.Metric (ResourceMetricsExport)
import OpenTelemetry.Exporter.Prometheus.WAI (prometheusMiddleware)
import OpenTelemetry.MeterProvider (SdkMeterEnv, collectResourceMetrics)

import Ecluse.Core.Text (displayExceptionT)
import Ecluse.Runtime.Log (moduleLog)
import Ecluse.Runtime.Telemetry.Resolve (declaredEnv)

{- | One on-demand collection of the meter's current series. The substrate builds one only where
the operator asked for the scrape transport.
-}
newtype MetricScrape = MetricScrape
    { MetricScrape -> IO (Vector ResourceMetricsExport)
runMetricScrape :: IO (Vector ResourceMetricsExport)
    }

{- | Whether @OTEL_METRICS_EXPORTER@ names the Prometheus transport. It reads the SDK's own parse
of the variable, so the listener and the exporter the SDK resolves cannot disagree over one value.
-}
scrapeSelected :: IO Bool
scrapeSelected :: IO Bool
scrapeSelected = (MetricsExporterSelection -> Maybe MetricsExporterSelection
forall a. a -> Maybe a
Just MetricsExporterSelection
MetricsExporterPrometheus Maybe MetricsExporterSelection
-> Maybe MetricsExporterSelection -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe MetricsExporterSelection -> Bool)
-> IO (Maybe MetricsExporterSelection) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe MetricsExporterSelection)
lookupMetricsExporterSelection

{- | Build the scrape handle, or 'Nothing' when the transport stayed on OTLP push. Collecting
beside the periodic reader is safe only under cumulative temporality: delta would split the points.
-}
metricScrapeFor :: SdkMeterEnv -> IO (Maybe MetricScrape)
metricScrapeFor :: SdkMeterEnv -> IO (Maybe MetricScrape)
metricScrapeFor SdkMeterEnv
meterEnv = do
    selected <- IO Bool
scrapeSelected
    pure (if selected then Just (MetricScrape collect) else Nothing)
  where
    collect :: IO (Vector ResourceMetricsExport)
    collect :: IO (Vector ResourceMetricsExport)
collect = [ResourceMetricsExport] -> Vector ResourceMetricsExport
forall a. [a] -> Vector a
V.fromList ([ResourceMetricsExport] -> Vector ResourceMetricsExport)
-> IO [ResourceMetricsExport] -> IO (Vector ResourceMetricsExport)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SdkMeterEnv -> IO [ResourceMetricsExport]
forall (m :: * -> *).
MonadIO m =>
SdkMeterEnv -> m [ResourceMetricsExport]
collectResourceMetrics SdkMeterEnv
meterEnv

-- | Where the scrape listener binds.
data ScrapeListener = ScrapeListener
    { ScrapeListener -> Text
slHost :: Text
    -- ^ The bind address, loopback unless the operator widened it.
    , ScrapeListener -> Int
slPort :: Int
    -- ^ The TCP port, 9464 by the OpenTelemetry specification's default.
    }
    deriving stock (ScrapeListener -> ScrapeListener -> Bool
(ScrapeListener -> ScrapeListener -> Bool)
-> (ScrapeListener -> ScrapeListener -> Bool) -> Eq ScrapeListener
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScrapeListener -> ScrapeListener -> Bool
== :: ScrapeListener -> ScrapeListener -> Bool
$c/= :: ScrapeListener -> ScrapeListener -> Bool
/= :: ScrapeListener -> ScrapeListener -> Bool
Eq, Int -> ScrapeListener -> ShowS
[ScrapeListener] -> ShowS
ScrapeListener -> String
(Int -> ScrapeListener -> ShowS)
-> (ScrapeListener -> String)
-> ([ScrapeListener] -> ShowS)
-> Show ScrapeListener
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScrapeListener -> ShowS
showsPrec :: Int -> ScrapeListener -> ShowS
$cshow :: ScrapeListener -> String
show :: ScrapeListener -> String
$cshowList :: [ScrapeListener] -> ShowS
showList :: [ScrapeListener] -> ShowS
Show)

{- | Resolve the listener from an environment. The defaults reach no interface but the loopback,
so publishing the exposition any wider is an operator's deliberate act.
-}
scrapeListenerFrom :: [(String, String)] -> ScrapeListener
scrapeListenerFrom :: [(String, String)] -> ScrapeListener
scrapeListenerFrom [(String, String)]
environment =
    ScrapeListener
        { slHost :: Text
slHost = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
defaultScrapeHost (String -> [(String, String)] -> Maybe Text
declaredEnv String
hostVar [(String, String)]
environment)
        , slPort :: Int
slPort = case [(String, String)] -> PortSource
declaredPort [(String, String)]
environment of
            PortDeclared Int
port -> Int
port
            PortSource
PortAbsent -> Int
defaultScrapePort
            PortUnusable Text
_ -> Int
defaultScrapePort
        }

-- | The warnings this environment raises. 'withScrapeListener' surfaces them before it binds.
scrapeListenerWarnings :: [(String, String)] -> [Text]
scrapeListenerWarnings :: [(String, String)] -> [Text]
scrapeListenerWarnings [(String, String)]
environment = case [(String, String)] -> PortSource
declaredPort [(String, String)]
environment of
    PortUnusable Text
raw -> [Text -> Text
unusablePortMessage Text
raw]
    PortSource
PortAbsent -> []
    PortDeclared Int
_ -> []

-- What the operator's port variable amounts to. One reading feeds both the resolution and the
-- warning, so the two can never disagree about which values are usable.
data PortSource
    = PortAbsent
    | PortDeclared Int
    | PortUnusable Text

declaredPort :: [(String, String)] -> PortSource
declaredPort :: [(String, String)] -> PortSource
declaredPort [(String, String)]
environment = case String -> [(String, String)] -> Maybe Text
declaredEnv String
portVar [(String, String)]
environment of
    Maybe Text
Nothing -> PortSource
PortAbsent
    Just Text
raw -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
raw) of
        Just Int
port | Int -> Bool
isScrapeListenerPort Int
port -> Int -> PortSource
PortDeclared Int
port
        Maybe Int
_ -> Text -> PortSource
PortUnusable Text
raw

isScrapeListenerPort :: Int -> Bool
isScrapeListenerPort :: Int -> Bool
isScrapeListenerPort Int
port = Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| (Int
port Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
65535)

hostVar :: String
hostVar :: String
hostVar = String
"OTEL_EXPORTER_PROMETHEUS_HOST"

portVar :: String
portVar :: String
portVar = String
"OTEL_EXPORTER_PROMETHEUS_PORT"

defaultScrapeHost :: Text
defaultScrapeHost :: Text
defaultScrapeHost = Text
"localhost"

defaultScrapePort :: Int
defaultScrapePort :: Int
defaultScrapePort = Int
9464

unusablePortMessage :: Text -> Text
unusablePortMessage :: Text -> Text
unusablePortMessage Text
raw =
    String -> Text
forall a. ToText a => a -> Text
toText String
portVar
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a port number ("
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"). Serving the scrape exposition on "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
defaultScrapePort
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" instead."

{- | Answer @\/metrics@ with the Prometheus text exposition of the current series, and every other
path with a plain @404@. This is the whole surface of the dedicated listener.
-}
scrapeApplication :: MetricScrape -> Application
scrapeApplication :: MetricScrape -> Application
scrapeApplication MetricScrape
scrape = IO (Vector ResourceMetricsExport) -> Middleware
prometheusMiddleware (MetricScrape -> IO (Vector ResourceMetricsExport)
runMetricScrape MetricScrape
scrape) Application
unmatchedPath

-- The listener serves one path, so anything else gets a body with nothing in it to parse.
unmatchedPath :: Application
unmatchedPath :: Application
unmatchedPath Request
_request Response -> IO ResponseReceived
respond =
    Response -> IO ResponseReceived
respond (Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [(HeaderName
hContentType, ByteString
"text/plain; charset=utf-8")] ByteString
"Not Found\n")

{- | Run @act@ with the scrape listener alive when the transport selected one, and unchanged when
it did not. A listener that cannot bind is reported and abandoned, never a failed boot.
-}
withScrapeListener :: LogEnv -> Maybe MetricScrape -> IO a -> IO a
withScrapeListener :: forall a. LogEnv -> Maybe MetricScrape -> IO a -> IO a
withScrapeListener LogEnv
_ Maybe MetricScrape
Nothing IO a
act = IO a
act
withScrapeListener LogEnv
logEnv (Just MetricScrape
scrape) IO a
act = do
    environment <- IO [(String, String)]
getEnvironment
    traverse_ (scrapeLog logEnv WarningS) (scrapeListenerWarnings environment)
    bound <- newEmptyMVar
    withAsync (runScrapeListener logEnv (scrapeListenerFrom environment) scrape bound) $ \Async ()
started -> do
        -- Whichever lands first: the port is bound, or the attempt gave up and logged. Racing
        -- them is what keeps a bind failure from parking the caller on a signal never sent.
        _ <- IO () -> IO () -> IO (Either () ())
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async ()
started) (MVar () -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar ()
bound)
        act

runScrapeListener :: LogEnv -> ScrapeListener -> MetricScrape -> MVar () -> IO ()
runScrapeListener :: LogEnv -> ScrapeListener -> MetricScrape -> MVar () -> IO ()
runScrapeListener LogEnv
logEnv ScrapeListener
listener MetricScrape
scrape MVar ()
bound =
    Settings -> Application -> IO ()
Warp.runSettings Settings
settings (MetricScrape -> Application
scrapeApplication MetricScrape
scrape)
        IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (Severity -> Text -> IO ()
say Severity
ErrorS (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrapeListener -> SomeException -> Text
failedMessage ScrapeListener
listener)
  where
    settings :: Warp.Settings
    settings :: Settings
settings =
        Int -> Settings -> Settings
Warp.setPort (ScrapeListener -> Int
slPort ScrapeListener
listener)
            (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostPreference -> Settings -> Settings
Warp.setHost (String -> HostPreference
forall a. IsString a => String -> a
fromString (Text -> String
forall a. ToString a => a -> String
toString (ScrapeListener -> Text
slHost ScrapeListener
listener)))
            (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Settings -> Settings
Warp.setBeforeMainLoop (Severity -> Text -> IO ()
say Severity
InfoS (ScrapeListener -> Text
boundMessage ScrapeListener
listener) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar ()
bound ())
            (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
Warp.defaultSettings

    say :: Severity -> Text -> IO ()
    say :: Severity -> Text -> IO ()
say = LogEnv -> Severity -> Text -> IO ()
scrapeLog LogEnv
logEnv

-- The @module@ key names the public module, not this one, because operators filter on it.
scrapeLog :: LogEnv -> Severity -> Text -> IO ()
scrapeLog :: LogEnv -> Severity -> Text -> IO ()
scrapeLog LogEnv
logEnv = LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog LogEnv
logEnv Text
"Ecluse.Runtime.Telemetry.Scrape"

-- The bind line states what the exposition carries, because the posture is the operator's to hold.
boundMessage :: ScrapeListener -> Text
boundMessage :: ScrapeListener -> Text
boundMessage ScrapeListener
listener =
    Text
"prometheus scrape exposition listening on "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScrapeListener -> Text
address ScrapeListener
listener
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". It carries host, process, and cloud identity, so keep the port inside your network."

failedMessage :: ScrapeListener -> SomeException -> Text
failedMessage :: ScrapeListener -> SomeException -> Text
failedMessage ScrapeListener
listener SomeException
failure =
    Text
"prometheus scrape exposition could not listen on "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScrapeListener -> Text
address ScrapeListener
listener
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Serving continues without it: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptionT SomeException
failure

address :: ScrapeListener -> Text
address :: ScrapeListener -> Text
address ScrapeListener
listener = ScrapeListener -> Text
slHost ScrapeListener
listener Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (ScrapeListener -> Int
slPort ScrapeListener
listener)