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

{- | The private construction boundary for 'RegistryUrl'.

@ecluse-core@ does not expose this module (it is an @other-module@), so the raw constructor is
reachable only from inside the library. "Ecluse.Core.Security.Egress" re-exports the type
abstractly with the https-only builders, and the loopback builder in
"Ecluse.Core.Security.Egress.DevHttp" compiles only under the @dev-http-egress@ Cabal flag.
-}
module Ecluse.Core.Security.Egress.Internal (
    RegistryUrl (..),
    mkRegistryUrl,
    mkConfiguredRegistryUrl,
    registryUrlText,
) where

import Data.Text qualified as T

import Ecluse.Core.Security.Authority (refuseCredentialMaterial)
import Ecluse.Core.Text (httpsPrefix, isPrefixOfLowered)

{- | An outbound registry-egress URL, https by construction and stored with surrounding
whitespace trimmed. A plain-HTTP registry target cannot be represented in a running system.
-}
newtype RegistryUrl = RegistryUrl Text
    deriving stock (RegistryUrl -> RegistryUrl -> Bool
(RegistryUrl -> RegistryUrl -> Bool)
-> (RegistryUrl -> RegistryUrl -> Bool) -> Eq RegistryUrl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RegistryUrl -> RegistryUrl -> Bool
== :: RegistryUrl -> RegistryUrl -> Bool
$c/= :: RegistryUrl -> RegistryUrl -> Bool
/= :: RegistryUrl -> RegistryUrl -> Bool
Eq, Eq RegistryUrl
Eq RegistryUrl =>
(RegistryUrl -> RegistryUrl -> Ordering)
-> (RegistryUrl -> RegistryUrl -> Bool)
-> (RegistryUrl -> RegistryUrl -> Bool)
-> (RegistryUrl -> RegistryUrl -> Bool)
-> (RegistryUrl -> RegistryUrl -> Bool)
-> (RegistryUrl -> RegistryUrl -> RegistryUrl)
-> (RegistryUrl -> RegistryUrl -> RegistryUrl)
-> Ord RegistryUrl
RegistryUrl -> RegistryUrl -> Bool
RegistryUrl -> RegistryUrl -> Ordering
RegistryUrl -> RegistryUrl -> RegistryUrl
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RegistryUrl -> RegistryUrl -> Ordering
compare :: RegistryUrl -> RegistryUrl -> Ordering
$c< :: RegistryUrl -> RegistryUrl -> Bool
< :: RegistryUrl -> RegistryUrl -> Bool
$c<= :: RegistryUrl -> RegistryUrl -> Bool
<= :: RegistryUrl -> RegistryUrl -> Bool
$c> :: RegistryUrl -> RegistryUrl -> Bool
> :: RegistryUrl -> RegistryUrl -> Bool
$c>= :: RegistryUrl -> RegistryUrl -> Bool
>= :: RegistryUrl -> RegistryUrl -> Bool
$cmax :: RegistryUrl -> RegistryUrl -> RegistryUrl
max :: RegistryUrl -> RegistryUrl -> RegistryUrl
$cmin :: RegistryUrl -> RegistryUrl -> RegistryUrl
min :: RegistryUrl -> RegistryUrl -> RegistryUrl
Ord, Int -> RegistryUrl -> ShowS
[RegistryUrl] -> ShowS
RegistryUrl -> String
(Int -> RegistryUrl -> ShowS)
-> (RegistryUrl -> String)
-> ([RegistryUrl] -> ShowS)
-> Show RegistryUrl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RegistryUrl -> ShowS
showsPrec :: Int -> RegistryUrl -> ShowS
$cshow :: RegistryUrl -> String
show :: RegistryUrl -> String
$cshowList :: [RegistryUrl] -> ShowS
showList :: [RegistryUrl] -> ShowS
Show)

{- | Build a 'RegistryUrl', accepting only an @https:\/\/@ URL, matched case-insensitively. The
configuration layer fails closed at boot on the 'Left' reason, which quotes the offending value.

>>> mkRegistryUrl "https://registry.npmjs.org"
Right (RegistryUrl "https://registry.npmjs.org")

>>> mkRegistryUrl "http://registry.npmjs.org"
Left "registry URL must use https (got http://registry.npmjs.org)"
-}
mkRegistryUrl :: Text -> Either Text RegistryUrl
mkRegistryUrl :: Text -> Either Text RegistryUrl
mkRegistryUrl Text
raw
    | Text -> Bool
T.null Text
trimmed = Text -> Either Text RegistryUrl
forall a b. a -> Either a b
Left Text
"expected a non-empty https URL"
    | LowerPrefix -> Text -> Bool
isPrefixOfLowered LowerPrefix
httpsPrefix Text
trimmed = RegistryUrl -> Either Text RegistryUrl
forall a b. b -> Either a b
Right (Text -> RegistryUrl
RegistryUrl Text
trimmed)
    | Bool
otherwise = Text -> Either Text RegistryUrl
forall a b. a -> Either a b
Left (Text
"registry URL must use https (got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
trimmed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  where
    trimmed :: Text
trimmed = Text -> Text
T.strip Text
raw

{- | Build a 'RegistryUrl' for an __operator-configured__ endpoint. @refuseCredentialMaterial@
runs before 'mkRegistryUrl', which quotes what it rejects.

>>> mkConfiguredRegistryUrl "https://registry.npmjs.org"
Right (RegistryUrl "https://registry.npmjs.org")

>>> mkConfiguredRegistryUrl "https://deploy:hunter2@registry.npmjs.org"
Left "registry URL must not carry userinfo (a credential belongs in its own configuration key)"
-}
mkConfiguredRegistryUrl :: Text -> Either Text RegistryUrl
mkConfiguredRegistryUrl :: Text -> Either Text RegistryUrl
mkConfiguredRegistryUrl Text
raw = do
    Text -> Text -> Either Text ()
refuseCredentialMaterial Text
"registry URL" Text
trimmed
    Text -> Either Text RegistryUrl
mkRegistryUrl Text
trimmed
  where
    trimmed :: Text
trimmed = Text -> Text
T.strip Text
raw

-- | The underlying URL text.
registryUrlText :: RegistryUrl -> Text
registryUrlText :: RegistryUrl -> Text
registryUrlText (RegistryUrl Text
u) = Text
u