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

{- | Resolve a mount's declared endpoints against the store tag each one names.

The tag is the declaration, and the URL is checked against it. A @codeArtifact@ endpoint must carry
the CodeArtifact host shape and, as mirror target or private upstream, address a repository under
the mount's own package format, because a repository's per-format endpoints are separate stores.
Every other tag admits any https registry the egress boundary cleared. Each refusal names the key,
so a store this build cannot address is refused at load rather than at the first write.
-}
module Ecluse.Config.Target (
    -- * Resolution
    resolveStoreBackend,
    resolvePrivateBackend,
    vetTargetTag,
    vetPrivateRepository,
    parseCodeArtifactHost,
    isAccountId,
) where

import Data.Char (isDigit)
import Data.Text qualified as T

import Ecluse.Config.Types (
    ConfigError (..),
    MirrorEndpoint (..),
    MirrorWrite (..),
    StoreBackend (..),
    StoreTag (..),
    Target (..),
 )
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Security (hostAddress)
import Ecluse.Core.Security.Egress (RegistryUrl, registryUrlText)
import Ecluse.Core.Text (nonBlank, registryPath)
import Ecluse.Runtime.Credential.CodeArtifact (CodeArtifactConfig (..))
import Ecluse.Runtime.Maintenance.CodeArtifact.Decide (
    CodeArtifactStore (..),
    codeArtifactFormat,
    formatToken,
 )

{- | Resolve a mirror target's store backend from the tag it declares. Only the CodeArtifact arm
reads the URL, and it refuses one that addresses no repository this mount could mirror into.
-}
resolveStoreBackend :: Ecosystem -> MirrorEndpoint -> Either ConfigError StoreBackend
resolveStoreBackend :: Ecosystem -> MirrorEndpoint -> Either ConfigError StoreBackend
resolveStoreBackend Ecosystem
eco MirrorEndpoint
endpoint = case MirrorEndpoint -> MirrorWrite
meWrite MirrorEndpoint
endpoint of
    WriteRegistry Secret
token -> StoreBackend -> Either ConfigError StoreBackend
forall a b. b -> Either a b
Right (Secret -> StoreBackend
BackendRegistry Secret
token)
    WriteVerdaccio Secret
token DeletionConsent
consent -> StoreBackend -> Either ConfigError StoreBackend
forall a b. b -> Either a b
Right (Secret -> DeletionConsent -> StoreBackend
BackendVerdaccio Secret
token DeletionConsent
consent)
    WriteCodeArtifact Maybe Natural
mDuration -> do
        (domain, owner, region) <- Ecosystem
-> Text -> RegistryUrl -> Either ConfigError (Text, Text, Text)
codeArtifactHost Ecosystem
eco Text
mirrorTargetKey (MirrorEndpoint -> RegistryUrl
meUrl MirrorEndpoint
endpoint)
        store <- codeArtifactStore eco mirrorTargetKey (registryUrlText (meUrl endpoint)) domain owner region
        Right (BackendCodeArtifact (mintIdentity domain owner region mDuration) store)

{- | Resolve a private target already classified as CodeArtifact, using the default token lifetime.
The repository is returned beside the backend, so a caller needs no second read of the control plane.
-}
resolvePrivateBackend :: Ecosystem -> Target -> Either ConfigError (StoreBackend, CodeArtifactStore)
resolvePrivateBackend :: Ecosystem
-> Target -> Either ConfigError (StoreBackend, CodeArtifactStore)
resolvePrivateBackend Ecosystem
eco Target
target = do
    (domain, owner, region) <- Ecosystem
-> Text -> RegistryUrl -> Either ConfigError (Text, Text, Text)
codeArtifactHost Ecosystem
eco Text
privateUpstreamKey (Target -> RegistryUrl
tgtUrl Target
target)
    store <- codeArtifactStore eco privateUpstreamKey (registryUrlText (tgtUrl target)) domain owner region
    pure (BackendCodeArtifact (mintIdentity domain owner region Nothing) store, store)

{- | Vet a read or publish endpoint's URL against its declared tag. Only @codeArtifact@ constrains
the host, and only a mirror target constrains the path, so this is total over the other tags.
-}
vetTargetTag :: Ecosystem -> Text -> Target -> Either ConfigError ()
vetTargetTag :: Ecosystem -> Text -> Target -> Either ConfigError ()
vetTargetTag Ecosystem
eco Text
key Target
target = case Target -> StoreTag
tgtTag Target
target of
    StoreTag
TagCodeArtifact -> Either ConfigError (Text, Text, Text) -> Either ConfigError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ecosystem
-> Text -> RegistryUrl -> Either ConfigError (Text, Text, Text)
codeArtifactHost Ecosystem
eco Text
key (Target -> RegistryUrl
tgtUrl Target
target))
    StoreTag
TagRegistry -> () -> Either ConfigError ()
forall a b. b -> Either a b
Right ()
    StoreTag
TagVerdaccio -> () -> Either ConfigError ()
forall a b. b -> Either a b
Right ()

{- | Vet a declared private upstream past its tag. A @codeArtifact@ one must address a repository
under the mount's own format, because the boot asks that repository what content it aggregates.
-}
vetPrivateRepository :: Ecosystem -> Target -> Either ConfigError ()
vetPrivateRepository :: Ecosystem -> Target -> Either ConfigError ()
vetPrivateRepository Ecosystem
eco Target
target = case Target -> StoreTag
tgtTag Target
target of
    -- The host is 'vetTargetTag''s to report, so a bad one is left to it rather than named twice.
    StoreTag
TagCodeArtifact | Either ConfigError (Text, Text, Text) -> Bool
forall a b. Either a b -> Bool
isRight (Ecosystem
-> Text -> RegistryUrl -> Either ConfigError (Text, Text, Text)
codeArtifactHost Ecosystem
eco Text
privateUpstreamKey (Target -> RegistryUrl
tgtUrl Target
target)) -> Either ConfigError (StoreBackend, CodeArtifactStore)
-> Either ConfigError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ecosystem
-> Target -> Either ConfigError (StoreBackend, CodeArtifactStore)
resolvePrivateBackend Ecosystem
eco Target
target)
    StoreTag
_ -> () -> Either ConfigError ()
forall a b. b -> Either a b
Right ()

-- The key a private upstream is declared under, which every refusal of one is reported at.
privateUpstreamKey :: Text
privateUpstreamKey :: Text
privateUpstreamKey = Text
"privateUpstream"

-- The key a mirror target is declared under, which every refusal of one is reported at.
mirrorTargetKey :: Text
mirrorTargetKey :: Text
mirrorTargetKey = Text
"mirrorTarget"

-- The mint identity a CodeArtifact host carries, with the lifetime the operator asked for.
mintIdentity :: Text -> Text -> Text -> Maybe Natural -> CodeArtifactConfig
mintIdentity :: Text -> Text -> Text -> Maybe Natural -> CodeArtifactConfig
mintIdentity Text
domain Text
owner Text
region Maybe Natural
mDuration =
    CodeArtifactConfig
        { caRegion :: Text
caRegion = Text
region
        , caDomain :: Text
caDomain = Text
domain
        , caDomainOwner :: Maybe Text
caDomainOwner = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
owner
        , caDurationSeconds :: Maybe Natural
caDurationSeconds = Maybe Natural
mDuration
        }

-- The CodeArtifact identity a target's host carries, refused under the key it was written at.
codeArtifactHost :: Ecosystem -> Text -> RegistryUrl -> Either ConfigError (Text, Text, Text)
codeArtifactHost :: Ecosystem
-> Text -> RegistryUrl -> Either ConfigError (Text, Text, Text)
codeArtifactHost Ecosystem
eco Text
key RegistryUrl
url =
    ConfigError
-> Maybe (Text, Text, Text)
-> Either ConfigError (Text, Text, Text)
forall l r. l -> Maybe r -> Either l r
maybeToRight
        (Ecosystem -> Text -> ConfigError
CodeArtifactHostMismatch Ecosystem
eco (Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".codeArtifact.url"))
        (Text -> Maybe (Text, Text, Text)
parseCodeArtifactHost (Text -> Text
hostAddress (RegistryUrl -> Text
registryUrlText RegistryUrl
url)))

-- The repository an endpoint addresses, under the format token its mount's ecosystem maps to.
codeArtifactStore :: Ecosystem -> Text -> Text -> Text -> Text -> Text -> Either ConfigError CodeArtifactStore
codeArtifactStore :: Ecosystem
-> Text
-> Text
-> Text
-> Text
-> Text
-> Either ConfigError CodeArtifactStore
codeArtifactStore Ecosystem
eco Text
key Text
raw Text
domain Text
owner Text
region = do
    format <- ConfigError
-> Maybe CodeArtifactFormat
-> Either ConfigError CodeArtifactFormat
forall l r. l -> Maybe r -> Either l r
maybeToRight (Ecosystem -> Text -> ConfigError
CodeArtifactFormatUnsupported Ecosystem
eco Text
urlPath) (Ecosystem -> Maybe CodeArtifactFormat
codeArtifactFormat Ecosystem
eco)
    repository <-
        maybeToRight
            (CodeArtifactRepositoryMissing eco urlPath (formatToken format))
            (repositoryOfPath (formatToken format) raw)
    pure
        CodeArtifactStore
            { casDomain = domain
            , casDomainOwner = owner
            , casRegion = region
            , casRepository = repository
            , casFormat = format
            }
  where
    urlPath :: Text
urlPath = Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".codeArtifact.url"

-- The repository a CodeArtifact endpoint path names, under the expected format segment.
repositoryOfPath :: Text -> Text -> Maybe Text
repositoryOfPath :: Text -> Text -> Maybe Text
repositoryOfPath Text
format Text
url = case Text -> [Text]
pathSegments Text
url of
    [Text
pathFormat, Text
repository] | Text
pathFormat Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
format -> Text -> Maybe Text
nonBlank Text
repository
    [Text]
_ -> Maybe Text
forall a. Maybe a
Nothing

-- The non-empty path segments of an absolute URL, which the egress boundary has already vetted.
pathSegments :: Text -> [Text]
pathSegments :: Text -> [Text]
pathSegments = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
registryPath

{- | Parse @{domain}-{owner}.d.codeartifact.{region}.amazonaws.com@ into (domain, owner, region).
The owner is the 12-digit account id after the __last__ hyphen, so a domain may carry them.
-}
parseCodeArtifactHost :: Text -> Maybe (Text, Text, Text)
parseCodeArtifactHost :: Text -> Maybe (Text, Text, Text)
parseCodeArtifactHost Text
host =
    -- The accepted shape carries exactly one @.d.codeartifact.@ marker. Any other count is not
    -- a CodeArtifact endpoint, refused here rather than by an implicit pattern-match failure.
    case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
".d.codeartifact." Text
host of
        [Text
domainOwner, Text
regionTail] -> do
            region <- Text -> Maybe Text
nonBlank (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Text -> Maybe Text
T.stripSuffix Text
".amazonaws.com" Text
regionTail
            let (domainDash, owner) = T.breakOnEnd "-" domainOwner
            domain <- nonBlank (T.dropEnd 1 domainDash)
            guard (isAccountId owner)
            pure (domain, owner, region)
        [Text]
_ -> Maybe (Text, Text, Text)
forall a. Maybe a
Nothing

{- | Whether a value is a 12-digit AWS account id (shared with the SQS queue-URL
shape validation in "Ecluse.Config.QueueTarget").
-}
isAccountId :: Text -> Bool
isAccountId :: Text -> Bool
isAccountId Text
t = Text -> Int -> Ordering
T.compareLength Text
t Int
12 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
t