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

{- | The pure boot pass accumulates refusals and advisories for each role.
The composition root builds only from 'ValidatedPlan'. Unvetted settings remain on 'vpSettings'.
-}
module Ecluse.Composition.Validate (
    -- * The validate phase
    ValidatedPlan (vpMounts, vpPublications, vpMirrorStores, vpPrivateCaches, vpProgressFloor, vpSettings),
    vetBoot,

    -- * What it clears
    VettedMount (vmEcosystem, vmAdapter, vmMount, vmConfig),
    VettedPublication (vpubTarget, vpubFirstParty, vpubStaticToken),
) where

import Data.Map.Strict qualified as Map

import Ecluse.Composition.BootError (
    Advisory (DredgerQuotaOverrideUnmatched),
    BootError (
        AdvisoryDenyWithoutStore,
        DredgerChunkPauseBeneathFloor,
        DredgerQuotaScopeConflict,
        FirstPartyMissing,
        FirstPartyWithoutPrivateUpstream,
        MinProgressBytesNotPositive,
        MirrorTargetWithoutPublish,
        MissingAdapter,
        ProgressWindowNotBelowServeCap,
        ProgressWindowNotPositive,
        PublicationTargetWithoutPublish,
        PublishStaticCredentialNeedsEdge
    ),
 )
import Ecluse.Composition.Endpoints (
    PublicationTarget,
    VettedEndpoints (vePublicationTargets),
    vetEndpoints,
 )
import Ecluse.Composition.Maintenance (ClearedBackend, overrideKey, vetPrivateCaches, vetStoreBackends)
import Ecluse.Composition.Vet (Severity (Advise, Ignore, Refuse), Vet, byStoreRole, decided, rule)
import Ecluse.Config (
    AdvisoriesSettings (advUrl),
    AppConfig (cfgAdvisories, cfgDredger, cfgLimits, cfgMounts, cfgServer),
    Config (configApp, configMounts),
    DredgerSettings (drgChunkPause, drgQuotaOverrides),
    FirstParty,
    LimitsSettings (limMinProgressBytes, limProgressWindow),
    MirrorTarget (mtUrl),
    Mount,
    MountConfig (mntFirstParty, mntPrivateUpstream, mntPublicationTarget),
    PrivateEndpoint (preTarget),
    PublicationEndpoint (peTarget, peToken),
    QuotaOverride (qoQuotas, qoScope, qoWeights),
    ServerSettings (srvAuthToken),
    StoreBackend,
    StoreTag,
    Target (tgtTag, tgtUrl),
    mountAdvisoryDenials,
    mountRegistries,
    regMirrorTarget,
 )
import Ecluse.Core.Credential (Secret)
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Registry.Adapter (RegistryAdapter, adapterFor, adapterPublish)
import Ecluse.Core.Registry.Sweep.Types (minimumChunkPause)
import Ecluse.Core.Security (
    ProgressFloor,
    ProgressFloorError (MinBytesNotPositive, WindowNotBelowServeCap, WindowNotPositive),
    mkProgressFloor,
    serveCapSeconds,
 )
import Ecluse.Core.Security.Egress (registryUrlText)

{- | What the pure boot pass cleared: the mounts a role may serve, the endpoints it may use, and
the settings no rule vets.
-}
data ValidatedPlan = ValidatedPlan
    { ValidatedPlan -> [VettedMount]
vpMounts :: [VettedMount]
    -- ^ Every active mount, in ascending ecosystem order, with the adapter that serves it.
    , ValidatedPlan -> Map Ecosystem VettedPublication
vpPublications :: Map Ecosystem VettedPublication
    -- ^ Each mount's cleared publish path, absent where the mount declares no target.
    , ValidatedPlan -> Map Ecosystem ClearedBackend
vpMirrorStores :: Map Ecosystem ClearedBackend
    -- ^ The backend for each store a sweep may delete from. Only @ecluse dredger@'s pass clears one.
    , ValidatedPlan -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
vpPrivateCaches :: Map Ecosystem (Maybe StoreBackend, ClearedBackend)
    -- ^ Private caches cleared for this role with their own credential plans.
    , ValidatedPlan -> ProgressFloor
vpProgressFloor :: ProgressFloor
    -- ^ The upstream progress floor the configured window and byte count make under the serve-path cap.
    , ValidatedPlan -> AppConfig
vpSettings :: AppConfig
    {- ^ The settings no rule vets. The mounts it carries are the raw declarations, and 'vpMounts'
    holds the vetted ones the runtime reads.
    -}
    }

-- | One active mount, paired with the adapter this build ships for its ecosystem.
data VettedMount = VettedMount
    { VettedMount -> Ecosystem
vmEcosystem :: Ecosystem
    , VettedMount -> RegistryAdapter
vmAdapter :: RegistryAdapter
    , VettedMount -> Mount
vmMount :: Mount
    , VettedMount -> MountConfig
vmConfig :: MountConfig
    }

{- | A mount's cleared publish path: the vetted endpoint, the first-party namespaces the
anti-shadowing guard enforces, and the static credential the inbound edge gate covers.
-}
data VettedPublication = VettedPublication
    { VettedPublication -> PublicationTarget
vpubTarget :: PublicationTarget
    , VettedPublication -> FirstParty
vpubFirstParty :: FirstParty
    , VettedPublication -> Maybe Secret
vpubStaticToken :: Maybe Secret
    }

-- | Accumulate every pure refusal and advisory for one role before constructing its plan.
vetBoot :: Config -> Vet ValidatedPlan
vetBoot :: Config -> Vet ValidatedPlan
vetBoot Config
config =
    [VettedMount]
-> Map Ecosystem (FirstParty, Maybe Secret)
-> VettedEndpoints
-> Map Ecosystem ClearedBackend
-> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
-> ProgressFloor
-> ValidatedPlan
assemble
        ([VettedMount]
 -> Map Ecosystem (FirstParty, Maybe Secret)
 -> VettedEndpoints
 -> Map Ecosystem ClearedBackend
 -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
 -> ProgressFloor
 -> ValidatedPlan)
-> Vet [VettedMount]
-> Vet
     (Map Ecosystem (FirstParty, Maybe Secret)
      -> VettedEndpoints
      -> Map Ecosystem ClearedBackend
      -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
      -> ProgressFloor
      -> ValidatedPlan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Vet [VettedMount]
vetMounts Config
config
        Vet
  (Map Ecosystem (FirstParty, Maybe Secret)
   -> VettedEndpoints
   -> Map Ecosystem ClearedBackend
   -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
   -> ProgressFloor
   -> ValidatedPlan)
-> Vet (Map Ecosystem (FirstParty, Maybe Secret))
-> Vet
     (VettedEndpoints
      -> Map Ecosystem ClearedBackend
      -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
      -> ProgressFloor
      -> ValidatedPlan)
forall a b. Vet (a -> b) -> Vet a -> Vet b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppConfig -> Vet (Map Ecosystem (FirstParty, Maybe Secret))
vetPublishPolicy AppConfig
app
        Vet
  (VettedEndpoints
   -> Map Ecosystem ClearedBackend
   -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
   -> ProgressFloor
   -> ValidatedPlan)
-> Vet VettedEndpoints
-> Vet
     (Map Ecosystem ClearedBackend
      -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
      -> ProgressFloor
      -> ValidatedPlan)
forall a b. Vet (a -> b) -> Vet a -> Vet b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Ecosystem MountConfig -> Vet VettedEndpoints
vetEndpoints (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app)
        Vet
  (Map Ecosystem ClearedBackend
   -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
   -> ProgressFloor
   -> ValidatedPlan)
-> Vet (Map Ecosystem ClearedBackend)
-> Vet
     (Map Ecosystem (Maybe StoreBackend, ClearedBackend)
      -> ProgressFloor -> ValidatedPlan)
forall a b. Vet (a -> b) -> Vet a -> Vet b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ResolveMaintenanceAdapter
-> MountMap -> Vet (Map Ecosystem ClearedBackend)
vetStoreBackends ResolveMaintenanceAdapter
adapterFor (Config -> MountMap
configMounts Config
config)
        Vet
  (Map Ecosystem (Maybe StoreBackend, ClearedBackend)
   -> ProgressFloor -> ValidatedPlan)
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
-> Vet (ProgressFloor -> ValidatedPlan)
forall a b. Vet (a -> b) -> Vet a -> Vet b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ResolveMaintenanceAdapter
-> Map Ecosystem MountConfig
-> MountMap
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
vetPrivateCaches ResolveMaintenanceAdapter
adapterFor (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app) (Config -> MountMap
configMounts Config
config)
        Vet (ProgressFloor -> ValidatedPlan)
-> Vet ProgressFloor -> Vet ValidatedPlan
forall a b. Vet (a -> b) -> Vet a -> Vet b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppConfig -> Vet ProgressFloor
vetProgressFloor AppConfig
app
        Vet ValidatedPlan -> Vet () -> Vet ValidatedPlan
forall a b. Vet a -> Vet b -> Vet a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* AppConfig -> Vet ()
vetSweepPacing AppConfig
app
        Vet ValidatedPlan -> Vet () -> Vet ValidatedPlan
forall a b. Vet a -> Vet b -> Vet a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Config -> Vet ()
vetAdvisoryStore Config
config
        Vet ValidatedPlan -> Vet () -> Vet ValidatedPlan
forall a b. Vet a -> Vet b -> Vet a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Config -> Vet ()
vetQuotaOverrides Config
config
        Vet ValidatedPlan -> Vet () -> Vet ValidatedPlan
forall a b. Vet a -> Vet b -> Vet a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* AppConfig -> Vet ()
vetQuotaScopes AppConfig
app
  where
    app :: AppConfig
app = Config -> AppConfig
configApp Config
config

    assemble :: [VettedMount]
-> Map Ecosystem (FirstParty, Maybe Secret)
-> VettedEndpoints
-> Map Ecosystem ClearedBackend
-> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
-> ProgressFloor
-> ValidatedPlan
assemble [VettedMount]
mounts Map Ecosystem (FirstParty, Maybe Secret)
policies VettedEndpoints
endpoints Map Ecosystem ClearedBackend
backends Map Ecosystem (Maybe StoreBackend, ClearedBackend)
caches ProgressFloor
progress =
        ValidatedPlan
            { vpMounts :: [VettedMount]
vpMounts = [VettedMount]
mounts
            , vpPublications :: Map Ecosystem VettedPublication
vpPublications = (PublicationTarget
 -> (FirstParty, Maybe Secret) -> VettedPublication)
-> Map Ecosystem PublicationTarget
-> Map Ecosystem (FirstParty, Maybe Secret)
-> Map Ecosystem VettedPublication
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith PublicationTarget
-> (FirstParty, Maybe Secret) -> VettedPublication
cleared (VettedEndpoints -> Map Ecosystem PublicationTarget
vePublicationTargets VettedEndpoints
endpoints) Map Ecosystem (FirstParty, Maybe Secret)
policies
            , vpMirrorStores :: Map Ecosystem ClearedBackend
vpMirrorStores = Map Ecosystem ClearedBackend
backends
            , vpPrivateCaches :: Map Ecosystem (Maybe StoreBackend, ClearedBackend)
vpPrivateCaches = Map Ecosystem (Maybe StoreBackend, ClearedBackend)
caches
            , vpProgressFloor :: ProgressFloor
vpProgressFloor = ProgressFloor
progress
            , vpSettings :: AppConfig
vpSettings = AppConfig
app
            }

    cleared :: PublicationTarget
-> (FirstParty, Maybe Secret) -> VettedPublication
cleared PublicationTarget
target (FirstParty
firstParty, Maybe Secret
staticToken) = PublicationTarget
-> FirstParty -> Maybe Secret -> VettedPublication
VettedPublication PublicationTarget
target FirstParty
firstParty Maybe Secret
staticToken

-- Every role dials upstreams, so every role refuses a floor the window and byte count cannot make.
vetProgressFloor :: AppConfig -> Vet ProgressFloor
vetProgressFloor :: AppConfig -> Vet ProgressFloor
vetProgressFloor AppConfig
app =
    Either [BootError] ProgressFloor -> Vet ProgressFloor
forall a. Either [BootError] a -> Vet a
decided ((NonEmpty ProgressFloorError -> [BootError])
-> Either (NonEmpty ProgressFloorError) ProgressFloor
-> Either [BootError] ProgressFloor
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 ((ProgressFloorError -> BootError)
-> [ProgressFloorError] -> [BootError]
forall a b. (a -> b) -> [a] -> [b]
map ProgressFloorError -> BootError
refusal ([ProgressFloorError] -> [BootError])
-> (NonEmpty ProgressFloorError -> [ProgressFloorError])
-> NonEmpty ProgressFloorError
-> [BootError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgressFloorError -> [ProgressFloorError]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) (NominalDiffTime
-> NominalDiffTime
-> Int
-> Either (NonEmpty ProgressFloorError) ProgressFloor
mkProgressFloor (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
serveCapSeconds) (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
window) Int
minBytes))
  where
    window :: Int
window = LimitsSettings -> Int
limProgressWindow (AppConfig -> LimitsSettings
cfgLimits AppConfig
app)
    minBytes :: Int
minBytes = LimitsSettings -> Int
limMinProgressBytes (AppConfig -> LimitsSettings
cfgLimits AppConfig
app)
    refusal :: ProgressFloorError -> BootError
refusal = \case
        ProgressFloorError
WindowNotPositive -> Int -> BootError
ProgressWindowNotPositive Int
window
        ProgressFloorError
WindowNotBelowServeCap -> Int -> Int -> BootError
ProgressWindowNotBelowServeCap Int
window Int
serveCapSeconds
        ProgressFloorError
MinBytesNotPositive -> Int -> BootError
MinProgressBytesNotPositive Int
minBytes

{- The floor under the sweep's own pace. Deletion is permanent, so both store roles refuse a
pause that would sweep faster than an operator can stop it, and every other role reads none. -}
vetSweepPacing :: AppConfig -> Vet ()
vetSweepPacing :: AppConfig -> Vet ()
vetSweepPacing AppConfig
app = (RegistryRole -> Severity NominalDiffTime)
-> (NominalDiffTime -> Maybe NominalDiffTime)
-> NominalDiffTime
-> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule RegistryRole -> Severity NominalDiffTime
severity NominalDiffTime -> Maybe NominalDiffTime
forall {f :: * -> *}.
Alternative f =>
NominalDiffTime -> f NominalDiffTime
beneathFloor (DredgerSettings -> NominalDiffTime
drgChunkPause (AppConfig -> DredgerSettings
cfgDredger AppConfig
app))
  where
    severity :: RegistryRole -> Severity NominalDiffTime
severity = Severity NominalDiffTime
-> Severity NominalDiffTime
-> RegistryRole
-> Severity NominalDiffTime
forall finding.
Severity finding
-> Severity finding -> RegistryRole -> Severity finding
byStoreRole ((NominalDiffTime -> BootError) -> Severity NominalDiffTime
forall finding. (finding -> BootError) -> Severity finding
Refuse (NominalDiffTime -> NominalDiffTime -> BootError
`DredgerChunkPauseBeneathFloor` NominalDiffTime
minimumChunkPause)) Severity NominalDiffTime
forall finding. Severity finding
Ignore

    beneathFloor :: NominalDiffTime -> f NominalDiffTime
beneathFloor NominalDiffTime
configured = NominalDiffTime
configured NominalDiffTime -> f () -> f NominalDiffTime
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> f ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (NominalDiffTime
configured NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
minimumChunkPause)

{- An advisory deny cannot decide without a database, whatever its onUnavailable says, so every
role that evaluates rules refuses the pairing rather than serving a mount that denies everything. -}
vetAdvisoryStore :: Config -> Vet ()
vetAdvisoryStore :: Config -> Vet ()
vetAdvisoryStore Config
config =
    ((Ecosystem, Mount) -> Vet ()) -> [(Ecosystem, Mount)] -> Vet ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((RegistryRole -> Severity (Ecosystem, NonEmpty Text))
-> ((Ecosystem, Mount) -> Maybe (Ecosystem, NonEmpty Text))
-> (Ecosystem, Mount)
-> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity (Ecosystem, NonEmpty Text)
-> RegistryRole -> Severity (Ecosystem, NonEmpty Text)
forall a b. a -> b -> a
const (((Ecosystem, NonEmpty Text) -> BootError)
-> Severity (Ecosystem, NonEmpty Text)
forall finding. (finding -> BootError) -> Severity finding
Refuse ((Ecosystem -> NonEmpty Text -> BootError)
-> (Ecosystem, NonEmpty Text) -> BootError
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ecosystem -> NonEmpty Text -> BootError
AdvisoryDenyWithoutStore))) (Ecosystem, Mount) -> Maybe (Ecosystem, NonEmpty Text)
forall {a}. (a, Mount) -> Maybe (a, NonEmpty Text)
denyingWithoutStore) [(Ecosystem, Mount)]
mounts
  where
    stored :: Bool
stored = Maybe AdvisoryStoreUrl -> Bool
forall a. Maybe a -> Bool
isJust (AdvisoriesSettings -> Maybe AdvisoryStoreUrl
advUrl (AppConfig -> AdvisoriesSettings
cfgAdvisories (Config -> AppConfig
configApp Config
config)))
    mounts :: [(Ecosystem, Mount)]
mounts = MountMap -> [(Ecosystem, Mount)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Config -> MountMap
configMounts Config
config)

    denyingWithoutStore :: (a, Mount) -> Maybe (a, NonEmpty Text)
denyingWithoutStore (a
eco, Mount
mount)
        | Bool
stored = Maybe (a, NonEmpty Text)
forall a. Maybe a
Nothing
        | Bool
otherwise = (,) a
eco (NonEmpty Text -> (a, NonEmpty Text))
-> Maybe (NonEmpty Text) -> Maybe (a, NonEmpty Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Mount -> [Text]
mountAdvisoryDenials Mount
mount)

{- A declared capacity that matches no store paces nothing. It advises rather than refuses,
because an endpoint renamed under a running Dredger would otherwise stop the role outright. -}
vetQuotaOverrides :: Config -> Vet ()
vetQuotaOverrides :: Config -> Vet ()
vetQuotaOverrides Config
config = (Text -> Vet ()) -> [Text] -> Vet ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((RegistryRole -> Severity Text)
-> (Text -> Maybe Text) -> Text -> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule RegistryRole -> Severity Text
severity Text -> Maybe Text
forall {f :: * -> *}. Alternative f => Text -> f Text
unmatched) [Text]
declaredKeys
  where
    severity :: RegistryRole -> Severity Text
severity = Severity Text -> Severity Text -> RegistryRole -> Severity Text
forall finding.
Severity finding
-> Severity finding -> RegistryRole -> Severity finding
byStoreRole ((Text -> Advisory) -> Severity Text
forall finding. (finding -> Advisory) -> Severity finding
Advise Text -> Advisory
DredgerQuotaOverrideUnmatched) Severity Text
forall finding. Severity finding
Ignore
    declaredKeys :: [Text]
declaredKeys = Map Text QuotaOverride -> [Text]
forall k a. Map k a -> [k]
Map.keys (DredgerSettings -> Map Text QuotaOverride
drgQuotaOverrides (AppConfig -> DredgerSettings
cfgDredger (Config -> AppConfig
configApp Config
config)))
    unmatched :: Text -> f Text
unmatched Text
key = Text
key Text -> f () -> f Text
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> f ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Text
overrideKey Text
key Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Text]
storeKeys)
    storeKeys :: [Text]
storeKeys = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
overrideKey (Config -> [Text]
declaredStoreUrls Config
config)

{- One capacity pool takes one definition. Two entries that name the same scope and describe it
differently refuse, because whichever the boot read last would silently set the other's rate. -}
vetQuotaScopes :: AppConfig -> Vet ()
vetQuotaScopes :: AppConfig -> Vet ()
vetQuotaScopes AppConfig
app = ((Text, (Text, QuotaOverride), (Text, QuotaOverride)) -> Vet ())
-> [(Text, (Text, QuotaOverride), (Text, QuotaOverride))] -> Vet ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((RegistryRole -> Severity (Text, Text, Text))
-> ((Text, (Text, QuotaOverride), (Text, QuotaOverride))
    -> Maybe (Text, Text, Text))
-> (Text, (Text, QuotaOverride), (Text, QuotaOverride))
-> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule RegistryRole -> Severity (Text, Text, Text)
severity (Text, (Text, QuotaOverride), (Text, QuotaOverride))
-> Maybe (Text, Text, Text)
forall {a} {b} {c}.
(a, (b, QuotaOverride), (c, QuotaOverride)) -> Maybe (a, b, c)
conflicting) (((Text, QuotaOverride) -> Maybe Text)
-> [(Text, QuotaOverride)]
-> [(Text, (Text, QuotaOverride), (Text, QuotaOverride))]
forall key entry.
Ord key =>
(entry -> Maybe key) -> [entry] -> [(key, entry, entry)]
pairsBy (Text, QuotaOverride) -> Maybe Text
forall {a}. (a, QuotaOverride) -> Maybe Text
declaredScope [(Text, QuotaOverride)]
entries)
  where
    severity :: RegistryRole -> Severity (Text, Text, Text)
severity = Severity (Text, Text, Text)
-> Severity (Text, Text, Text)
-> RegistryRole
-> Severity (Text, Text, Text)
forall finding.
Severity finding
-> Severity finding -> RegistryRole -> Severity finding
byStoreRole (((Text, Text, Text) -> BootError) -> Severity (Text, Text, Text)
forall finding. (finding -> BootError) -> Severity finding
Refuse (\(Text
scope, Text
first', Text
second') -> Text -> Text -> Text -> BootError
DredgerQuotaScopeConflict Text
scope Text
first' Text
second')) Severity (Text, Text, Text)
forall finding. Severity finding
Ignore
    entries :: [(Text, QuotaOverride)]
entries = Map Text QuotaOverride -> [(Text, QuotaOverride)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (DredgerSettings -> Map Text QuotaOverride
drgQuotaOverrides (AppConfig -> DredgerSettings
cfgDredger AppConfig
app))
    declaredScope :: (a, QuotaOverride) -> Maybe Text
declaredScope (a
_, QuotaOverride
override) = QuotaOverride -> Maybe Text
qoScope QuotaOverride
override
    conflicting :: (a, (b, QuotaOverride), (c, QuotaOverride)) -> Maybe (a, b, c)
conflicting (a
scope, (b
leftKey, QuotaOverride
left), (c
rightKey, QuotaOverride
right))
        | QuotaOverride
-> (Map QuotaDimension Rational, Map RequestKind Rational)
describes QuotaOverride
left (Map QuotaDimension Rational, Map RequestKind Rational)
-> (Map QuotaDimension Rational, Map RequestKind Rational) -> Bool
forall a. Eq a => a -> a -> Bool
== QuotaOverride
-> (Map QuotaDimension Rational, Map RequestKind Rational)
describes QuotaOverride
right = Maybe (a, b, c)
forall a. Maybe a
Nothing
        | Bool
otherwise = (a, b, c) -> Maybe (a, b, c)
forall a. a -> Maybe a
Just (a
scope, b
leftKey, c
rightKey)
    describes :: QuotaOverride
-> (Map QuotaDimension Rational, Map RequestKind Rational)
describes QuotaOverride
override = (QuotaOverride -> Map QuotaDimension Rational
qoQuotas QuotaOverride
override, QuotaOverride -> Map RequestKind Rational
qoWeights QuotaOverride
override)

-- Every pair of entries sharing one declared key, so a rule reads two definitions at once.
pairsBy :: (Ord key) => (entry -> Maybe key) -> [entry] -> [(key, entry, entry)]
pairsBy :: forall key entry.
Ord key =>
(entry -> Maybe key) -> [entry] -> [(key, entry, entry)]
pairsBy entry -> Maybe key
keyOf [entry]
entries =
    [ (key
key, entry
left, entry
right)
    | (key
key, [entry]
grouped) <- Map key [entry] -> [(key, [entry])]
forall k a. Map k a -> [(k, a)]
Map.toAscList (([entry] -> [entry] -> [entry])
-> [(key, [entry])] -> Map key [entry]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [entry] -> [entry] -> [entry]
forall a. Semigroup a => a -> a -> a
(<>) [(key
key, [entry
entry]) | entry
entry <- [entry]
entries, Just key
key <- [entry -> Maybe key
keyOf entry
entry]])
    , (entry
left, entry
right) <- [entry] -> [(entry, entry)]
forall {b}. [b] -> [(b, b)]
adjacent ([entry] -> [entry]
forall a. [a] -> [a]
reverse [entry]
grouped)
    ]
  where
    adjacent :: [b] -> [(b, b)]
adjacent [b]
values = [b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [b]
values (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
1 [b]
values)

-- Every store URL a mount declares as a sweep target: its mirror target and its private cache.
declaredStoreUrls :: Config -> [Text]
declaredStoreUrls :: Config -> [Text]
declaredStoreUrls Config
config =
    [RegistryUrl -> Text
registryUrlText (MirrorTarget -> RegistryUrl
mtUrl MirrorTarget
target) | Mount
mount <- MountMap -> [Mount]
forall k a. Map k a -> [a]
Map.elems (Config -> MountMap
configMounts Config
config), Just MirrorTarget
target <- [MountRegistries -> Maybe MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount)]]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [RegistryUrl -> Text
registryUrlText (Target -> RegistryUrl
tgtUrl (PrivateEndpoint -> Target
preTarget PrivateEndpoint
endpoint)) | MountConfig
mcfg <- Map Ecosystem MountConfig -> [MountConfig]
forall k a. Map k a -> [a]
Map.elems (AppConfig -> Map Ecosystem MountConfig
cfgMounts (Config -> AppConfig
configApp Config
config)), Just PrivateEndpoint
endpoint <- [MountConfig -> Maybe PrivateEndpoint
mntPrivateUpstream MountConfig
mcfg]]

vetMounts :: Config -> Vet [VettedMount]
vetMounts :: Config -> Vet [VettedMount]
vetMounts Config
config = [Maybe VettedMount] -> [VettedMount]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe VettedMount] -> [VettedMount])
-> Vet [Maybe VettedMount] -> Vet [VettedMount]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Ecosystem, (Mount, MountConfig)) -> Vet (Maybe VettedMount))
-> [(Ecosystem, (Mount, MountConfig))] -> Vet [Maybe VettedMount]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Ecosystem, (Mount, MountConfig)) -> Vet (Maybe VettedMount)
vetMount (Config -> [(Ecosystem, (Mount, MountConfig))]
activeMounts Config
config)

{- 'Ecluse.Config.loadConfig' derives 'configMounts' from 'cfgMounts' entry for entry, so the two
maps share a keyset and this pairing is total. -}
activeMounts :: Config -> [(Ecosystem, (Mount, MountConfig))]
activeMounts :: Config -> [(Ecosystem, (Mount, MountConfig))]
activeMounts Config
config =
    Map Ecosystem (Mount, MountConfig)
-> [(Ecosystem, (Mount, MountConfig))]
forall k a. Map k a -> [(k, a)]
Map.toAscList ((Mount -> MountConfig -> (Mount, MountConfig))
-> MountMap
-> Map Ecosystem MountConfig
-> Map Ecosystem (Mount, MountConfig)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) (Config -> MountMap
configMounts Config
config) (AppConfig -> Map Ecosystem MountConfig
cfgMounts (Config -> AppConfig
configApp Config
config)))

-- 'Nothing' only where the rule refused, and a refused pass yields no plan to carry it into.
vetMount :: (Ecosystem, (Mount, MountConfig)) -> Vet (Maybe VettedMount)
vetMount :: (Ecosystem, (Mount, MountConfig)) -> Vet (Maybe VettedMount)
vetMount (Ecosystem
eco, (Mount
mount, MountConfig
mcfg)) =
    Maybe VettedMount
vetted
        Maybe VettedMount -> Vet () -> Vet (Maybe VettedMount)
forall a b. a -> Vet b -> Vet a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (RegistryRole -> Severity Ecosystem)
-> (Ecosystem -> Maybe Ecosystem) -> Ecosystem -> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity Ecosystem -> RegistryRole -> Severity Ecosystem
forall a b. a -> b -> a
const ((Ecosystem -> BootError) -> Severity Ecosystem
forall finding. (finding -> BootError) -> Severity finding
Refuse Ecosystem -> BootError
MissingAdapter)) Ecosystem -> Maybe Ecosystem
unservedEcosystem Ecosystem
eco
        Vet (Maybe VettedMount) -> Vet () -> Vet (Maybe VettedMount)
forall a b. Vet a -> Vet b -> Vet a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (RegistryRole -> Severity Ecosystem)
-> (Ecosystem -> Maybe Ecosystem) -> Ecosystem -> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity Ecosystem -> RegistryRole -> Severity Ecosystem
forall a b. a -> b -> a
const ((Ecosystem -> BootError) -> Severity Ecosystem
forall finding. (finding -> BootError) -> Severity finding
Refuse Ecosystem -> BootError
MirrorTargetWithoutPublish)) (Bool -> Ecosystem -> Maybe Ecosystem
declaredWithoutPublish Bool
mirrors) Ecosystem
eco
        Vet (Maybe VettedMount) -> Vet () -> Vet (Maybe VettedMount)
forall a b. Vet a -> Vet b -> Vet a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (RegistryRole -> Severity Ecosystem)
-> (Ecosystem -> Maybe Ecosystem) -> Ecosystem -> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity Ecosystem -> RegistryRole -> Severity Ecosystem
forall a b. a -> b -> a
const ((Ecosystem -> BootError) -> Severity Ecosystem
forall finding. (finding -> BootError) -> Severity finding
Refuse Ecosystem -> BootError
PublicationTargetWithoutPublish)) (Bool -> Ecosystem -> Maybe Ecosystem
declaredWithoutPublish Bool
publishes) Ecosystem
eco
        Vet (Maybe VettedMount) -> Vet () -> Vet (Maybe VettedMount)
forall a b. Vet a -> Vet b -> Vet a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (RegistryRole -> Severity Ecosystem)
-> ((Ecosystem, MountConfig) -> Maybe Ecosystem)
-> (Ecosystem, MountConfig)
-> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity Ecosystem -> RegistryRole -> Severity Ecosystem
forall a b. a -> b -> a
const ((Ecosystem -> BootError) -> Severity Ecosystem
forall finding. (finding -> BootError) -> Severity finding
Refuse Ecosystem -> BootError
FirstPartyWithoutPrivateUpstream)) (Ecosystem, MountConfig) -> Maybe Ecosystem
firstPartyWithoutPrivateUpstream (Ecosystem
eco, MountConfig
mcfg)
  where
    vetted :: Maybe VettedMount
vetted = ResolveMaintenanceAdapter
adapterFor Ecosystem
eco Maybe RegistryAdapter
-> (RegistryAdapter -> VettedMount) -> Maybe VettedMount
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \RegistryAdapter
adapter -> Ecosystem -> RegistryAdapter -> Mount -> MountConfig -> VettedMount
VettedMount Ecosystem
eco RegistryAdapter
adapter Mount
mount MountConfig
mcfg

    unservedEcosystem :: Ecosystem -> Maybe Ecosystem
unservedEcosystem Ecosystem
e
        | Maybe RegistryAdapter -> Bool
forall a. Maybe a -> Bool
isNothing (ResolveMaintenanceAdapter
adapterFor Ecosystem
e) = Ecosystem -> Maybe Ecosystem
forall a. a -> Maybe a
Just Ecosystem
e
        | Bool
otherwise = Maybe Ecosystem
forall a. Maybe a
Nothing

    mirrors :: Bool
mirrors = Maybe MirrorTarget -> Bool
forall a. Maybe a -> Bool
isJust (MountRegistries -> Maybe MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount))
    publishes :: Bool
publishes = Maybe PublicationEndpoint -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe PublicationEndpoint
mntPublicationTarget MountConfig
mcfg)

    declaredWithoutPublish :: Bool -> Ecosystem -> Maybe Ecosystem
declaredWithoutPublish Bool
declared Ecosystem
e = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
declared
        adapter <- ResolveMaintenanceAdapter
adapterFor Ecosystem
e
        guard (isNothing (adapterPublish adapter))
        pure e

firstPartyWithoutPrivateUpstream :: (Ecosystem, MountConfig) -> Maybe Ecosystem
firstPartyWithoutPrivateUpstream :: (Ecosystem, MountConfig) -> Maybe Ecosystem
firstPartyWithoutPrivateUpstream (Ecosystem
eco, MountConfig
mcfg) =
    Ecosystem
eco Ecosystem -> Maybe () -> Maybe Ecosystem
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Maybe FirstParty -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe FirstParty
mntFirstParty MountConfig
mcfg) Bool -> Bool -> Bool
&& Maybe PrivateEndpoint -> Bool
forall a. Maybe a -> Bool
isNothing (MountConfig -> Maybe PrivateEndpoint
mntPrivateUpstream MountConfig
mcfg))

{- The two couplings a declared publication target carries: the first-party namespaces the
guard enforces, and the inbound edge a static publish credential needs. -}
vetPublishPolicy :: AppConfig -> Vet (Map Ecosystem (FirstParty, Maybe Secret))
vetPublishPolicy :: AppConfig -> Vet (Map Ecosystem (FirstParty, Maybe Secret))
vetPublishPolicy AppConfig
app =
    [(Ecosystem, (FirstParty, Maybe Secret))]
-> Map Ecosystem (FirstParty, Maybe Secret)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Ecosystem, (FirstParty, Maybe Secret))]
 -> Map Ecosystem (FirstParty, Maybe Secret))
-> ([Maybe (Ecosystem, (FirstParty, Maybe Secret))]
    -> [(Ecosystem, (FirstParty, Maybe Secret))])
-> [Maybe (Ecosystem, (FirstParty, Maybe Secret))]
-> Map Ecosystem (FirstParty, Maybe Secret)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Ecosystem, (FirstParty, Maybe Secret))]
-> [(Ecosystem, (FirstParty, Maybe Secret))]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Ecosystem, (FirstParty, Maybe Secret))]
 -> Map Ecosystem (FirstParty, Maybe Secret))
-> Vet [Maybe (Ecosystem, (FirstParty, Maybe Secret))]
-> Vet (Map Ecosystem (FirstParty, Maybe Secret))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Ecosystem, MountConfig)
 -> Vet (Maybe (Ecosystem, (FirstParty, Maybe Secret))))
-> [(Ecosystem, MountConfig)]
-> Vet [Maybe (Ecosystem, (FirstParty, Maybe Secret))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Maybe Secret
-> (Ecosystem, MountConfig)
-> Vet (Maybe (Ecosystem, (FirstParty, Maybe Secret)))
vetPublication (ServerSettings -> Maybe Secret
srvAuthToken (AppConfig -> ServerSettings
cfgServer AppConfig
app))) [(Ecosystem, MountConfig)]
publishingMounts
  where
    publishingMounts :: [(Ecosystem, MountConfig)]
publishingMounts =
        [ (Ecosystem
eco, MountConfig
mcfg)
        | (Ecosystem
eco, MountConfig
mcfg) <- Map Ecosystem MountConfig -> [(Ecosystem, MountConfig)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app)
        , Maybe PublicationEndpoint -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe PublicationEndpoint
mntPublicationTarget MountConfig
mcfg)
        ]

vetPublication :: Maybe Secret -> (Ecosystem, MountConfig) -> Vet (Maybe (Ecosystem, (FirstParty, Maybe Secret)))
vetPublication :: Maybe Secret
-> (Ecosystem, MountConfig)
-> Vet (Maybe (Ecosystem, (FirstParty, Maybe Secret)))
vetPublication Maybe Secret
inboundToken subject :: (Ecosystem, MountConfig)
subject@(Ecosystem
eco, MountConfig
mcfg) =
    Maybe (Ecosystem, (FirstParty, Maybe Secret))
cleared
        Maybe (Ecosystem, (FirstParty, Maybe Secret))
-> Vet () -> Vet (Maybe (Ecosystem, (FirstParty, Maybe Secret)))
forall a b. a -> Vet b -> Vet a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (RegistryRole -> Severity Ecosystem)
-> ((Ecosystem, MountConfig) -> Maybe Ecosystem)
-> (Ecosystem, MountConfig)
-> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity Ecosystem -> RegistryRole -> Severity Ecosystem
forall a b. a -> b -> a
const ((Ecosystem -> BootError) -> Severity Ecosystem
forall finding. (finding -> BootError) -> Severity finding
Refuse Ecosystem -> BootError
FirstPartyMissing)) (Ecosystem, MountConfig) -> Maybe Ecosystem
firstPartyMissing (Ecosystem, MountConfig)
subject
        Vet (Maybe (Ecosystem, (FirstParty, Maybe Secret)))
-> Vet () -> Vet (Maybe (Ecosystem, (FirstParty, Maybe Secret)))
forall a b. Vet a -> Vet b -> Vet a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (RegistryRole -> Severity (Ecosystem, StoreTag))
-> ((Ecosystem, MountConfig) -> Maybe (Ecosystem, StoreTag))
-> (Ecosystem, MountConfig)
-> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity (Ecosystem, StoreTag)
-> RegistryRole -> Severity (Ecosystem, StoreTag)
forall a b. a -> b -> a
const (((Ecosystem, StoreTag) -> BootError)
-> Severity (Ecosystem, StoreTag)
forall finding. (finding -> BootError) -> Severity finding
Refuse ((Ecosystem -> StoreTag -> BootError)
-> (Ecosystem, StoreTag) -> BootError
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ecosystem -> StoreTag -> BootError
PublishStaticCredentialNeedsEdge))) (Maybe Secret
-> (Ecosystem, MountConfig) -> Maybe (Ecosystem, StoreTag)
staticWithoutEdge Maybe Secret
inboundToken) (Ecosystem, MountConfig)
subject
  where
    cleared :: Maybe (Ecosystem, (FirstParty, Maybe Secret))
cleared = MountConfig -> Maybe FirstParty
mntFirstParty MountConfig
mcfg Maybe FirstParty
-> (FirstParty -> (Ecosystem, (FirstParty, Maybe Secret)))
-> Maybe (Ecosystem, (FirstParty, Maybe Secret))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \FirstParty
firstParty -> (Ecosystem
eco, (FirstParty
firstParty, MountConfig -> Maybe Secret
publicationToken MountConfig
mcfg))

publicationToken :: MountConfig -> Maybe Secret
publicationToken :: MountConfig -> Maybe Secret
publicationToken MountConfig
mcfg = PublicationEndpoint -> Maybe Secret
peToken (PublicationEndpoint -> Maybe Secret)
-> Maybe PublicationEndpoint -> Maybe Secret
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MountConfig -> Maybe PublicationEndpoint
mntPublicationTarget MountConfig
mcfg

firstPartyMissing :: (Ecosystem, MountConfig) -> Maybe Ecosystem
firstPartyMissing :: (Ecosystem, MountConfig) -> Maybe Ecosystem
firstPartyMissing (Ecosystem
eco, MountConfig
mcfg)
    | Maybe FirstParty -> Bool
forall a. Maybe a -> Bool
isNothing (MountConfig -> Maybe FirstParty
mntFirstParty MountConfig
mcfg) = Ecosystem -> Maybe Ecosystem
forall a. a -> Maybe a
Just Ecosystem
eco
    | Bool
otherwise = Maybe Ecosystem
forall a. Maybe a
Nothing

{- Any unauthenticated client could otherwise publish within scope under Écluse's own credential.
The tag rides along, because the credential's key path nests below it. -}
staticWithoutEdge :: Maybe Secret -> (Ecosystem, MountConfig) -> Maybe (Ecosystem, StoreTag)
staticWithoutEdge :: Maybe Secret
-> (Ecosystem, MountConfig) -> Maybe (Ecosystem, StoreTag)
staticWithoutEdge Maybe Secret
inboundToken (Ecosystem
eco, MountConfig
mcfg) = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Maybe Secret -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe Secret
publicationToken MountConfig
mcfg) Bool -> Bool -> Bool
&& Maybe Secret -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Secret
inboundToken)
    endpoint <- MountConfig -> Maybe PublicationEndpoint
mntPublicationTarget MountConfig
mcfg
    pure (eco, tgtTag (peTarget endpoint))