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

{- | Derive the advisory-database store from @advisories.url@'s own scheme, once at load
('mkAdvisoryStoreUrl'), the way "Ecluse.Config.QueueTarget" derives the mirror-queue backend.

@s3:\/\/bucket[\/prefix]@ names the S3 store. No separate provider selector exists to disagree
with the URL, and a scheme this build does not know is refused at load rather than dialled.
'advisoryStoreBucket' and 'advisoryObjectKey' are the one place the proxy's sync and Pilot's
export agree on where an artifact lives.
-}
module Ecluse.Config.AdvisoryStore (
    AdvisoryStoreTarget (..),
    AdvisoryStoreUrl,
    advisoryStoreUrlText,
    advisoryStoreTarget,
    mkAdvisoryStoreUrl,
    advisoryStoreBucket,
    advisoryObjectKey,
) where

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

import Ecluse.Config.Advisory.Internal (
    AdvisoryStoreTarget (..),
    AdvisoryStoreUrl (..),
    advisoryStoreTarget,
    advisoryStoreUrlText,
 )
import Ecluse.Core.Security (refuseCredentialMaterial)
import Ecluse.Core.Text (nonBlank)

-- The scheme this build knows, named in its own refusal so the message stays in step.
s3Scheme :: Text
s3Scheme :: Text
s3Scheme = Text
"s3://"

{- | Build the 'AdvisoryStoreUrl' an @advisories.url@ key resolves to, the key naming every
refusal. The credential refusal runs first, because the refusals below it quote the value.
-}
mkAdvisoryStoreUrl :: Text -> Text -> Either Text AdvisoryStoreUrl
mkAdvisoryStoreUrl :: Text -> Text -> Either Text AdvisoryStoreUrl
mkAdvisoryStoreUrl Text
key Text
raw
    | Left Text
reason <- Text -> Text -> Either Text ()
refuseCredentialMaterial Text
key Text
trimmed = Text -> Either Text AdvisoryStoreUrl
forall a b. a -> Either a b
Left Text
reason
    | Just Text
rest <- Text -> Text -> Maybe Text
T.stripPrefix Text
s3Scheme Text
trimmed = Text -> AdvisoryStoreTarget -> AdvisoryStoreUrl
AdvisoryStoreUrl Text
trimmed (AdvisoryStoreTarget -> AdvisoryStoreUrl)
-> Either Text AdvisoryStoreTarget -> Either Text AdvisoryStoreUrl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Either Text AdvisoryStoreTarget
s3StoreOf Text
key Text
rest
    | Bool
otherwise =
        Text -> Either Text AdvisoryStoreUrl
forall a b. a -> Either a b
Left
            ( Text
key
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" must name an object store this build knows, currently only "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s3Scheme
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"bucket[/prefix] (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

-- Split the authority from the key prefix, refusing a bucket the S3 naming rules would.
s3StoreOf :: Text -> Text -> Either Text AdvisoryStoreTarget
s3StoreOf :: Text -> Text -> Either Text AdvisoryStoreTarget
s3StoreOf Text
key Text
rest = do
    let (Text
bucket, Text
slashPrefix) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"/" Text
rest
    Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
validBucketName Text
bucket) (Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Text -> Text
bucketRefusal Text
key Text
bucket))
    AdvisoryStoreTarget -> Either Text AdvisoryStoreTarget
forall a b. b -> Either a b
Right (Text -> Maybe Text -> AdvisoryStoreTarget
S3Store Text
bucket (Text -> Maybe Text
normalisedPrefix Text
slashPrefix))

bucketRefusal :: Text -> Text -> Text
bucketRefusal :: Text -> Text -> Text
bucketRefusal Text
key Text
bucket =
    Text
key
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" must name an S3 bucket of 3 to 63 characters, lowercase letters, digits, dots, and"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" hyphens, starting and ending alphanumeric (got "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bucket
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- The S3 bucket naming rules, checked at load so a malformed name fails the boot rather than the
-- first advisory poll. A dotted name stays legal, because an existing bucket may carry one.
validBucketName :: Text -> Bool
validBucketName :: Text -> Bool
validBucketName Text
bucket =
    Text -> Int -> Ordering
T.compareLength Text
bucket Int
3 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
        Bool -> Bool -> Bool
&& Text -> Int -> Ordering
T.compareLength Text
bucket Int
63 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT
        Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
bucketChar Text
bucket
        Bool -> Bool -> Bool
&& Bool -> ((Char, Text) -> Bool) -> Maybe (Char, Text) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
alphanumeric (Char -> Bool) -> ((Char, Text) -> Char) -> (Char, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Text) -> Char
forall a b. (a, b) -> a
fst) (Text -> Maybe (Char, Text)
T.uncons Text
bucket)
        Bool -> Bool -> Bool
&& Bool -> ((Text, Char) -> Bool) -> Maybe (Text, Char) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
alphanumeric (Char -> Bool) -> ((Text, Char) -> Char) -> (Text, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Char) -> Char
forall a b. (a, b) -> b
snd) (Text -> Maybe (Text, Char)
T.unsnoc Text
bucket)
  where
    bucketChar :: Char -> Bool
bucketChar Char
c = Char -> Bool
alphanumeric Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
    alphanumeric :: Char -> Bool
alphanumeric Char
c = Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c

-- A prefix is stored without its surrounding slashes, so 'advisoryObjectKey' writes exactly one.
normalisedPrefix :: Text -> Maybe Text
normalisedPrefix :: Text -> Maybe Text
normalisedPrefix = Text -> Maybe Text
nonBlank (Text -> Maybe Text) -> (Text -> Text) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')

-- | The bucket the store names.
advisoryStoreBucket :: AdvisoryStoreUrl -> Text
advisoryStoreBucket :: AdvisoryStoreUrl -> Text
advisoryStoreBucket AdvisoryStoreUrl
url = case AdvisoryStoreUrl -> AdvisoryStoreTarget
advisoryStoreTarget AdvisoryStoreUrl
url of
    S3Store Text
bucket Maybe Text
_ -> Text
bucket

{- | The object key one compiled artifact takes in the store: the configured prefix ahead of the
artifact's own file name.
-}
advisoryObjectKey :: AdvisoryStoreUrl -> FilePath -> Text
advisoryObjectKey :: AdvisoryStoreUrl -> FilePath -> Text
advisoryObjectKey AdvisoryStoreUrl
url FilePath
fileName = case AdvisoryStoreUrl -> AdvisoryStoreTarget
advisoryStoreTarget AdvisoryStoreUrl
url of
    S3Store Text
_ Maybe Text
Nothing -> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
fileName
    S3Store Text
_ (Just Text
prefix) -> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
fileName