-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Ecluse.Config.Parser (
    rejectSecretKeys,
    parseRegistryUrl,
    parseEnum,
    valueKind,
    rejectUnknownKeys,
    parseUrl,
    parseHttpUrl,
    parsePort,
    parseCodeArtifactDuration,
) where

import Data.Aeson (Value (..), parseJSON)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (Parser, withText)
import Data.Text qualified as T

import Ecluse.Config.Types (Url, mkUrl)
import Ecluse.Core.Security (hostPortAddress)
import Ecluse.Core.Security.Egress (RegistryUrl, mkRegistryUrl)

rejectSecretKeys :: KeyMap.KeyMap Value -> Parser ()
rejectSecretKeys :: KeyMap Value -> Parser ()
rejectSecretKeys KeyMap Value
o =
    case (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> KeyMap Value -> Bool
forall a. Key -> KeyMap a -> Bool
`KeyMap.member` KeyMap Value
o) [Key]
secretKeys of
        [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [Key]
present ->
            String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                ( String
"secret key(s) are not allowed in the config document (use environment variables): "
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
forall b a. (Show a, IsString b) => a -> b
show (Text -> String) -> (Key -> Text) -> Key -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText) [Key]
present)
                )
  where
    secretKeys :: [Key.Key]
    secretKeys :: [Key]
secretKeys = [Key
"token", Key
"authToken", Key
"password", Key
"secret", Key
"credentialToken"]

-- A registry URL entry must be https (mkRegistryUrl) and must carry a dialable
-- authority: a host, and, when a port is written, a decimal port in 1..65535
-- (hostPortAddress, the same extraction the egress gate authorises by). The gate
-- treats an unextractable authority as refused, so an entry that fails here could
-- only ever produce a mount that refuses every fetch; failing the boot names the
-- offending value instead.
parseRegistryUrl :: Value -> Parser RegistryUrl
parseRegistryUrl :: Value -> Parser RegistryUrl
parseRegistryUrl = \case
    String Text
t
        | Maybe HostPort -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Maybe HostPort
hostPortAddress Text
t) ->
            String -> Parser RegistryUrl
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                ( String
"registry URL must carry a host and, when a port is written, a decimal port in 1..65535 (got "
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
                )
        | Bool
otherwise -> (Text -> Parser RegistryUrl)
-> (RegistryUrl -> Parser RegistryUrl)
-> Either Text RegistryUrl
-> Parser RegistryUrl
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser RegistryUrl
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser RegistryUrl)
-> (Text -> String) -> Text -> Parser RegistryUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) RegistryUrl -> Parser RegistryUrl
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either Text RegistryUrl
mkRegistryUrl Text
t)
    Value
other -> String -> Parser RegistryUrl
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"parseRegistryUrl expected a string, but encountered a " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
valueKind Value
other)

parseEnum :: (Text -> Either Text a) -> String -> Value -> Parser a
parseEnum :: forall a. (Text -> Either Text a) -> String -> Value -> Parser a
parseEnum Text -> Either Text a
parser String
field = \case
    String Text
t -> (Text -> Parser a) -> (a -> Parser a) -> Either Text a -> Parser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
e -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
e)) a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either Text a
parser Text
t)
    Value
other -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" expected a string, but encountered a " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
valueKind Value
other)

valueKind :: Value -> String
valueKind :: Value -> String
valueKind = \case
    Object{} -> String
"an object"
    Array{} -> String
"an array"
    Number{} -> String
"a number"
    Bool{} -> String
"a boolean"
    Value
Null -> String
"null"
    String{} -> String
"a string"

rejectUnknownKeys :: String -> [Key.Key] -> KeyMap.KeyMap Value -> Parser ()
rejectUnknownKeys :: String -> [Key] -> KeyMap Value -> Parser ()
rejectUnknownKeys String
context [Key]
accepted KeyMap Value
o =
    let isUnknown :: Key -> Bool
isUnknown Key
k = Key
k Key -> [Key] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Key]
accepted
     in case (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter Key -> Bool
isUnknown (KeyMap Value -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys KeyMap Value
o) of
            [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            [Key]
unknown ->
                String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                    ( String
"unexpected "
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
context
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" key(s): "
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
forall b a. (Show a, IsString b) => a -> b
show (Text -> String) -> (Key -> Text) -> Key -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText) [Key]
unknown)
                    )

parseUrl :: Value -> Parser Url
parseUrl :: Value -> Parser Url
parseUrl = String -> (Text -> Parser Url) -> Value -> Parser Url
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Url" ((Text -> Parser Url) -> Value -> Parser Url)
-> (Text -> Parser Url) -> Value -> Parser Url
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case Text -> Either Text Url
mkUrl Text
t of
        Right Url
u -> Url -> Parser Url
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Url
u
        Left Text
e -> String -> Parser Url
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Text -> String
T.unpack Text
e)

{- | An @http(s)@ URL Écluse itself serves or rewrites against (the public URL):
the scheme must be http or https (http stays legal for loopback development
deployments), and the authority must be dialable by the same extraction the egress
gate authorises ('hostPortAddress'), so a value that cannot name a real listener is
refused at load instead of surfacing as rewritten artifact URLs no client can fetch.
-}
parseHttpUrl :: String -> Value -> Parser Url
parseHttpUrl :: String -> Value -> Parser Url
parseHttpUrl String
field = \case
    String Text
t
        | Bool -> Bool
not ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.strip Text
t) [Text
"http://", Text
"https://"]) ->
            String -> Parser Url
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be an http:// or https:// URL (got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")")
        | Maybe HostPort -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Maybe HostPort
hostPortAddress (Text -> Text
T.strip Text
t)) ->
            String -> Parser Url
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                ( String
field
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must carry a host and, when a port is written, a decimal port in 1..65535 (got "
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
                )
        | Bool
otherwise -> (Text -> Parser Url)
-> (Url -> Parser Url) -> Either Text Url -> Parser Url
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser Url
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Url) -> (Text -> String) -> Text -> Parser Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Url -> Parser Url
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either Text Url
mkUrl Text
t)
    Value
other -> String -> Parser Url
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" expected a string, but encountered a " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
valueKind Value
other)

-- | A listener port: 0..65535, where 0 asks the OS for an ephemeral port.
parsePort :: String -> Int -> Parser Int
parsePort :: String -> Int -> Parser Int
parsePort String
field Int
value
    | Int
value Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
value Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
65535 = Int -> Parser Int
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
value
    | Bool
otherwise = String -> Parser Int
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be a port in 0..65535 (0 = OS-assigned), got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
value)

{- | A CodeArtifact authorisation-token duration in seconds, bounded to the range
the service accepts (900..43200); an out-of-range value would only fail later, at
the first mint, with the mirror queue already accepting work.
-}
parseCodeArtifactDuration :: String -> Value -> Parser Natural
parseCodeArtifactDuration :: String -> Value -> Parser Natural
parseCodeArtifactDuration String
field Value
v = do
    n <- case Value
v of
        String Text
t -> case String -> Maybe Natural
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
t) :: Maybe Natural of
            Just Natural
parsed -> Natural -> Parser Natural
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
parsed
            Maybe Natural
Nothing -> String -> Parser Natural
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": invalid duration: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t)
        Value
other -> Value -> Parser Natural
forall a. FromJSON a => Value -> Parser a
parseJSON Value
other
    if n >= 900 && n <= 43200
        then pure n
        else fail (field <> " must be a duration in seconds within 900..43200, got " <> show n)