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

{- | Operator diagnostics for metadata failures, dropped entries, and integrity divergence.
Access-refusal logs contain no upstream body, headers, or credential.

The bad-upstream warnings carry 'pipelineInternalModule' as their @module@ filter key and the other
payload-bearing lines carry 'pipelineModule', both held stable as values rather than source module
paths, so an operator's saved filter keeps matching.
-}
module Ecluse.Core.Server.Pipeline.Diagnostics (
    -- * Metadata-read failures
    logMetadataFailure,
    logDecodeFailure,
    logNameMismatch,
    logUpstreamUnformable,
    logUpstreamUnreachable,

    -- * Dropped entries and divergence
    logInvalidEntries,
    warnDivergences,
) where

import Data.Aeson (Value)
import Data.Aeson.Text (encodeToLazyText)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Katip (KatipContext, Severity (ErrorS, WarningS), SimpleLogPayload, katipAddContext, logFM, ls, sl)

import Ecluse.Core.Fault (TransportFault (tfCause, tfDetail))
import Ecluse.Core.Fault.Http (isRetryableStatusCode)

import Ecluse.Core.Package (
    HashAlg,
    InvalidEntry (invalidKey, invalidKind, invalidReason, invalidValue),
    PackageName,
    dropCountsByKind,
    renderHashAlg,
    renderInvalidEntryKind,
    renderPackageName,
 )
import Ecluse.Core.Package.Merge (
    Divergence (divLosing, divVersion, divWinning),
    IntegrityFingerprint,
    MergePlan (mpDivergences),
    integrityHashes,
 )
import Ecluse.Core.Registry (
    FetchFault (FetchBoundExceeded, FetchTransport, FetchUrlUnformable),
    UrlFormationError,
    renderUrlFormationError,
 )
import Ecluse.Core.Registry.Metadata (
    MetadataError (MetadataAbsent, MetadataAuthorisationFailure, MetadataBoundExceeded, MetadataFetch, MetadataHttpFailure, MetadataNameMismatch, MetadataUndecodable),
 )
import Ecluse.Core.Security (
    BodyLimit (..),
    LimitError (BodyTooLarge, TooDeeplyNested, TooManyArtifacts, TooManyVersions),
    authorityLabel,
    bodyLimitBytes,
 )
import Ecluse.Core.Server.Pipeline.Internal (pipelineInternalModule)
import Ecluse.Core.Telemetry.Record (MetricsPort (..))

-- | Log once per real fetch, inside the single-flight leader's request context.
logMetadataFailure :: (KatipContext m) => PackageName -> Text -> MetadataError -> m ()
logMetadataFailure :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> MetadataError -> m ()
logMetadataFailure PackageName
name Text
baseUrl = \case
    MetadataError
MetadataAbsent -> PackageName -> Text -> Int -> Text -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> Int -> Text -> m ()
logHttpFailure PackageName
name Text
baseUrl Int
404 Text
"the upstream has no metadata for the requested package"
    MetadataHttpFailure Int
code -> PackageName -> Text -> Int -> Text -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> Int -> Text -> m ()
logHttpFailure PackageName
name Text
baseUrl Int
code Text
"the upstream refused the metadata read"
    MetadataAuthorisationFailure Int
_ -> Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS LogStr
"the upstream refused metadata access"
    MetadataBoundExceeded LimitError
err -> PackageName -> LimitError -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> LimitError -> m ()
logBreach PackageName
name LimitError
err
    MetadataError
MetadataUndecodable -> PackageName -> m ()
forall (m :: * -> *). KatipContext m => PackageName -> m ()
logDecodeFailure PackageName
name
    MetadataNameMismatch Text
reported -> PackageName -> Text -> Text -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> Text -> m ()
logNameMismatch PackageName
name Text
baseUrl Text
reported
    MetadataFetch (FetchBoundExceeded LimitError
err) -> PackageName -> LimitError -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> LimitError -> m ()
logBreach PackageName
name LimitError
err
    MetadataFetch (FetchUrlUnformable UrlFormationError
urlErr) -> PackageName -> Text -> UrlFormationError -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> UrlFormationError -> m ()
logUpstreamUnformable PackageName
name Text
baseUrl UrlFormationError
urlErr
    MetadataFetch (FetchTransport TransportFault
fault) -> PackageName -> Text -> TransportFault -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> TransportFault -> m ()
logUpstreamUnreachable PackageName
name Text
baseUrl TransportFault
fault

logHttpFailure :: (KatipContext m) => PackageName -> Text -> Int -> Text -> m ()
logHttpFailure :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> Int -> Text -> m ()
logHttpFailure PackageName
name Text
baseUrl Int
code Text
message =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
severity (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message))
  where
    severity :: Severity
severity = if Int -> Bool
isRetryableStatusCode Int
code then Severity
ErrorS else Severity
WarningS
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"upstream" (Text -> Text
authorityLabel Text
baseUrl)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"status" Int
code

logBreach :: (KatipContext m) => PackageName -> LimitError -> m ()
logBreach :: forall (m :: * -> *).
KatipContext m =>
PackageName -> LimitError -> m ()
logBreach PackageName
name LimitError
err =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"bound" Text
boundName
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"observed" Text
observed
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"cap" Text
cap

    message :: Text
    message :: Text
message = Text
"refused an upstream metadata document: it exceeded the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
boundName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" response bound (observed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
observed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", cap " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cap Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

    boundName :: Text
    observed :: Text
    cap :: Text
    (Text
boundName, Text
observed, Text
cap) = case LimitError
err of
        BodyTooLarge BodyLimit
bound ->
            let c :: Int
c = BodyLimit -> Int
bodyLimitBytes BodyLimit
bound
                role :: Text
role = case BodyLimit
bound of
                    MetadataBodyLimit Int
_ -> Text
"metadata-body-size"
                    PublishRequestBodyLimit Int
_ -> Text
"publish-request-body-size"
                    MirrorArtifactBodyLimit Int
_ -> Text
"mirror-artifact-body-size"
             in (Text
role, Text
"over " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes", Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes")
        TooManyVersions Int
seen Int
c -> (Text
"version-count", Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
seen, Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c)
        TooManyArtifacts Int
seen Int
c -> (Text
"artifact-count", Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
seen, Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c)
        TooDeeplyNested Int
c -> (Text
"nesting-depth", Text
"over " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" levels", Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" levels")

-- The fields every bad-upstream warning carries, before the caller's own. The response-bound
-- guards leave these conditions silent, so an operator would otherwise see nothing at all.
warnUpstream :: (KatipContext m) => PackageName -> SimpleLogPayload -> Text -> m ()
warnUpstream :: forall (m :: * -> *).
KatipContext m =>
PackageName -> SimpleLogPayload -> Text -> m ()
warnUpstream PackageName
name SimpleLogPayload
extra Text
message =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext (SimpleLogPayload
prefix SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> SimpleLogPayload
extra) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    prefix :: SimpleLogPayload
prefix = Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineInternalModule SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)

-- | Warn that an upstream body did not decode into a usable packument.
logDecodeFailure :: (KatipContext m) => PackageName -> m ()
logDecodeFailure :: forall (m :: * -> *). KatipContext m => PackageName -> m ()
logDecodeFailure PackageName
name =
    PackageName -> SimpleLogPayload -> Text -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> SimpleLogPayload -> Text -> m ()
warnUpstream PackageName
name SimpleLogPayload
forall a. Monoid a => a
mempty Text
"refused an upstream metadata document: it did not decode into a usable packument"

{- | Warn that an origin's packument self-reported a name for a different package, so an
operator can tell a misconfigured or hostile upstream from an ordinary outage.
-}
logNameMismatch :: (KatipContext m) => PackageName -> Text -> Text -> m ()
logNameMismatch :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> Text -> m ()
logNameMismatch PackageName
requested Text
origin Text
reported =
    PackageName -> SimpleLogPayload -> Text -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> SimpleLogPayload -> Text -> m ()
warnUpstream
        PackageName
requested
        (Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"origin" (Text -> Text
authorityLabel Text
origin) SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"upstreamName" Text
reported)
        Text
"dropped an upstream contribution: its packument self-reported a name for a different package"

{- | Warn that this origin's configured base URL could not be formed into a request, so an
operator sees a misconfigured mount rather than an upstream that merely appears unreachable.
-}
logUpstreamUnformable :: (KatipContext m) => PackageName -> Text -> UrlFormationError -> m ()
logUpstreamUnformable :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> UrlFormationError -> m ()
logUpstreamUnformable PackageName
name Text
origin UrlFormationError
urlErr =
    PackageName -> SimpleLogPayload -> Text -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> SimpleLogPayload -> Text -> m ()
warnUpstream
        PackageName
name
        (Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"origin" (Text -> Text
authorityLabel Text
origin) SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"urlError" (UrlFormationError -> Text
renderUrlFormationError UrlFormationError
urlErr))
        Text
"refused an upstream metadata fetch: the configured base URL could not be formed into a request"

{- | Warn that the transport failed before a usable body returned, so an operator can tell an
outage from a decode failure or a misconfigured mount.
-}
logUpstreamUnreachable :: (KatipContext m) => PackageName -> Text -> TransportFault -> m ()
logUpstreamUnreachable :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> TransportFault -> m ()
logUpstreamUnreachable PackageName
name Text
origin TransportFault
fault =
    PackageName -> SimpleLogPayload -> Text -> m ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> SimpleLogPayload -> Text -> m ()
warnUpstream
        PackageName
name
        ( Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"origin" (Text -> Text
authorityLabel Text
origin)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"transportCause" (TransportCause -> Text
forall b a. (Show a, IsString b) => a -> b
show (TransportFault -> TransportCause
tfCause TransportFault
fault) :: Text)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"transportDetail" (TransportFault -> Text
tfDetail TransportFault
fault)
        )
        Text
"an upstream metadata fetch could not reach the origin; its contribution degrades this request"

-- | The malformed packument entries the projection dropped rather than failing the whole document.
logInvalidEntries :: (KatipContext m) => PackageName -> Text -> [InvalidEntry] -> m ()
logInvalidEntries :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> [InvalidEntry] -> m ()
logInvalidEntries PackageName
name Text
baseUrl [InvalidEntry]
entries =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"upstream" (Text -> Text
authorityLabel Text
baseUrl)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Map Text Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"droppedByKind" ([InvalidEntry] -> Map Text Int
dropCountsByKind [InvalidEntry]
entries)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"droppedEntries" ((InvalidEntry -> Text) -> [InvalidEntry] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map InvalidEntry -> Text
renderDroppedEntry (Int -> [InvalidEntry] -> [InvalidEntry]
forall a. Int -> [a] -> [a]
take Int
maxRenderedDrops [InvalidEntry]
entries))

    entriesLen :: Int
    entriesLen :: Int
entriesLen = [InvalidEntry] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InvalidEntry]
entries

    message :: Text
    message :: Text
message =
        Text
"dropped " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
entriesLen Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" malformed entr" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
plural Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from an upstream packument (the rest is served)"
    plural :: Text
plural = if Int
entriesLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"y" else Text
"ies"

renderDroppedEntry :: InvalidEntry -> Text
renderDroppedEntry :: InvalidEntry -> Text
renderDroppedEntry InvalidEntry
e =
    InvalidEntryKind -> Text
renderInvalidEntryKind (InvalidEntry -> InvalidEntryKind
invalidKind InvalidEntry
e)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> InvalidEntry -> Text
invalidKey InvalidEntry
e
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
truncatedValue (InvalidEntry -> Value
invalidValue InvalidEntry
e)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> InvalidEntry -> Text
invalidReason InvalidEntry
e
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- Only 'maxRenderedValueChars' characters are ever forced, so a huge value never balloons
-- the log line.
truncatedValue :: Value -> Text
truncatedValue :: Value -> Text
truncatedValue Value
v =
    let rendered :: Text
rendered = LazyText -> Text
TL.toStrict (Int64 -> LazyText -> LazyText
TL.take (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxRenderedValueChars Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) (Value -> LazyText
forall a. ToJSON a => a -> LazyText
encodeToLazyText Value
v))
     in if Text -> Int -> Ordering
T.compareLength Text
rendered Int
maxRenderedValueChars Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
            then Int -> Text -> Text
T.take Int
maxRenderedValueChars Text
rendered Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…"
            else Text
rendered

-- How many dropped entries the log renders in full, and how many characters of each raw value, so
-- a flood of drops or one huge value cannot bloat a log line. The per-kind counts stay complete.
maxRenderedDrops :: Int
maxRenderedDrops :: Int
maxRenderedDrops = Int
20

maxRenderedValueChars :: Int
maxRenderedValueChars :: Int
maxRenderedValueChars = Int
200

-- | Warn and increment the divergence metric when shared digests disagree across origins.
warnDivergences :: (KatipContext m) => MetricsPort -> PackageName -> MergePlan -> m ()
warnDivergences :: forall (m :: * -> *).
KatipContext m =>
MetricsPort -> PackageName -> MergePlan -> m ()
warnDivergences MetricsPort
metrics PackageName
name MergePlan
plan =
    case Set Divergence -> [Divergence]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (MergePlan -> Set Divergence
mpDivergences MergePlan
plan) of
        [] -> m ()
forall (f :: * -> *). Applicative f => f ()
pass
        [Divergence]
divs -> do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Divergence] -> (Divergence -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Divergence]
divs (IO () -> Divergence -> IO ()
forall a b. a -> b -> a
const (MetricsPort -> IO ()
mpMergeDivergence MetricsPort
metrics)))
            SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext ([Divergence] -> SimpleLogPayload
payload [Divergence]
divs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls ([Divergence] -> Text
message [Divergence]
divs))
  where
    payload :: [Divergence] -> SimpleLogPayload
payload [Divergence]
divs =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"versions" (Text -> [Text] -> Text
T.intercalate Text
"," ((Divergence -> Text) -> [Divergence] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Divergence -> Text
divVersion [Divergence]
divs))
    message :: [Divergence] -> Text
message [Divergence]
divs =
        Text
"cross-upstream integrity divergence: the trusted copy of "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is served, but a public copy contradicts it on a shared integrity algorithm for "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show ([Divergence] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Divergence]
divs)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" version(s): "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"; " ((Divergence -> Text) -> [Divergence] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Divergence -> Text
renderDivergence [Divergence]
divs)

renderDivergence :: Divergence -> Text
renderDivergence :: Divergence -> Text
renderDivergence Divergence
d =
    Divergence -> Text
divVersion Divergence
d
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (trusted "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IntegrityFingerprint -> Text
renderFingerprint (Divergence -> IntegrityFingerprint
divWinning Divergence
d)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" vs public "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IntegrityFingerprint -> Text
renderFingerprint (Divergence -> IntegrityFingerprint
divLosing Divergence
d)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

renderFingerprint :: IntegrityFingerprint -> Text
renderFingerprint :: IntegrityFingerprint -> Text
renderFingerprint IntegrityFingerprint
fp = Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (((Text, Maybe HashAlg, Text) -> Text)
-> [(Text, Maybe HashAlg, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe HashAlg, Text) -> Text
renderHash (IntegrityFingerprint -> [(Text, Maybe HashAlg, Text)]
integrityHashes IntegrityFingerprint
fp)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"

renderHash :: (Text, Maybe HashAlg, Text) -> Text
renderHash :: (Text, Maybe HashAlg, Text) -> Text
renderHash (Text
file, Maybe HashAlg
alg, Text
body) = Text
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (HashAlg -> Text) -> Maybe HashAlg -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"none" HashAlg -> Text
renderHashAlg Maybe HashAlg
alg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
body

-- The @module@ filter key for this module's own lines, held stable as this value rather than
-- the source module path, so an operator's saved filter keeps matching.
pipelineModule :: Text
pipelineModule :: Text
pipelineModule = Text
"Ecluse.Server.Pipeline"