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

{- | Every mount's declared endpoints, vetted against each other. A collision between two roles on
one registry is the finding: a publish or a mirror write carries a credential that must not reach
the endpoint it landed on, and a sweep deletes from a store another role owns. Three rules turn on
'RegistryRole': the deleting role and its preview refuse a collision the writing role warns about
or ignores. The rest refuse for every role.
-}
module Ecluse.Composition.Endpoints (
    -- * The endpoint pass
    VettedEndpoints (..),
    vetEndpoints,

    -- * The endpoints it clears
    PublicationTarget,
    publicationTargetUrl,
) where

import Data.Map.Strict qualified as Map

import Ecluse.Composition.BootError (
    Advisory (MirrorTargetOnOwnPublicationTarget, MirrorTargetOnPrivateUpstream),
    BootError (
        MirrorTargetOnMountEndpoint,
        MirrorTargetOnPublicUpstream,
        PrivateUpstreamOnPublicUpstream,
        PublicationTargetOnMountEndpoint,
        PublicationTargetOnPublicUpstream,
        StoreTagConflict
    ),
 )
import Ecluse.Composition.Types (RegistryRole)
import Ecluse.Composition.Vet (
    Severity (Advise, Ignore, Refuse),
    Vet,
    byStoreRole,
    rule,
 )
import Ecluse.Config (
    MountConfig (..),
    PrivateEndpoint (preTarget),
    PublicationEndpoint (peTarget),
    StoreTag (TagRegistry),
    Target (Target, tgtTag, tgtUrl),
    meTarget,
    sameRegistry,
    storeTagName,
 )
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Security (hostAddress)
import Ecluse.Core.Security.Egress (RegistryUrl, registryUrlText)

-- | The endpoints one role's pass cleared it to use, keyed by the mount that declares them.
newtype VettedEndpoints = VettedEndpoints
    { VettedEndpoints -> Map Ecosystem PublicationTarget
vePublicationTargets :: Map Ecosystem PublicationTarget
    -- ^ Each mount's cleared publish endpoint.
    }

{- | Vet every mount's declared endpoints against each other: the refusals and advisories this
role earns, and the endpoints a pass that refused nothing clears it to use.
-}
vetEndpoints :: Map Ecosystem MountConfig -> Vet VettedEndpoints
vetEndpoints :: Map Ecosystem MountConfig -> Vet VettedEndpoints
vetEndpoints Map Ecosystem MountConfig
mounts = VettedEndpoints
cleared VettedEndpoints -> Vet () -> Vet VettedEndpoints
forall a b. a -> Vet b -> Vet a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map Ecosystem MountConfig -> Vet ()
endpointRules Map Ecosystem MountConfig
mounts
  where
    cleared :: VettedEndpoints
cleared = Map Ecosystem PublicationTarget -> VettedEndpoints
VettedEndpoints ((MountConfig -> Maybe PublicationTarget)
-> Map Ecosystem MountConfig -> Map Ecosystem PublicationTarget
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((PublicationEndpoint -> PublicationTarget)
-> Maybe PublicationEndpoint -> Maybe PublicationTarget
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RegistryUrl -> PublicationTarget
PublicationTarget (RegistryUrl -> PublicationTarget)
-> (PublicationEndpoint -> RegistryUrl)
-> PublicationEndpoint
-> PublicationTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> RegistryUrl
tgtUrl (Target -> RegistryUrl)
-> (PublicationEndpoint -> Target)
-> PublicationEndpoint
-> RegistryUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicationEndpoint -> Target
peTarget) (Maybe PublicationEndpoint -> Maybe PublicationTarget)
-> (MountConfig -> Maybe PublicationEndpoint)
-> MountConfig
-> Maybe PublicationTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountConfig -> Maybe PublicationEndpoint
mntPublicationTarget) Map Ecosystem MountConfig
mounts)

-- | A publication target cleared for this role. The relay requires this value, never a configured URL.
newtype PublicationTarget = PublicationTarget RegistryUrl
    deriving stock (PublicationTarget -> PublicationTarget -> Bool
(PublicationTarget -> PublicationTarget -> Bool)
-> (PublicationTarget -> PublicationTarget -> Bool)
-> Eq PublicationTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PublicationTarget -> PublicationTarget -> Bool
== :: PublicationTarget -> PublicationTarget -> Bool
$c/= :: PublicationTarget -> PublicationTarget -> Bool
/= :: PublicationTarget -> PublicationTarget -> Bool
Eq, Int -> PublicationTarget -> ShowS
[PublicationTarget] -> ShowS
PublicationTarget -> String
(Int -> PublicationTarget -> ShowS)
-> (PublicationTarget -> String)
-> ([PublicationTarget] -> ShowS)
-> Show PublicationTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PublicationTarget -> ShowS
showsPrec :: Int -> PublicationTarget -> ShowS
$cshow :: PublicationTarget -> String
show :: PublicationTarget -> String
$cshowList :: [PublicationTarget] -> ShowS
showList :: [PublicationTarget] -> ShowS
Show)

-- | The vetted endpoint the publish relay dials.
publicationTargetUrl :: PublicationTarget -> RegistryUrl
publicationTargetUrl :: PublicationTarget -> RegistryUrl
publicationTargetUrl (PublicationTarget RegistryUrl
url) = RegistryUrl
url

{- Every endpoint rule, in the order a boot report lists them. A mirror target on another mount's
publication target is 'publicationOffNeighbourEndpoints', read from the publishing side. -}
endpointRules :: Map Ecosystem MountConfig -> Vet ()
endpointRules :: Map Ecosystem MountConfig -> Vet ()
endpointRules Map Ecosystem MountConfig
mounts =
    Map Ecosystem MountConfig -> Vet ()
publicationOffPublicUpstreams Map Ecosystem MountConfig
mounts
        Vet () -> Vet () -> Vet ()
forall a b. Vet a -> Vet b -> Vet b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Ecosystem MountConfig -> Vet ()
publicationOffNeighbourEndpoints Map Ecosystem MountConfig
mounts
        Vet () -> Vet () -> Vet ()
forall a b. Vet a -> Vet b -> Vet b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Ecosystem MountConfig -> Vet ()
publicationOffOwnPrivateUpstream Map Ecosystem MountConfig
mounts
        Vet () -> Vet () -> Vet ()
forall a b. Vet a -> Vet b -> Vet b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Ecosystem MountConfig -> Vet ()
mirrorOffPublicUpstreams Map Ecosystem MountConfig
mounts
        Vet () -> Vet () -> Vet ()
forall a b. Vet a -> Vet b -> Vet b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Ecosystem MountConfig -> Vet ()
mirrorOffPrivateUpstreams Map Ecosystem MountConfig
mounts
        Vet () -> Vet () -> Vet ()
forall a b. Vet a -> Vet b -> Vet b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Ecosystem MountConfig -> Vet ()
mirrorOffOwnPublicationTarget Map Ecosystem MountConfig
mounts
        Vet () -> Vet () -> Vet ()
forall a b. Vet a -> Vet b -> Vet b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Ecosystem MountConfig -> Vet ()
privateOffPublicUpstream Map Ecosystem MountConfig
mounts
        Vet () -> Vet () -> Vet ()
forall a b. Vet a -> Vet b -> Vet b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Map Ecosystem MountConfig -> Vet ()
oneTagPerStore Map Ecosystem MountConfig
mounts

-- A publish relays the publisher's own credential, which must never reach a public registry.
publicationOffPublicUpstreams :: Map Ecosystem MountConfig -> Vet ()
publicationOffPublicUpstreams :: Map Ecosystem MountConfig -> Vet ()
publicationOffPublicUpstreams =
    (RegistryRole -> Severity EndpointPair)
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions (Severity EndpointPair -> RegistryRole -> Severity EndpointPair
forall a b. a -> b -> a
const ((EndpointPair -> BootError) -> Severity EndpointPair
forall finding. (finding -> BootError) -> Severity finding
Refuse EndpointPair -> BootError
publicationOnPublicUpstream)) (EndpointComparison -> Map Ecosystem MountConfig -> Vet ())
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
forall a b. (a -> b) -> a -> b
$
        EndpointKey
-> [EndpointKey]
-> MountScope
-> RegistryMatch
-> EndpointComparison
EndpointComparison EndpointKey
KeyPublicationTarget [EndpointKey
KeyPublicUpstream] MountScope
AnyMount RegistryMatch
ByHost

-- A publish must not be relayed into a role the operator declared for something else.
publicationOffNeighbourEndpoints :: Map Ecosystem MountConfig -> Vet ()
publicationOffNeighbourEndpoints :: Map Ecosystem MountConfig -> Vet ()
publicationOffNeighbourEndpoints =
    (RegistryRole -> Severity EndpointPair)
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions (Severity EndpointPair -> RegistryRole -> Severity EndpointPair
forall a b. a -> b -> a
const ((EndpointPair -> BootError) -> Severity EndpointPair
forall finding. (finding -> BootError) -> Severity finding
Refuse EndpointPair -> BootError
publicationOnMountEndpoint)) (EndpointComparison -> Map Ecosystem MountConfig -> Vet ())
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
forall a b. (a -> b) -> a -> b
$
        EndpointKey
-> [EndpointKey]
-> MountScope
-> RegistryMatch
-> EndpointComparison
EndpointComparison
            EndpointKey
KeyPublicationTarget
            [EndpointKey
KeyPrivateUpstream, EndpointKey
KeyMirrorTarget, EndpointKey
KeyPublicationTarget]
            MountScope
OtherMount
            RegistryMatch
ByRegistry

-- Dredger requires the private read cache to be separate from user publications.
publicationOffOwnPrivateUpstream :: Map Ecosystem MountConfig -> Vet ()
publicationOffOwnPrivateUpstream :: Map Ecosystem MountConfig -> Vet ()
publicationOffOwnPrivateUpstream =
    (RegistryRole -> Severity EndpointPair)
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions RegistryRole -> Severity EndpointPair
severity (EndpointComparison -> Map Ecosystem MountConfig -> Vet ())
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
forall a b. (a -> b) -> a -> b
$
        EndpointKey
-> [EndpointKey]
-> MountScope
-> RegistryMatch
-> EndpointComparison
EndpointComparison EndpointKey
KeyPublicationTarget [EndpointKey
KeyPrivateUpstream] MountScope
SameMount RegistryMatch
ByRegistry
  where
    severity :: RegistryRole -> Severity EndpointPair
severity = Severity EndpointPair
-> Severity EndpointPair -> RegistryRole -> Severity EndpointPair
forall finding.
Severity finding
-> Severity finding -> RegistryRole -> Severity finding
byStoreRole ((EndpointPair -> BootError) -> Severity EndpointPair
forall finding. (finding -> BootError) -> Severity finding
Refuse EndpointPair -> BootError
publicationOnMountEndpoint) Severity EndpointPair
forall finding. Severity finding
Ignore

-- The mirror write carries this proxy's own credential, which must never reach a public registry.
mirrorOffPublicUpstreams :: Map Ecosystem MountConfig -> Vet ()
mirrorOffPublicUpstreams :: Map Ecosystem MountConfig -> Vet ()
mirrorOffPublicUpstreams =
    (RegistryRole -> Severity EndpointPair)
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions (Severity EndpointPair -> RegistryRole -> Severity EndpointPair
forall a b. a -> b -> a
const ((EndpointPair -> BootError) -> Severity EndpointPair
forall finding. (finding -> BootError) -> Severity finding
Refuse EndpointPair -> BootError
mirrorOnPublicUpstream)) (EndpointComparison -> Map Ecosystem MountConfig -> Vet ())
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
forall a b. (a -> b) -> a -> b
$
        EndpointKey
-> [EndpointKey]
-> MountScope
-> RegistryMatch
-> EndpointComparison
EndpointComparison EndpointKey
KeyMirrorTarget [EndpointKey
KeyPublicUpstream] MountScope
AnyMount RegistryMatch
ByHost

mirrorOffPrivateUpstreams :: Map Ecosystem MountConfig -> Vet ()
mirrorOffPrivateUpstreams :: Map Ecosystem MountConfig -> Vet ()
mirrorOffPrivateUpstreams =
    (RegistryRole -> Severity EndpointPair)
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions ((EndpointPair -> Advisory) -> RegistryRole -> Severity EndpointPair
mirrorCollapse EndpointPair -> Advisory
mirrorOnPrivateUpstream) (EndpointComparison -> Map Ecosystem MountConfig -> Vet ())
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
forall a b. (a -> b) -> a -> b
$
        EndpointKey
-> [EndpointKey]
-> MountScope
-> RegistryMatch
-> EndpointComparison
EndpointComparison EndpointKey
KeyMirrorTarget [EndpointKey
KeyPrivateUpstream] MountScope
AnyMount RegistryMatch
ByRegistry

mirrorOffOwnPublicationTarget :: Map Ecosystem MountConfig -> Vet ()
mirrorOffOwnPublicationTarget :: Map Ecosystem MountConfig -> Vet ()
mirrorOffOwnPublicationTarget =
    (RegistryRole -> Severity EndpointPair)
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions ((EndpointPair -> Advisory) -> RegistryRole -> Severity EndpointPair
mirrorCollapse EndpointPair -> Advisory
mirrorOnOwnPublicationTarget) (EndpointComparison -> Map Ecosystem MountConfig -> Vet ())
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
forall a b. (a -> b) -> a -> b
$
        EndpointKey
-> [EndpointKey]
-> MountScope
-> RegistryMatch
-> EndpointComparison
EndpointComparison EndpointKey
KeyMirrorTarget [EndpointKey
KeyPublicationTarget] MountScope
SameMount RegistryMatch
ByRegistry

privateOffPublicUpstream :: Map Ecosystem MountConfig -> Vet ()
privateOffPublicUpstream :: Map Ecosystem MountConfig -> Vet ()
privateOffPublicUpstream =
    (RegistryRole -> Severity EndpointPair)
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions (Severity EndpointPair -> RegistryRole -> Severity EndpointPair
forall a b. a -> b -> a
const ((EndpointPair -> BootError) -> Severity EndpointPair
forall finding. (finding -> BootError) -> Severity finding
Refuse EndpointPair -> BootError
privateOnPublicUpstream)) (EndpointComparison -> Map Ecosystem MountConfig -> Vet ())
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
forall a b. (a -> b) -> a -> b
$
        EndpointKey
-> [EndpointKey]
-> MountScope
-> RegistryMatch
-> EndpointComparison
EndpointComparison EndpointKey
KeyPrivateUpstream [EndpointKey
KeyPublicUpstream] MountScope
SameMount RegistryMatch
ByRegistry

{- One store cannot be two backends. It sits outside the comparison table because it puts every
declared endpoint against every other, and each unordered pair is read once. -}
oneTagPerStore :: Map Ecosystem MountConfig -> Vet ()
oneTagPerStore :: Map Ecosystem MountConfig -> Vet ()
oneTagPerStore = (EndpointPair -> Vet ()) -> [EndpointPair] -> Vet ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((RegistryRole -> Severity EndpointPair)
-> (EndpointPair -> Maybe EndpointPair) -> EndpointPair -> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity EndpointPair -> RegistryRole -> Severity EndpointPair
forall a b. a -> b -> a
const ((EndpointPair -> BootError) -> Severity EndpointPair
forall finding. (finding -> BootError) -> Severity finding
Refuse EndpointPair -> BootError
storeTagConflict)) EndpointPair -> Maybe EndpointPair
divergentTag) ([EndpointPair] -> Vet ())
-> (Map Ecosystem MountConfig -> [EndpointPair])
-> Map Ecosystem MountConfig
-> Vet ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Ecosystem MountConfig -> [EndpointPair]
distinctPairs

divergentTag :: EndpointPair -> Maybe EndpointPair
divergentTag :: EndpointPair -> Maybe EndpointPair
divergentTag EndpointPair
pair
    | RegistryUrl -> RegistryUrl -> Bool
sameRegistry (Target -> RegistryUrl
tgtUrl Target
subject) (Target -> RegistryUrl
tgtUrl Target
other), Target -> StoreTag
tgtTag Target
subject StoreTag -> StoreTag -> Bool
forall a. Eq a => a -> a -> Bool
/= Target -> StoreTag
tgtTag Target
other = EndpointPair -> Maybe EndpointPair
forall a. a -> Maybe a
Just EndpointPair
pair
    | Bool
otherwise = Maybe EndpointPair
forall a. Maybe a
Nothing
  where
    subject :: Target
subject = EndpointPair -> Target
epTarget EndpointPair
pair
    other :: Target
other = EndpointPair -> Target
epOtherTarget EndpointPair
pair

storeTagConflict :: EndpointPair -> BootError
storeTagConflict :: EndpointPair -> BootError
storeTagConflict EndpointPair
pair =
    Ecosystem -> Text -> Ecosystem -> Text -> Text -> BootError
StoreTagConflict
        (EndpointPair -> Ecosystem
epMount EndpointPair
pair)
        (EndpointKey -> Target -> Text
taggedKeyName (EndpointPair -> EndpointKey
epKey EndpointPair
pair) (EndpointPair -> Target
epTarget EndpointPair
pair))
        (EndpointPair -> Ecosystem
epOtherMount EndpointPair
pair)
        (EndpointKey -> Target -> Text
taggedKeyName (EndpointPair -> EndpointKey
epOtherKey EndpointPair
pair) (EndpointPair -> Target
epOtherTarget EndpointPair
pair))
        (RegistryUrl -> Text
registryUrlText (Target -> RegistryUrl
tgtUrl (EndpointPair -> Target
epTarget EndpointPair
pair)))

{- A mirror target on another declared endpoint: the deleting role refuses, its preview refuses
under the same reading, and the writing roles warn. -}
mirrorCollapse :: (EndpointPair -> Advisory) -> RegistryRole -> Severity EndpointPair
mirrorCollapse :: (EndpointPair -> Advisory) -> RegistryRole -> Severity EndpointPair
mirrorCollapse EndpointPair -> Advisory
toAdvisory = Severity EndpointPair
-> Severity EndpointPair -> RegistryRole -> Severity EndpointPair
forall finding.
Severity finding
-> Severity finding -> RegistryRole -> Severity finding
byStoreRole ((EndpointPair -> BootError) -> Severity EndpointPair
forall finding. (finding -> BootError) -> Severity finding
Refuse EndpointPair -> BootError
mirrorOnMountEndpoint) ((EndpointPair -> Advisory) -> Severity EndpointPair
forall finding. (finding -> Advisory) -> Severity finding
Advise EndpointPair -> Advisory
toAdvisory)

{- Each advisory carries the mirror target's own URL, so the warning quotes the spelling the
mount configured rather than the endpoint it collided with. -}
mirrorOnPrivateUpstream :: EndpointPair -> Advisory
mirrorOnPrivateUpstream :: EndpointPair -> Advisory
mirrorOnPrivateUpstream EndpointPair
pair =
    Ecosystem -> Ecosystem -> RegistryUrl -> Advisory
MirrorTargetOnPrivateUpstream (EndpointPair -> Ecosystem
epMount EndpointPair
pair) (EndpointPair -> Ecosystem
epOtherMount EndpointPair
pair) (Target -> RegistryUrl
tgtUrl (EndpointPair -> Target
epTarget EndpointPair
pair))

mirrorOnOwnPublicationTarget :: EndpointPair -> Advisory
mirrorOnOwnPublicationTarget :: EndpointPair -> Advisory
mirrorOnOwnPublicationTarget EndpointPair
pair =
    Ecosystem -> RegistryUrl -> Advisory
MirrorTargetOnOwnPublicationTarget (EndpointPair -> Ecosystem
epMount EndpointPair
pair) (Target -> RegistryUrl
tgtUrl (EndpointPair -> Target
epTarget EndpointPair
pair))

publicationOnPublicUpstream :: EndpointPair -> BootError
publicationOnPublicUpstream :: EndpointPair -> BootError
publicationOnPublicUpstream EndpointPair
pair =
    Ecosystem -> Ecosystem -> Text -> BootError
PublicationTargetOnPublicUpstream (EndpointPair -> Ecosystem
epMount EndpointPair
pair) (EndpointPair -> Ecosystem
epOtherMount EndpointPair
pair) (EndpointPair -> Text
pairRegistry EndpointPair
pair)

publicationOnMountEndpoint :: EndpointPair -> BootError
publicationOnMountEndpoint :: EndpointPair -> BootError
publicationOnMountEndpoint EndpointPair
pair =
    Ecosystem -> Ecosystem -> Text -> Text -> BootError
PublicationTargetOnMountEndpoint
        (EndpointPair -> Ecosystem
epMount EndpointPair
pair)
        (EndpointPair -> Ecosystem
epOtherMount EndpointPair
pair)
        (EndpointKey -> Text
endpointKeyName (EndpointPair -> EndpointKey
epOtherKey EndpointPair
pair))
        (EndpointPair -> Text
pairRegistry EndpointPair
pair)

mirrorOnPublicUpstream :: EndpointPair -> BootError
mirrorOnPublicUpstream :: EndpointPair -> BootError
mirrorOnPublicUpstream EndpointPair
pair =
    Ecosystem -> Ecosystem -> Text -> BootError
MirrorTargetOnPublicUpstream (EndpointPair -> Ecosystem
epMount EndpointPair
pair) (EndpointPair -> Ecosystem
epOtherMount EndpointPair
pair) (EndpointPair -> Text
pairRegistry EndpointPair
pair)

privateOnPublicUpstream :: EndpointPair -> BootError
privateOnPublicUpstream :: EndpointPair -> BootError
privateOnPublicUpstream EndpointPair
pair =
    Ecosystem -> Text -> BootError
PrivateUpstreamOnPublicUpstream (EndpointPair -> Ecosystem
epMount EndpointPair
pair) (EndpointPair -> Text
pairRegistry EndpointPair
pair)

-- A sweep deletes from the mirror target, so a store another role holds loses that role's data.
mirrorOnMountEndpoint :: EndpointPair -> BootError
mirrorOnMountEndpoint :: EndpointPair -> BootError
mirrorOnMountEndpoint EndpointPair
pair =
    Ecosystem -> Ecosystem -> Text -> Text -> BootError
MirrorTargetOnMountEndpoint
        (EndpointPair -> Ecosystem
epMount EndpointPair
pair)
        (EndpointPair -> Ecosystem
epOtherMount EndpointPair
pair)
        (EndpointKey -> Text
endpointKeyName (EndpointPair -> EndpointKey
epOtherKey EndpointPair
pair))
        (EndpointPair -> Text
pairRegistry EndpointPair
pair)

pairRegistry :: EndpointPair -> Text
pairRegistry :: EndpointPair -> Text
pairRegistry = RegistryUrl -> Text
registryUrlText (RegistryUrl -> Text)
-> (EndpointPair -> RegistryUrl) -> EndpointPair -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> RegistryUrl
tgtUrl (Target -> RegistryUrl)
-> (EndpointPair -> Target) -> EndpointPair -> RegistryUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EndpointPair -> Target
epTarget

-- A registry endpoint of a mount, named by the key the configuration declares it under.
data EndpointKey
    = KeyPublicUpstream
    | KeyPrivateUpstream
    | KeyMirrorTarget
    | KeyPublicationTarget
    deriving stock (EndpointKey -> EndpointKey -> Bool
(EndpointKey -> EndpointKey -> Bool)
-> (EndpointKey -> EndpointKey -> Bool) -> Eq EndpointKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EndpointKey -> EndpointKey -> Bool
== :: EndpointKey -> EndpointKey -> Bool
$c/= :: EndpointKey -> EndpointKey -> Bool
/= :: EndpointKey -> EndpointKey -> Bool
Eq, Int -> EndpointKey -> ShowS
[EndpointKey] -> ShowS
EndpointKey -> String
(Int -> EndpointKey -> ShowS)
-> (EndpointKey -> String)
-> ([EndpointKey] -> ShowS)
-> Show EndpointKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EndpointKey -> ShowS
showsPrec :: Int -> EndpointKey -> ShowS
$cshow :: EndpointKey -> String
show :: EndpointKey -> String
$cshowList :: [EndpointKey] -> ShowS
showList :: [EndpointKey] -> ShowS
Show)

-- Which mounts a rule compares: one mount's own endpoints, its neighbours', or both.
data MountScope = SameMount | OtherMount | AnyMount
    deriving stock (MountScope -> MountScope -> Bool
(MountScope -> MountScope -> Bool)
-> (MountScope -> MountScope -> Bool) -> Eq MountScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MountScope -> MountScope -> Bool
== :: MountScope -> MountScope -> Bool
$c/= :: MountScope -> MountScope -> Bool
/= :: MountScope -> MountScope -> Bool
Eq, Int -> MountScope -> ShowS
[MountScope] -> ShowS
MountScope -> String
(Int -> MountScope -> ShowS)
-> (MountScope -> String)
-> ([MountScope] -> ShowS)
-> Show MountScope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MountScope -> ShowS
showsPrec :: Int -> MountScope -> ShowS
$cshow :: MountScope -> String
show :: MountScope -> String
$cshowList :: [MountScope] -> ShowS
showList :: [MountScope] -> ShowS
Show)

{- How a rule compares two endpoints. Full-URL equality is what store identity needs, because
CodeArtifact repositories share one domain and differ only in path. -}
data RegistryMatch = ByHost | ByRegistry
    deriving stock (RegistryMatch -> RegistryMatch -> Bool
(RegistryMatch -> RegistryMatch -> Bool)
-> (RegistryMatch -> RegistryMatch -> Bool) -> Eq RegistryMatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RegistryMatch -> RegistryMatch -> Bool
== :: RegistryMatch -> RegistryMatch -> Bool
$c/= :: RegistryMatch -> RegistryMatch -> Bool
/= :: RegistryMatch -> RegistryMatch -> Bool
Eq, Int -> RegistryMatch -> ShowS
[RegistryMatch] -> ShowS
RegistryMatch -> String
(Int -> RegistryMatch -> ShowS)
-> (RegistryMatch -> String)
-> ([RegistryMatch] -> ShowS)
-> Show RegistryMatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RegistryMatch -> ShowS
showsPrec :: Int -> RegistryMatch -> ShowS
$cshow :: RegistryMatch -> String
show :: RegistryMatch -> String
$cshowList :: [RegistryMatch] -> ShowS
showList :: [RegistryMatch] -> ShowS
Show)

{- Which endpoints a rule puts against each other: the key whose role is at stake, the keys it
must not land on, the mounts those keys are read from, and how the two are compared. -}
data EndpointComparison = EndpointComparison
    { EndpointComparison -> EndpointKey
cmpSubject :: EndpointKey
    , EndpointComparison -> [EndpointKey]
cmpAgainst :: [EndpointKey]
    , EndpointComparison -> MountScope
cmpScope :: MountScope
    , EndpointComparison -> RegistryMatch
cmpMatch :: RegistryMatch
    }

-- Two declared endpoints a comparison reads side by side, each named by its mount and its key.
data EndpointPair = EndpointPair
    { EndpointPair -> Ecosystem
epMount :: Ecosystem
    , EndpointPair -> EndpointKey
epKey :: EndpointKey
    , EndpointPair -> Target
epTarget :: Target
    , EndpointPair -> Ecosystem
epOtherMount :: Ecosystem
    , EndpointPair -> EndpointKey
epOtherKey :: EndpointKey
    , EndpointPair -> Target
epOtherTarget :: Target
    }

vetCollisions :: (RegistryRole -> Severity EndpointPair) -> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions :: (RegistryRole -> Severity EndpointPair)
-> EndpointComparison -> Map Ecosystem MountConfig -> Vet ()
vetCollisions RegistryRole -> Severity EndpointPair
severity EndpointComparison
cmp Map Ecosystem MountConfig
mounts =
    (EndpointPair -> Vet ()) -> [EndpointPair] -> Vet ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((RegistryRole -> Severity EndpointPair)
-> (EndpointPair -> Maybe EndpointPair) -> EndpointPair -> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule RegistryRole -> Severity EndpointPair
severity (RegistryMatch -> EndpointPair -> Maybe EndpointPair
collidingPair (EndpointComparison -> RegistryMatch
cmpMatch EndpointComparison
cmp))) (EndpointComparison -> Map Ecosystem MountConfig -> [EndpointPair]
comparedPairs EndpointComparison
cmp Map Ecosystem MountConfig
mounts)

comparedPairs :: EndpointComparison -> Map Ecosystem MountConfig -> [EndpointPair]
comparedPairs :: EndpointComparison -> Map Ecosystem MountConfig -> [EndpointPair]
comparedPairs EndpointComparison
cmp Map Ecosystem MountConfig
mounts =
    [ Ecosystem
-> EndpointKey
-> Target
-> Ecosystem
-> EndpointKey
-> Target
-> EndpointPair
EndpointPair Ecosystem
eco (EndpointComparison -> EndpointKey
cmpSubject EndpointComparison
cmp) Target
target Ecosystem
other EndpointKey
otherKey Target
otherTarget
    | (Ecosystem
eco, MountConfig
mcfg) <- Map Ecosystem MountConfig -> [(Ecosystem, MountConfig)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Ecosystem MountConfig
mounts
    , Just Target
target <- [EndpointKey -> MountConfig -> Maybe Target
endpointOf (EndpointComparison -> EndpointKey
cmpSubject EndpointComparison
cmp) MountConfig
mcfg]
    , (Ecosystem
other, MountConfig
otherCfg) <- Map Ecosystem MountConfig -> [(Ecosystem, MountConfig)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Ecosystem MountConfig
mounts
    , MountScope -> Ecosystem -> Ecosystem -> Bool
withinScope (EndpointComparison -> MountScope
cmpScope EndpointComparison
cmp) Ecosystem
eco Ecosystem
other
    , EndpointKey
otherKey <- EndpointComparison -> [EndpointKey]
cmpAgainst EndpointComparison
cmp
    , Just Target
otherTarget <- [EndpointKey -> MountConfig -> Maybe Target
endpointOf EndpointKey
otherKey MountConfig
otherCfg]
    ]

-- Each unordered pair of declared endpoints once, so one collision earns one refusal.
distinctPairs :: Map Ecosystem MountConfig -> [EndpointPair]
distinctPairs :: Map Ecosystem MountConfig -> [EndpointPair]
distinctPairs Map Ecosystem MountConfig
mounts =
    [ Ecosystem
-> EndpointKey
-> Target
-> Ecosystem
-> EndpointKey
-> Target
-> EndpointPair
EndpointPair Ecosystem
eco EndpointKey
key Target
target Ecosystem
other EndpointKey
otherKey Target
otherTarget
    | (Ecosystem
eco, EndpointKey
key, Target
target) : [(Ecosystem, EndpointKey, Target)]
rest <- [(Ecosystem, EndpointKey, Target)]
-> [[(Ecosystem, EndpointKey, Target)]]
forall a. [a] -> [[a]]
tails (Map Ecosystem MountConfig -> [(Ecosystem, EndpointKey, Target)]
declaredEndpoints Map Ecosystem MountConfig
mounts)
    , (Ecosystem
other, EndpointKey
otherKey, Target
otherTarget) <- [(Ecosystem, EndpointKey, Target)]
rest
    ]

declaredEndpoints :: Map Ecosystem MountConfig -> [(Ecosystem, EndpointKey, Target)]
declaredEndpoints :: Map Ecosystem MountConfig -> [(Ecosystem, EndpointKey, Target)]
declaredEndpoints Map Ecosystem MountConfig
mounts =
    [ (Ecosystem
eco, EndpointKey
key, Target
target)
    | (Ecosystem
eco, MountConfig
mcfg) <- Map Ecosystem MountConfig -> [(Ecosystem, MountConfig)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Ecosystem MountConfig
mounts
    , EndpointKey
key <- [EndpointKey
KeyPublicUpstream, EndpointKey
KeyPrivateUpstream, EndpointKey
KeyMirrorTarget, EndpointKey
KeyPublicationTarget]
    , Just Target
target <- [EndpointKey -> MountConfig -> Maybe Target
endpointOf EndpointKey
key MountConfig
mcfg]
    ]

collidingPair :: RegistryMatch -> EndpointPair -> Maybe EndpointPair
collidingPair :: RegistryMatch -> EndpointPair -> Maybe EndpointPair
collidingPair RegistryMatch
match EndpointPair
pair
    | RegistryMatch -> RegistryUrl -> RegistryUrl -> Bool
sameStore RegistryMatch
match (Target -> RegistryUrl
tgtUrl (EndpointPair -> Target
epTarget EndpointPair
pair)) (Target -> RegistryUrl
tgtUrl (EndpointPair -> Target
epOtherTarget EndpointPair
pair)) = EndpointPair -> Maybe EndpointPair
forall a. a -> Maybe a
Just EndpointPair
pair
    | Bool
otherwise = Maybe EndpointPair
forall a. Maybe a
Nothing

{- The endpoint a mount declares under one key. Only @registry@ is admitted on the public
upstream, so its tag is the one the parser pinned rather than one the mount wrote. -}
endpointOf :: EndpointKey -> MountConfig -> Maybe Target
endpointOf :: EndpointKey -> MountConfig -> Maybe Target
endpointOf EndpointKey
key MountConfig
mcfg = case EndpointKey
key of
    EndpointKey
KeyPublicUpstream -> Target -> Maybe Target
forall a. a -> Maybe a
Just (StoreTag -> RegistryUrl -> Target
Target StoreTag
TagRegistry (MountConfig -> RegistryUrl
mntPublicUpstream MountConfig
mcfg))
    EndpointKey
KeyPrivateUpstream -> PrivateEndpoint -> Target
preTarget (PrivateEndpoint -> Target)
-> Maybe PrivateEndpoint -> Maybe Target
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MountConfig -> Maybe PrivateEndpoint
mntPrivateUpstream MountConfig
mcfg
    EndpointKey
KeyMirrorTarget -> MirrorEndpoint -> Target
meTarget (MirrorEndpoint -> Target) -> Maybe MirrorEndpoint -> Maybe Target
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MountConfig -> Maybe MirrorEndpoint
mntMirrorTarget MountConfig
mcfg
    EndpointKey
KeyPublicationTarget -> PublicationEndpoint -> Target
peTarget (PublicationEndpoint -> Target)
-> Maybe PublicationEndpoint -> Maybe Target
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MountConfig -> Maybe PublicationEndpoint
mntPublicationTarget MountConfig
mcfg

withinScope :: MountScope -> Ecosystem -> Ecosystem -> Bool
withinScope :: MountScope -> Ecosystem -> Ecosystem -> Bool
withinScope MountScope
scope Ecosystem
eco Ecosystem
other = case MountScope
scope of
    MountScope
SameMount -> Ecosystem
eco Ecosystem -> Ecosystem -> Bool
forall a. Eq a => a -> a -> Bool
== Ecosystem
other
    MountScope
OtherMount -> Ecosystem
eco Ecosystem -> Ecosystem -> Bool
forall a. Eq a => a -> a -> Bool
/= Ecosystem
other
    MountScope
AnyMount -> Bool
True

sameStore :: RegistryMatch -> RegistryUrl -> RegistryUrl -> Bool
sameStore :: RegistryMatch -> RegistryUrl -> RegistryUrl -> Bool
sameStore = \case
    RegistryMatch
ByHost -> RegistryUrl -> RegistryUrl -> Bool
sameHost
    RegistryMatch
ByRegistry -> RegistryUrl -> RegistryUrl -> Bool
sameRegistry

{- Whether two endpoints dial the same host, compared case-insensitively. An unreadable authority
yields the empty host, which matches no real one, so that endpoint fails later at the relay. -}
sameHost :: RegistryUrl -> RegistryUrl -> Bool
sameHost :: RegistryUrl -> RegistryUrl -> Bool
sameHost RegistryUrl
a RegistryUrl
b = RegistryUrl -> Text
hostOf RegistryUrl
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== RegistryUrl -> Text
hostOf RegistryUrl
b
  where
    hostOf :: RegistryUrl -> Text
hostOf = Text -> Text
hostAddress (Text -> Text) -> (RegistryUrl -> Text) -> RegistryUrl -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegistryUrl -> Text
registryUrlText

endpointKeyName :: EndpointKey -> Text
endpointKeyName :: EndpointKey -> Text
endpointKeyName = \case
    EndpointKey
KeyPublicUpstream -> Text
"publicUpstream"
    EndpointKey
KeyPrivateUpstream -> Text
"privateUpstream"
    EndpointKey
KeyMirrorTarget -> Text
"mirrorTarget"
    EndpointKey
KeyPublicationTarget -> Text
"publicationTarget"

-- The key path down to the tag, the depth a tag refusal must name to be actionable.
taggedKeyName :: EndpointKey -> Target -> Text
taggedKeyName :: EndpointKey -> Target -> Text
taggedKeyName EndpointKey
key Target
target = EndpointKey -> Text
endpointKeyName EndpointKey
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreTag -> Text
storeTagName (Target -> StoreTag
tgtTag Target
target)