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

{- | A mount's configured upstreams and the tarball-host gate derived from them, as one opaque
cluster with a private constructor.

The 'Ecluse.Core.Security.TarballHostGate' is built once per mount from the three upstream URLs,
so the hot artifact path re-parses nothing. A gate that disagreed with those URLs would silently
authorise the wrong authorities, so 'mountUpstreams' is the only builder and neither the
constructor nor the selectors are exported: an @upstreams{...}@ update alone would break the pair.
-}
module Ecluse.Core.Server.Upstream (
    -- * Mirror serve plan
    MirrorServePlan (..),

    -- * The upstream cluster
    MountUpstreams,
    mountUpstreams,
    upstreamPrivateBaseUrl,
    upstreamPublicBaseUrl,
    upstreamMirror,
    upstreamTarballHostGate,
) where

import Ecluse.Core.Security (TarballHostGate, tarballHostGate)
import Ecluse.Core.Security.Egress (RegistryUrl, registryUrlText)

{- | Whether an admitted public artifact is enqueued for the demand-driven mirror, and where that
write lands. A serve-only mount opens no producer span and emits no enqueue metric.
-}
data MirrorServePlan
    = {- | Enqueue admitted public artifacts for publication to this mirror-target endpoint. The
      worker resolves its publish capability from the same configuration.
      -}
      MirrorOnAdmit RegistryUrl
    | -- | Serve-only: admitted public artifacts stream to the client and are mirrored nowhere.
      NoMirrorWrite
    deriving stock (MirrorServePlan -> MirrorServePlan -> Bool
(MirrorServePlan -> MirrorServePlan -> Bool)
-> (MirrorServePlan -> MirrorServePlan -> Bool)
-> Eq MirrorServePlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MirrorServePlan -> MirrorServePlan -> Bool
== :: MirrorServePlan -> MirrorServePlan -> Bool
$c/= :: MirrorServePlan -> MirrorServePlan -> Bool
/= :: MirrorServePlan -> MirrorServePlan -> Bool
Eq, Int -> MirrorServePlan -> ShowS
[MirrorServePlan] -> ShowS
MirrorServePlan -> String
(Int -> MirrorServePlan -> ShowS)
-> (MirrorServePlan -> String)
-> ([MirrorServePlan] -> ShowS)
-> Show MirrorServePlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MirrorServePlan -> ShowS
showsPrec :: Int -> MirrorServePlan -> ShowS
$cshow :: MirrorServePlan -> String
show :: MirrorServePlan -> String
$cshowList :: [MirrorServePlan] -> ShowS
showList :: [MirrorServePlan] -> ShowS
Show)

{- | A mount's three configured upstreams and the tarball-host gate they derive. Exported
__abstract__, so the carried gate is always the gate of the carried URLs.
-}
data MountUpstreams = MountUpstreams
    { MountUpstreams -> Maybe RegistryUrl
muPrivateBaseUrl :: Maybe RegistryUrl
    , MountUpstreams -> RegistryUrl
muPublicBaseUrl :: RegistryUrl
    , MountUpstreams -> MirrorServePlan
muMirror :: MirrorServePlan
    , MountUpstreams -> TarballHostGate
muTarballHostGate :: TarballHostGate
    }
    deriving stock (MountUpstreams -> MountUpstreams -> Bool
(MountUpstreams -> MountUpstreams -> Bool)
-> (MountUpstreams -> MountUpstreams -> Bool) -> Eq MountUpstreams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MountUpstreams -> MountUpstreams -> Bool
== :: MountUpstreams -> MountUpstreams -> Bool
$c/= :: MountUpstreams -> MountUpstreams -> Bool
/= :: MountUpstreams -> MountUpstreams -> Bool
Eq, Int -> MountUpstreams -> ShowS
[MountUpstreams] -> ShowS
MountUpstreams -> String
(Int -> MountUpstreams -> ShowS)
-> (MountUpstreams -> String)
-> ([MountUpstreams] -> ShowS)
-> Show MountUpstreams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MountUpstreams -> ShowS
showsPrec :: Int -> MountUpstreams -> ShowS
$cshow :: MountUpstreams -> String
show :: MountUpstreams -> String
$cshowList :: [MountUpstreams] -> ShowS
showList :: [MountUpstreams] -> ShowS
Show)

{- | Bind a mount's upstreams. This is the only caller of 'Ecluse.Core.Security.tarballHostGate'
outside that gate's own specs, so the allowlist and the reference authorities have one derivation.
-}
mountUpstreams :: [Text] -> Maybe RegistryUrl -> RegistryUrl -> MirrorServePlan -> MountUpstreams
mountUpstreams :: [Text]
-> Maybe RegistryUrl
-> RegistryUrl
-> MirrorServePlan
-> MountUpstreams
mountUpstreams [Text]
ecosystemHostUrls Maybe RegistryUrl
privateBaseUrl RegistryUrl
publicBaseUrl MirrorServePlan
mirror =
    MountUpstreams
        { muPrivateBaseUrl :: Maybe RegistryUrl
muPrivateBaseUrl = Maybe RegistryUrl
privateBaseUrl
        , muPublicBaseUrl :: RegistryUrl
muPublicBaseUrl = RegistryUrl
publicBaseUrl
        , muMirror :: MirrorServePlan
muMirror = MirrorServePlan
mirror
        , -- The gate reasons over authorities, so it takes the URLs as text. That is the
          -- one place the egress witness is read for its characters.
          muTarballHostGate :: TarballHostGate
muTarballHostGate =
            [Text] -> Maybe Text -> Text -> Maybe Text -> TarballHostGate
tarballHostGate
                [Text]
ecosystemHostUrls
                (RegistryUrl -> Text
registryUrlText (RegistryUrl -> Text) -> Maybe RegistryUrl -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RegistryUrl
privateBaseUrl)
                (RegistryUrl -> Text
registryUrlText RegistryUrl
publicBaseUrl)
                (RegistryUrl -> Text
registryUrlText (RegistryUrl -> Text) -> Maybe RegistryUrl -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MirrorServePlan -> Maybe RegistryUrl
mirrorTargetUrl MirrorServePlan
mirror)
        }

-- The mirror target's URL, or 'Nothing' for a serve-only mount. It is the third
-- authority that feeds the gate's allowlist.
mirrorTargetUrl :: MirrorServePlan -> Maybe RegistryUrl
mirrorTargetUrl :: MirrorServePlan -> Maybe RegistryUrl
mirrorTargetUrl = \case
    MirrorOnAdmit RegistryUrl
url -> RegistryUrl -> Maybe RegistryUrl
forall a. a -> Maybe a
Just RegistryUrl
url
    MirrorServePlan
NoMirrorWrite -> Maybe RegistryUrl
forall a. Maybe a
Nothing

{- | The private upstream base URL. 'Nothing' when the mount has no private upstream, so
the private leg is structurally absent rather than misconfigured.
-}
upstreamPrivateBaseUrl :: MountUpstreams -> Maybe RegistryUrl
upstreamPrivateBaseUrl :: MountUpstreams -> Maybe RegistryUrl
upstreamPrivateBaseUrl = MountUpstreams -> Maybe RegistryUrl
muPrivateBaseUrl

-- | The public upstream base URL.
upstreamPublicBaseUrl :: MountUpstreams -> RegistryUrl
upstreamPublicBaseUrl :: MountUpstreams -> RegistryUrl
upstreamPublicBaseUrl = MountUpstreams -> RegistryUrl
muPublicBaseUrl

-- | The mirror serve plan, carrying the mirror-target endpoint when there is one.
upstreamMirror :: MountUpstreams -> MirrorServePlan
upstreamMirror :: MountUpstreams -> MirrorServePlan
upstreamMirror = MountUpstreams -> MirrorServePlan
muMirror

{- | The tarball-host gate of these upstreams: the canonicalised @host:port@ allowlist and the
private and public reference authorities the per-request SSRF check decides against.
-}
upstreamTarballHostGate :: MountUpstreams -> TarballHostGate
upstreamTarballHostGate :: MountUpstreams -> TarballHostGate
upstreamTarballHostGate = MountUpstreams -> TarballHostGate
muTarballHostGate