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

{- | The composition root's mirror-queue backend selection: the pure decision of which queue this
binary builds, and the boot warnings the choice warrants.

'planMirrorQueue' is the single place that knows which backends this binary can build. Failures
aggregate as 'Ecluse.Composition.BootError.BootError's, so one run reports every missing input.
-}
module Ecluse.Composition.MirrorQueue (
    MirrorRuntimePlan (..),
    planMirrorRuntime,
    MirrorQueuePlan (..),
    planMirrorQueue,
    mirrorQueuePlanWarning,
    memoryQueueBootWarning,
    memoryQueueDropWarning,
    deadLetterTerminusWarning,
) where

import Ecluse.Composition.BootError (BootError (..))
import Ecluse.Config (
    AppConfig (..),
    Config (..),
    Mount (mountRegistries),
    QueueSettings (qsMaxReceiveCount, qsUrl),
    QueueTarget (..),
    queueUrlTarget,
    queueUrlText,
    regMirrorTarget,
 )
import Ecluse.Config.Ambient (AmbientAws (..), parseEndpointUrl)
import Ecluse.Core.Fault (TransportFault, tfDetail)
import Ecluse.Core.Queue (
    DeadLetterTerminus (TerminusAbsent, TerminusAttached),
    DeliveryBudget (DeliveryBudget),
    retiringDelivery,
 )
import Ecluse.Core.Text (nonBlank)
import Ecluse.Runtime.Aws.Env (AwsEndpoint)
import Ecluse.Runtime.Queue.Sqs (SqsConfig (sqsEndpoint, sqsMaxReceiveCount), defaultSqsConfig)

{- | Whether this deployment runs a mirror runtime at all. A serve-only deployment never
consults the queue configuration, so it boots with no queue variables set.
-}
data MirrorRuntimePlan
    = -- | No mount mirrors: no queue, no enqueue buffer, no worker.
      NoMirroring
    | -- | At least one mount mirrors: build the planned queue backend.
      MirrorWith MirrorQueuePlan
    deriving stock (MirrorRuntimePlan -> MirrorRuntimePlan -> Bool
(MirrorRuntimePlan -> MirrorRuntimePlan -> Bool)
-> (MirrorRuntimePlan -> MirrorRuntimePlan -> Bool)
-> Eq MirrorRuntimePlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MirrorRuntimePlan -> MirrorRuntimePlan -> Bool
== :: MirrorRuntimePlan -> MirrorRuntimePlan -> Bool
$c/= :: MirrorRuntimePlan -> MirrorRuntimePlan -> Bool
/= :: MirrorRuntimePlan -> MirrorRuntimePlan -> Bool
Eq, Int -> MirrorRuntimePlan -> ShowS
[MirrorRuntimePlan] -> ShowS
MirrorRuntimePlan -> String
(Int -> MirrorRuntimePlan -> ShowS)
-> (MirrorRuntimePlan -> String)
-> ([MirrorRuntimePlan] -> ShowS)
-> Show MirrorRuntimePlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MirrorRuntimePlan -> ShowS
showsPrec :: Int -> MirrorRuntimePlan -> ShowS
$cshow :: MirrorRuntimePlan -> String
show :: MirrorRuntimePlan -> String
$cshowList :: [MirrorRuntimePlan] -> ShowS
showList :: [MirrorRuntimePlan] -> ShowS
Show)

{- | Decide whether the composition root builds a mirror runtime at all. A serve-only
deployment cannot fail boot over queue variables it does not need.
-}
planMirrorRuntime :: AmbientAws -> Config -> Either [BootError] MirrorRuntimePlan
planMirrorRuntime :: AmbientAws -> Config -> Either [BootError] MirrorRuntimePlan
planMirrorRuntime AmbientAws
ambient Config
config
    | Bool
noneMirror = MirrorRuntimePlan -> Either [BootError] MirrorRuntimePlan
forall a b. b -> Either a b
Right MirrorRuntimePlan
NoMirroring
    | Bool
otherwise = MirrorQueuePlan -> MirrorRuntimePlan
MirrorWith (MirrorQueuePlan -> MirrorRuntimePlan)
-> Either [BootError] MirrorQueuePlan
-> Either [BootError] MirrorRuntimePlan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AmbientAws -> AppConfig -> Either [BootError] MirrorQueuePlan
planMirrorQueue AmbientAws
ambient (Config -> AppConfig
configApp Config
config)
  where
    noneMirror :: Bool
noneMirror = (Mount -> Bool) -> Map Ecosystem Mount -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe MirrorTarget -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe MirrorTarget -> Bool)
-> (Mount -> Maybe MirrorTarget) -> Mount -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountRegistries -> Maybe MirrorTarget
regMirrorTarget (MountRegistries -> Maybe MirrorTarget)
-> (Mount -> MountRegistries) -> Mount -> Maybe MirrorTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mount -> MountRegistries
mountRegistries) (Config -> Map Ecosystem Mount
configMounts Config
config)

{- | Which mirror-queue backend the composition root builds. The plan carries no sizes:
the in-memory backend's depth cap is a memory-plan tenant, allocated after this choice.
-}
data MirrorQueuePlan
    = -- | The durable AWS SQS backend, built by @Ecluse.Runtime.Queue.Sqs.newSqsQueue@.
      SqsBackend SqsConfig
    | -- | The bounded in-memory backend: non-durable and best-effort, so boot warns.
      MemoryBackend
    deriving stock (MirrorQueuePlan -> MirrorQueuePlan -> Bool
(MirrorQueuePlan -> MirrorQueuePlan -> Bool)
-> (MirrorQueuePlan -> MirrorQueuePlan -> Bool)
-> Eq MirrorQueuePlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MirrorQueuePlan -> MirrorQueuePlan -> Bool
== :: MirrorQueuePlan -> MirrorQueuePlan -> Bool
$c/= :: MirrorQueuePlan -> MirrorQueuePlan -> Bool
/= :: MirrorQueuePlan -> MirrorQueuePlan -> Bool
Eq, Int -> MirrorQueuePlan -> ShowS
[MirrorQueuePlan] -> ShowS
MirrorQueuePlan -> String
(Int -> MirrorQueuePlan -> ShowS)
-> (MirrorQueuePlan -> String)
-> ([MirrorQueuePlan] -> ShowS)
-> Show MirrorQueuePlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MirrorQueuePlan -> ShowS
showsPrec :: Int -> MirrorQueuePlan -> ShowS
$cshow :: MirrorQueuePlan -> String
show :: MirrorQueuePlan -> String
$cshowList :: [MirrorQueuePlan] -> ShowS
showList :: [MirrorQueuePlan] -> ShowS
Show)

{- | Select the mirror-queue backend from @ECLUSE_QUEUE__URL@'s derived shape, which an @AWS_ENDPOINT_URL_SQS@ override overrules.
The generic @AWS_ENDPOINT_URL@ is the S3 advisory client's, and honouring it here would redirect queue traffic.
-}
planMirrorQueue :: AmbientAws -> AppConfig -> Either [BootError] MirrorQueuePlan
planMirrorQueue :: AmbientAws -> AppConfig -> Either [BootError] MirrorQueuePlan
planMirrorQueue AmbientAws
ambient AppConfig
env = case QueueSettings -> Maybe QueueUrl
qsUrl (AppConfig -> QueueSettings
cfgQueue AppConfig
env) of
    -- No queue URL is a deliberate rollover, never a boot failure. Mirroring is demand-driven, so a
    -- job lost to a restart re-enqueues on the next demand: the rollover costs durability, not safety.
    Maybe QueueUrl
Nothing -> MirrorQueuePlan -> Either [BootError] MirrorQueuePlan
forall a b. b -> Either a b
Right MirrorQueuePlan
MemoryBackend
    Just QueueUrl
queueUrl ->
        let url :: Text
url = QueueUrl -> Text
queueUrlText QueueUrl
queueUrl
         in case Text -> Maybe Text
nonBlank (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AmbientAws -> Maybe Text
ambientAwsEndpointUrlSqs AmbientAws
ambient of
                Just Text
override -> case (Either BootError Text
regionE, Text -> Either BootError AwsEndpoint
endpointE Text
override) of
                    (Right Text
region, Right AwsEndpoint
endpoint) ->
                        MirrorQueuePlan -> Either [BootError] MirrorQueuePlan
forall a b. b -> Either a b
Right (SqsConfig -> MirrorQueuePlan
SqsBackend (Text -> Text -> SqsConfig
sqsConfigFor Text
url Text
region){sqsEndpoint = Just endpoint})
                    (Either BootError Text
r, Either BootError AwsEndpoint
e) -> [BootError] -> Either [BootError] MirrorQueuePlan
forall a b. a -> Either a b
Left ([Either BootError ()] -> [BootError]
forall a b. [Either a b] -> [a]
lefts [Either BootError Text -> Either BootError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Either BootError Text
r, Either BootError AwsEndpoint -> Either BootError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Either BootError AwsEndpoint
e])
                Maybe Text
Nothing -> case QueueUrl -> Maybe QueueTarget
queueUrlTarget QueueUrl
queueUrl of
                    Just (SqsTarget Text
region) -> MirrorQueuePlan -> Either [BootError] MirrorQueuePlan
forall a b. b -> Either a b
Right (SqsConfig -> MirrorQueuePlan
SqsBackend (Text -> Text -> SqsConfig
sqsConfigFor Text
url Text
region))
                    Just (PubSubTarget Text
_project Text
_topic) -> [BootError] -> Either [BootError] MirrorQueuePlan
forall a b. a -> Either a b
Left [Text -> BootError
QueueProviderUnavailable Text
"pubsub"]
                    Maybe QueueTarget
Nothing -> [BootError] -> Either [BootError] MirrorQueuePlan
forall a b. a -> Either a b
Left [Text -> BootError
QueueUrlUnrecognised Text
url]
  where
    -- The provider knobs stay at their defaults. The operator's redelivery budget comes
    -- in as the floor, and the built backend raises it past any attached terminus.
    sqsConfigFor :: Text -> Text -> SqsConfig
    sqsConfigFor :: Text -> Text -> SqsConfig
sqsConfigFor Text
url Text
region =
        (Text -> Text -> SqsConfig
defaultSqsConfig Text
url Text
region)
            { sqsMaxReceiveCount = DeliveryBudget (qsMaxReceiveCount (cfgQueue env))
            }

    -- AWS_REGION, required only under the endpoint override, because a real SQS URL
    -- carries its region in its host. A blank value counts as absent.
    regionE :: Either BootError Text
    regionE :: Either BootError Text
regionE = BootError -> Maybe Text -> Either BootError Text
forall l r. l -> Maybe r -> Either l r
maybeToRight BootError
QueueRegionMissing (Text -> Maybe Text
nonBlank (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AmbientAws -> Maybe Text
ambientAwsRegion AmbientAws
ambient)

    endpointE :: Text -> Either BootError AwsEndpoint
    endpointE :: Text -> Either BootError AwsEndpoint
endpointE = (Secret -> BootError)
-> Either Secret AwsEndpoint -> Either BootError AwsEndpoint
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Secret -> BootError
QueueEndpointMalformed (Either Secret AwsEndpoint -> Either BootError AwsEndpoint)
-> (Text -> Either Secret AwsEndpoint)
-> Text
-> Either BootError AwsEndpoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Secret AwsEndpoint
parseEndpointUrl

{- | The loud boot warning a 'MirrorQueuePlan' warrants, or 'Nothing' for a durable
backend. The composition root logs the 'Just' at @WarningS@ when it selects the plan.
-}
mirrorQueuePlanWarning :: MirrorQueuePlan -> Maybe Text
mirrorQueuePlanWarning :: MirrorQueuePlan -> Maybe Text
mirrorQueuePlanWarning = \case
    SqsBackend SqsConfig
_ -> Maybe Text
forall a. Maybe a
Nothing
    MirrorQueuePlan
MemoryBackend -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
memoryQueueBootWarning

-- | The boot warning for a rollover to the in-memory queue (no @ECLUSE_QUEUE__URL@).
memoryQueueBootWarning :: Text
memoryQueueBootWarning :: Text
memoryQueueBootWarning =
    Text
"no ECLUSE_QUEUE__URL is set, so the mirror queue is IN-MEMORY, NON-DURABLE, and BEST-EFFORT. "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Jobs are dropped on cap overflow and lost on restart or redeploy; each is re-mirrored on the next "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"demand (no data loss, only deferred mirroring). Point ECLUSE_QUEUE__URL at a durable queue (SQS) "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"for a production mirror that must not shed under load."

{- | The warning a built queue's dead-letter probe warrants, or 'Nothing': the memory backend is silent, 'memoryQueueBootWarning' covering it.
Pass the built handle's budget, not the plan's configured floor, so the warning states what the worker will do.
-}
deadLetterTerminusWarning :: MirrorQueuePlan -> DeliveryBudget -> Either TransportFault DeadLetterTerminus -> Maybe Text
deadLetterTerminusWarning :: MirrorQueuePlan
-> DeliveryBudget
-> Either TransportFault DeadLetterTerminus
-> Maybe Text
deadLetterTerminusWarning MirrorQueuePlan
plan DeliveryBudget
budget Either TransportFault DeadLetterTerminus
probed = case MirrorQueuePlan
plan of
    MirrorQueuePlan
MemoryBackend -> Maybe Text
forall a. Maybe a
Nothing
    SqsBackend{} -> case Either TransportFault DeadLetterTerminus
probed of
        Right TerminusAttached{} -> Maybe Text
forall a. Maybe a
Nothing
        Right DeadLetterTerminus
TerminusAbsent -> Text -> Maybe Text
forall a. a -> Maybe a
Just (DeliveryBudget -> Text
noDeadLetterTerminusWarning DeliveryBudget
budget)
        Left TransportFault
fault -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
terminusUnprobedWarning (TransportFault -> Text
tfDetail TransportFault
fault))

-- The no-terminus warning. It names the budget that stands in for the missing
-- dead-letter queue, so an operator sees what happens to a poison message.
noDeadLetterTerminusWarning :: DeliveryBudget -> Text
noDeadLetterTerminusWarning :: DeliveryBudget -> Text
noDeadLetterTerminusWarning DeliveryBudget
budget =
    Text
"the mirror queue has NO DEAD-LETTER TERMINUS: no redrive policy is attached, so nothing captures a "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"mirror job that can never be published. Écluse retires such a job itself once it has been "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"delivered "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (DeliveryBudget -> Int
retiringDelivery DeliveryBudget
budget)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" times, alarming and counting it, rather than letting it cycle until the queue's "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"retention window discards it unseen. Attach a redrive policy with a dead-letter queue to keep "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"poison messages for inspection."

-- The unreadable-policy warning. Boot continues on the configured budget, but Écluse
-- can no longer confirm that the budget sits above an attached terminus's capture count.
terminusUnprobedWarning :: Text -> Text
terminusUnprobedWarning :: Text -> Text
terminusUnprobedWarning Text
detail =
    Text
"could not read the mirror queue's redrive policy, so whether poison messages have a dead-letter "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"terminus is unknown; grant sqs:GetQueueAttributes on the queue to let Écluse check. The "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"configured ECLUSE_QUEUE__MAX_RECEIVE_COUNT stands as the delivery budget, and may retire a job "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"before a dead-letter queue would have captured it: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
detail

{- | The cap-overflow drop warning for the in-memory backend. The queue rate-limits this
report, so it does not fire once per dropped job.
-}
memoryQueueDropWarning :: Int -> Text
memoryQueueDropWarning :: Int -> Text
memoryQueueDropWarning Int
dropped =
    Text
"mirror queue at capacity: dropped a mirror job (drop-newest); "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
dropped
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" job(s) dropped so far. Each is re-mirrored on the next demand; raise "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ECLUSE_QUEUE__MAX_MEMORY_DEPTH to shed fewer under load."