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

{- | The key vocabulary every configuration group decodes through ("Ecluse.Config.Aeson").

One declaration list is both the accepted-key list and the read list, so a key no field reads
cannot pass unnoticed and must be declared with 'unreadKey'. Each refusal carries the
group-qualified label and the Aeson path, so a nested type error names the setting an operator
wrote.
-}
module Ecluse.Config.Parser (
    -- * Group decoding
    GroupDecoder,
    decodeGroup,
    decodeBareGroup,
    requiredKey,
    optionalKey,
    optionalKeyOr,
    plainKey,
    optionalPlainKey,
    optionalPlainKeyOr,
    nestedKey,
    unreadKey,

    -- * Tagged targets
    TagCase (..),
    taggedTarget,

    -- * Value shapes
    expectString,
    commaSeparated,
    valueKind,
    rejectSecretKeys,

    -- * Leaf parsers
    parseRegistryUrl,
    parseEnum,
    parseHttpUrl,
    parseQueueUrl,
    parseAdvisoryStoreUrl,
    parsePort,
    parseCodeArtifactDuration,
) where

import Data.Aeson (FromJSON, Value (..), parseJSON, (.!=), (.:), (.:?))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (JSONPathElement (Key), Parser, modifyFailure, (<?>))
import Data.Text qualified as T

import Ecluse.Config.AdvisoryStore (mkAdvisoryStoreUrl)
import Ecluse.Config.QueueTarget (mkQueueUrl)
import Ecluse.Config.Types (AdvisoryStoreUrl, QueueUrl, Url, mkUrl)
import Ecluse.Core.Json.Lenient (valueKind)
import Ecluse.Core.Security (hostPortAddress)
import Ecluse.Core.Security.Egress (RegistryUrl, mkConfiguredRegistryUrl)
import Ecluse.Core.Text (nonBlank, readDecimalText)

-- The object a group decodes, with the prefix its value refusals write before each key.
data GroupInput = GroupInput
    { GroupInput -> String
giPrefix :: String
    , GroupInput -> KeyMap Value
giObject :: KeyMap.KeyMap Value
    }

-- | An applicative group decoder: each key it declares is one it accepts and one it reads.
data GroupDecoder a = GroupDecoder
    { forall a. GroupDecoder a -> [Key]
gdKeys :: [Key.Key]
    , forall a. GroupDecoder a -> GroupInput -> Parser a
gdRead :: GroupInput -> Parser a
    }

instance Functor GroupDecoder where
    fmap :: forall a b. (a -> b) -> GroupDecoder a -> GroupDecoder b
fmap a -> b
f GroupDecoder a
decoder = GroupDecoder a
decoder{gdRead = fmap f . gdRead decoder}

instance Applicative GroupDecoder where
    pure :: forall a. a -> GroupDecoder a
pure a
a = [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
forall a. [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
GroupDecoder [] (Parser a -> GroupInput -> Parser a
forall a b. a -> b -> a
const (a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a))
    GroupDecoder (a -> b)
lhs <*> :: forall a b.
GroupDecoder (a -> b) -> GroupDecoder a -> GroupDecoder b
<*> GroupDecoder a
rhs =
        [Key] -> (GroupInput -> Parser b) -> GroupDecoder b
forall a. [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
GroupDecoder
            (GroupDecoder (a -> b) -> [Key]
forall a. GroupDecoder a -> [Key]
gdKeys GroupDecoder (a -> b)
lhs [Key] -> [Key] -> [Key]
forall a. Semigroup a => a -> a -> a
<> GroupDecoder a -> [Key]
forall a. GroupDecoder a -> [Key]
gdKeys GroupDecoder a
rhs)
            (\GroupInput
input -> GroupDecoder (a -> b) -> GroupInput -> Parser (a -> b)
forall a. GroupDecoder a -> GroupInput -> Parser a
gdRead GroupDecoder (a -> b)
lhs GroupInput
input Parser (a -> b) -> Parser a -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GroupDecoder a -> GroupInput -> Parser a
forall a. GroupDecoder a -> GroupInput -> Parser a
gdRead GroupDecoder a
rhs GroupInput
input)

-- | Refuse unknown keys before reading values. Refinement labels use @noun.key@.
decodeGroup :: String -> GroupDecoder a -> KeyMap.KeyMap Value -> Parser a
decodeGroup :: forall a. String -> GroupDecoder a -> KeyMap Value -> Parser a
decodeGroup String
noun = String -> String -> GroupDecoder a -> KeyMap Value -> Parser a
forall a.
String -> String -> GroupDecoder a -> KeyMap Value -> Parser a
runGroupDecoder String
noun (String
noun String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".")

-- | Decode with bare refinement labels when the enclosing parser supplies the group context.
decodeBareGroup :: String -> GroupDecoder a -> KeyMap.KeyMap Value -> Parser a
decodeBareGroup :: forall a. String -> GroupDecoder a -> KeyMap Value -> Parser a
decodeBareGroup String
noun = String -> String -> GroupDecoder a -> KeyMap Value -> Parser a
forall a.
String -> String -> GroupDecoder a -> KeyMap Value -> Parser a
runGroupDecoder String
noun String
""

runGroupDecoder :: String -> String -> GroupDecoder a -> KeyMap.KeyMap Value -> Parser a
runGroupDecoder :: forall a.
String -> String -> GroupDecoder a -> KeyMap Value -> Parser a
runGroupDecoder String
noun String
prefix GroupDecoder a
decoder KeyMap Value
o = do
    String -> [Key] -> KeyMap Value -> Parser ()
rejectUnknownKeys String
noun (GroupDecoder a -> [Key]
forall a. GroupDecoder a -> [Key]
gdKeys GroupDecoder a
decoder) KeyMap Value
o
    GroupDecoder a -> GroupInput -> Parser a
forall a. GroupDecoder a -> GroupInput -> Parser a
gdRead GroupDecoder a
decoder (GroupInput{giPrefix :: String
giPrefix = String
prefix, giObject :: KeyMap Value
giObject = KeyMap Value
o})

-- | Decode and refine a required key. Refinements receive its group-qualified label.
requiredKey :: (FromJSON b) => Key.Key -> (String -> b -> Parser a) -> GroupDecoder a
requiredKey :: forall b a.
FromJSON b =>
Key -> (String -> b -> Parser a) -> GroupDecoder a
requiredKey Key
k String -> b -> Parser a
parse = [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
forall a. [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
GroupDecoder [Key
k] GroupInput -> Parser a
present
  where
    present :: GroupInput -> Parser a
present GroupInput
input = case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
k (GroupInput -> KeyMap Value
giObject GroupInput
input) of
        Maybe Value
Nothing -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (GroupInput -> Key -> String
labelOf GroupInput
input Key
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is required")
        Just Value
v -> (String -> Value -> Parser b
forall a. FromJSON a => String -> Value -> Parser a
parseAt (GroupInput -> Key -> String
labelOf GroupInput
input Key
k) Value
v Parser b -> (b -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> b -> Parser a
parse (GroupInput -> Key -> String
labelOf GroupInput
input Key
k)) Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
k

-- | 'requiredKey' for an optional key: an absent or @null@ one yields 'Nothing'.
optionalKey :: (FromJSON b) => Key.Key -> (String -> b -> Parser a) -> GroupDecoder (Maybe a)
optionalKey :: forall b a.
FromJSON b =>
Key -> (String -> b -> Parser a) -> GroupDecoder (Maybe a)
optionalKey Key
k String -> b -> Parser a
parse =
    [Key] -> (GroupInput -> Parser (Maybe a)) -> GroupDecoder (Maybe a)
forall a. [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
GroupDecoder [Key
k] (\GroupInput
input -> GroupInput -> Key -> Parser (Maybe b)
forall a. FromJSON a => GroupInput -> Key -> Parser (Maybe a)
readOptionalKey GroupInput
input Key
k Parser (Maybe b)
-> (Maybe b -> Parser (Maybe a)) -> Parser (Maybe a)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> Parser a) -> Maybe b -> Parser (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (String -> b -> Parser a
parse (GroupInput -> Key -> String
labelOf GroupInput
input Key
k)))

-- | 'requiredKey' for an optional key whose absence reads as @fallback@ before @parse@ sees it.
optionalKeyOr :: (FromJSON b) => Key.Key -> b -> (String -> b -> Parser a) -> GroupDecoder a
optionalKeyOr :: forall b a.
FromJSON b =>
Key -> b -> (String -> b -> Parser a) -> GroupDecoder a
optionalKeyOr Key
k b
fallback String -> b -> Parser a
parse =
    [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
forall a. [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
GroupDecoder [Key
k] (\GroupInput
input -> GroupInput -> Key -> Parser (Maybe b)
forall a. FromJSON a => GroupInput -> Key -> Parser (Maybe a)
readOptionalKey GroupInput
input Key
k Parser (Maybe b) -> b -> Parser b
forall a. Parser (Maybe a) -> a -> Parser a
.!= b
fallback Parser b -> (b -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> b -> Parser a
parse (GroupInput -> Key -> String
labelOf GroupInput
input Key
k))

-- | A required key its own 'FromJSON' instance decodes whole, with no further refusal.
plainKey :: (FromJSON a) => Key.Key -> GroupDecoder a
plainKey :: forall a. FromJSON a => Key -> GroupDecoder a
plainKey Key
k = [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
forall a. [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
GroupDecoder [Key
k] GroupInput -> Parser a
forall {a}. FromJSON a => GroupInput -> Parser a
present
  where
    present :: GroupInput -> Parser a
present GroupInput
input = case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
k (GroupInput -> KeyMap Value
giObject GroupInput
input) of
        Maybe Value
Nothing -> GroupInput -> KeyMap Value
giObject GroupInput
input KeyMap Value -> Key -> Parser a
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
k
        Just Value
v -> String -> Value -> Parser a
forall a. FromJSON a => String -> Value -> Parser a
parseAt (GroupInput -> Key -> String
labelOf GroupInput
input Key
k) Value
v Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
k

-- | 'plainKey' for an optional key.
optionalPlainKey :: (FromJSON a) => Key.Key -> GroupDecoder (Maybe a)
optionalPlainKey :: forall a. FromJSON a => Key -> GroupDecoder (Maybe a)
optionalPlainKey Key
k = Key -> (String -> a -> Parser a) -> GroupDecoder (Maybe a)
forall b a.
FromJSON b =>
Key -> (String -> b -> Parser a) -> GroupDecoder (Maybe a)
optionalKey Key
k ((a -> Parser a) -> String -> a -> Parser a
forall a b. a -> b -> a
const a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

-- | 'plainKey' for an optional key, with the value an absent one reads as.
optionalPlainKeyOr :: (FromJSON a) => Key.Key -> a -> GroupDecoder a
optionalPlainKeyOr :: forall a. FromJSON a => Key -> a -> GroupDecoder a
optionalPlainKeyOr Key
k a
fallback = Key -> a -> (String -> a -> Parser a) -> GroupDecoder a
forall b a.
FromJSON b =>
Key -> b -> (String -> b -> Parser a) -> GroupDecoder a
optionalKeyOr Key
k a
fallback ((a -> Parser a) -> String -> a -> Parser a
forall a b. a -> b -> a
const a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

-- | Decode an absent group as an empty object so its required keys determine the refusal.
nestedKey :: Key.Key -> (KeyMap.KeyMap Value -> Parser a) -> GroupDecoder a
nestedKey :: forall a. Key -> (KeyMap Value -> Parser a) -> GroupDecoder a
nestedKey Key
k KeyMap Value -> Parser a
parse = [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
forall a. [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
GroupDecoder [Key
k] (\GroupInput
input -> KeyMap Value -> Parser a
nested (GroupInput -> KeyMap Value
giObject GroupInput
input) Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
k)
  where
    nested :: KeyMap Value -> Parser a
nested KeyMap Value
o = case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
k KeyMap Value
o of
        Maybe Value
Nothing -> KeyMap Value -> Parser a
parse KeyMap Value
forall v. KeyMap v
KeyMap.empty
        Just (Object KeyMap Value
inner) -> KeyMap Value -> Parser a
parse KeyMap Value
inner
        Just Value
other -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Key -> String
Key.toString Key
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be an object, but encountered " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
valueKind Value
other)

-- | A key the group accepts and no field reads.
unreadKey :: Key.Key -> GroupDecoder ()
unreadKey :: Key -> GroupDecoder ()
unreadKey Key
k = [Key] -> (GroupInput -> Parser ()) -> GroupDecoder ()
forall a. [Key] -> (GroupInput -> Parser a) -> GroupDecoder a
GroupDecoder [Key
k] (Parser () -> GroupInput -> Parser ()
forall a b. a -> b -> a
const (() -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

-- | One tag a target key admits: the tag as an operator writes it, and the group under it.
data TagCase a = TagCase Key.Key (GroupDecoder a)

-- | Admit exactly one store tag and only the keys its decoder declares.
taggedTarget :: [TagCase a] -> String -> Value -> Parser a
taggedTarget :: forall a. [TagCase a] -> String -> Value -> Parser a
taggedTarget [TagCase a]
cases String
field = \case
    Object KeyMap Value
o -> case KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList KeyMap Value
o of
        [(Key
tag, Value
inner)] | Just (TagCase Key
_ GroupDecoder a
decoder) <- Key -> Maybe (TagCase a)
caseFor Key
tag -> Key -> GroupDecoder a -> Value -> Parser a
forall {a}. Key -> GroupDecoder a -> Value -> Parser a
tagGroup Key
tag GroupDecoder a
decoder Value
inner
        [(Key, Value)]
written -> 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
" must name " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
admitted String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Key] -> String
writtenTags (((Key, Value) -> Key) -> [(Key, Value)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Value) -> Key
forall a b. (a, b) -> a
fst [(Key, Value)]
written))
    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
" must be an object naming " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
admitted String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but encountered " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
valueKind Value
other)
  where
    caseFor :: Key -> Maybe (TagCase a)
caseFor Key
tag = (TagCase a -> Bool) -> [TagCase a] -> Maybe (TagCase a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(TagCase Key
k GroupDecoder a
_) -> Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
tag) [TagCase a]
cases

    admitted :: String
admitted = String
"exactly one store tag (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((TagCase a -> String) -> [TagCase a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(TagCase Key
k GroupDecoder a
_) -> Key -> String
Key.toString Key
k) [TagCase a]
cases) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

    tagGroup :: Key -> GroupDecoder a -> Value -> Parser a
tagGroup Key
tag GroupDecoder a
decoder = \case
        Object KeyMap Value
inner -> String -> GroupDecoder a -> KeyMap Value -> Parser a
forall a. String -> GroupDecoder a -> KeyMap Value -> Parser a
decodeGroup (String
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Key -> String
Key.toString Key
tag) GroupDecoder a
decoder KeyMap Value
inner
        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
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Key -> String
Key.toString Key
tag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be an object, but encountered " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
valueKind Value
other)

writtenTags :: [Key.Key] -> String
writtenTags :: [Key] -> String
writtenTags = \case
    [] -> String
"no tag"
    [Key]
tags -> 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]
tags)

parseAt :: (FromJSON a) => String -> Value -> Parser a
parseAt :: forall a. FromJSON a => String -> Value -> Parser a
parseAt String
label = (String -> String) -> Parser a -> Parser a
forall a. (String -> String) -> Parser a -> Parser a
modifyFailure ((String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ") String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (Parser a -> Parser a) -> (Value -> Parser a) -> Value -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON

readOptionalKey :: (FromJSON a) => GroupInput -> Key.Key -> Parser (Maybe a)
readOptionalKey :: forall a. FromJSON a => GroupInput -> Key -> Parser (Maybe a)
readOptionalKey GroupInput
input Key
k =
    GroupInput -> KeyMap Value
giObject GroupInput
input KeyMap Value -> Key -> Parser (Maybe Value)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
k Parser (Maybe Value)
-> (Maybe Value -> Parser (Maybe a)) -> Parser (Maybe a)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser a) -> Maybe Value -> Parser (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (\Value
v -> String -> Value -> Parser a
forall a. FromJSON a => String -> Value -> Parser a
parseAt (GroupInput -> Key -> String
labelOf GroupInput
input Key
k) Value
v Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
k)

labelOf :: GroupInput -> Key.Key -> String
labelOf :: GroupInput -> Key -> String
labelOf GroupInput
input Key
k = GroupInput -> String
giPrefix GroupInput
input String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Key -> String
Key.toString Key
k

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)
                    )

-- | Refuse document credentials without including their values in the error.
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"]

-- | Refuse a non-string with its setting label and JSON kind, without quoting its value.
expectString :: String -> (Text -> Parser a) -> Value -> Parser a
expectString :: forall a. String -> (Text -> Parser a) -> Value -> Parser a
expectString String
field Text -> Parser a
parse = \case
    String Text
t -> Text -> Parser a
parse 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 " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
valueKind Value
other)

-- | A blank string gives no entries. Empty comma-separated entries still reach @parseEntry@.
commaSeparated :: String -> (Text -> Parser a) -> Value -> Parser [a]
commaSeparated :: forall a. String -> (Text -> Parser a) -> Value -> Parser [a]
commaSeparated String
field Text -> Parser a
parseEntry =
    String -> (Text -> Parser [a]) -> Value -> Parser [a]
forall a. String -> (Text -> Parser a) -> Value -> Parser a
expectString String
field (Parser [a] -> (Text -> Parser [a]) -> Maybe Text -> Parser [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> Parser [a]
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ((Text -> Parser a) -> [Text] -> Parser [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Text -> Parser a
parseEntry (Text -> Parser a) -> (Text -> Text) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) ([Text] -> Parser [a]) -> (Text -> [Text]) -> Text -> Parser [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
",") (Maybe Text -> Parser [a])
-> (Text -> Maybe Text) -> Text -> Parser [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
nonBlank)

-- | Refuse credentials before any URL refusal can quote the input.
parseRegistryUrl :: String -> Value -> Parser RegistryUrl
parseRegistryUrl :: String -> Value -> Parser RegistryUrl
parseRegistryUrl String
field = String
-> (Text -> Parser RegistryUrl) -> Value -> Parser RegistryUrl
forall a. String -> (Text -> Parser a) -> Value -> Parser a
expectString String
field ((Text -> Parser RegistryUrl) -> Value -> Parser RegistryUrl)
-> (Text -> Parser RegistryUrl) -> Value -> Parser RegistryUrl
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text -> Either Text RegistryUrl
mkConfiguredRegistryUrl Text
t of
    Left Text
reason -> String -> Parser RegistryUrl
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
reason)
    Right RegistryUrl
url
        | 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
field
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> 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 -> RegistryUrl -> Parser RegistryUrl
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegistryUrl
url

-- | Decode a named enum and retain the setting label on refusal.
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 =
    String -> (Text -> Parser a) -> Value -> Parser a
forall a. String -> (Text -> Parser a) -> Value -> Parser a
expectString String
field ((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 (Either Text a -> Parser a)
-> (Text -> Either Text a) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
parser)

-- | Parse an HTTP(S) URL without credentials. Plain HTTP remains legal for loopback deployments.
parseHttpUrl :: String -> Value -> Parser Url
parseHttpUrl :: String -> Value -> Parser Url
parseHttpUrl String
field = String -> (Text -> Parser Url) -> Value -> Parser Url
forall a. String -> (Text -> Parser a) -> Value -> Parser a
expectString String
field ((Text -> Either Text Url) -> Text -> Parser Url
forall a. (Text -> Either Text a) -> Text -> Parser a
refined (Text -> Text -> Either Text Url
mkUrl (String -> Text
T.pack String
field)))

-- | Parse a queue destination whose shape determines its provider.
parseQueueUrl :: String -> Value -> Parser QueueUrl
parseQueueUrl :: String -> Value -> Parser QueueUrl
parseQueueUrl String
field = String -> (Text -> Parser QueueUrl) -> Value -> Parser QueueUrl
forall a. String -> (Text -> Parser a) -> Value -> Parser a
expectString String
field ((Text -> Either Text QueueUrl) -> Text -> Parser QueueUrl
forall a. (Text -> Either Text a) -> Text -> Parser a
refined (Text -> Text -> Either Text QueueUrl
mkQueueUrl (String -> Text
T.pack String
field)))

-- | Parse an advisory object store whose scheme determines its provider.
parseAdvisoryStoreUrl :: String -> Value -> Parser AdvisoryStoreUrl
parseAdvisoryStoreUrl :: String -> Value -> Parser AdvisoryStoreUrl
parseAdvisoryStoreUrl String
field = String
-> (Text -> Parser AdvisoryStoreUrl)
-> Value
-> Parser AdvisoryStoreUrl
forall a. String -> (Text -> Parser a) -> Value -> Parser a
expectString String
field ((Text -> Either Text AdvisoryStoreUrl)
-> Text -> Parser AdvisoryStoreUrl
forall a. (Text -> Either Text a) -> Text -> Parser a
refined (Text -> Text -> Either Text AdvisoryStoreUrl
mkAdvisoryStoreUrl (String -> Text
T.pack String
field)))

-- A smart constructor's refusal, which already names the key, raised as the key's parse failure.
refined :: (Text -> Either Text a) -> Text -> Parser a
refined :: forall a. (Text -> Either Text a) -> Text -> Parser a
refined Text -> Either Text a
parse = (Text -> Parser a) -> (a -> Parser a) -> Either Text a -> Parser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> (Text -> String) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> Parser a)
-> (Text -> Either Text a) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
parse

-- | 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)

-- | Accept seconds in CodeArtifact's 900..43200 range before the first token mint.
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 Text -> Maybe Natural
forall a. Integral a => Text -> Maybe a
readDecimalText 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 -> String -> Value -> Parser Natural
forall a. FromJSON a => String -> Value -> Parser a
parseAt String
field 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)