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

{- | Derive the mirror-queue backend from the queue URL's own shape, once at load ('mkQueueUrl').

The queue URL is the single source of truth for which backend carries the mirror jobs, the same
derivation the mirror-write credential follows ("Ecluse.Config.Target"). An SQS queue URL
(@https:\/\/sqs.{region}.amazonaws.com\/{account}\/{queue}@) names the SQS backend and carries its
region, and a Pub\/Sub topic resource (@projects\/{project}\/topics\/{topic}@) names the GCP one. No
separate backend selector exists to disagree with the URL.
-}
module Ecluse.Config.QueueTarget (
    QueueTarget (..),
    QueueUrl,
    queueUrlText,
    queueUrlTarget,
    mkQueueUrl,
    parseQueueTarget,
) where

import Data.Text qualified as T

import Ecluse.Config.Queue.Internal (QueueTarget (..), QueueUrl (..), queueUrlTarget, queueUrlText)
import Ecluse.Config.Target (isAccountId)
import Ecluse.Config.Types (HttpScheme (Https), splitHttpScheme)
import Ecluse.Core.Security (refuseCredentialMaterial, splitHostPort)
import Ecluse.Core.Text (nonBlank)

{- | Build the 'QueueUrl' a @queue.url@ key resolves to, the key naming every refusal. A shape
naming no backend is carried, not refused: the SQS endpoint override dials one that matches none.
-}
mkQueueUrl :: Text -> Text -> Either Text QueueUrl
mkQueueUrl :: Text -> Text -> Either Text QueueUrl
mkQueueUrl Text
key Text
raw
    | Left Text
reason <- Text -> Text -> Either Text ()
refuseCredentialMaterial Text
key Text
trimmed = Text -> Either Text QueueUrl
forall a b. a -> Either a b
Left Text
reason
    | Text -> Bool
T.null Text
trimmed = Text -> Either Text QueueUrl
forall a b. a -> Either a b
Left (Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" must be a non-empty URL")
    | Bool
otherwise = QueueUrl -> Either Text QueueUrl
forall a b. b -> Either a b
Right (Text -> Maybe QueueTarget -> QueueUrl
QueueUrl Text
trimmed (Text -> Maybe QueueTarget
parseQueueTarget Text
trimmed))
  where
    trimmed :: Text
trimmed = Text -> Text
T.strip Text
raw

{- | Parse a queue URL into the backend it names, or 'Nothing' when it names neither. The SQS form
is exact, and a nearly-but-not SQS URL is a transcription error to surface, never to repair.
-}
parseQueueTarget :: Text -> Maybe QueueTarget
parseQueueTarget :: Text -> Maybe QueueTarget
parseQueueTarget Text
raw = Text -> Maybe QueueTarget
sqsTargetOf Text
raw Maybe QueueTarget -> Maybe QueueTarget -> Maybe QueueTarget
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe QueueTarget
pubSubTargetOf Text
raw

-- The region slot must be a single host label. A dotted "region" means the host is
-- some other AWS endpoint shape, never an SQS queue's, so this does not mis-parse it.
sqsTargetOf :: Text -> Maybe QueueTarget
sqsTargetOf :: Text -> Maybe QueueTarget
sqsTargetOf Text
raw = do
    let url :: Text
url = Text -> Text
T.strip Text
raw
    (scheme, rest) <- Text -> Maybe (HttpScheme, Text)
splitHttpScheme Text
url
    guard (scheme == Https)
    guard (T.all (\Char
c -> 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
'#') rest)
    let (authority, slashPath) = T.breakOn "/" rest
    -- The canonical form writes no port and no brackets, so the authority must be exactly
    -- the host the shared split recovers.
    (host, _) <- splitHostPort authority
    guard (host == authority)
    region <- nonBlank =<< T.stripSuffix ".amazonaws.com" =<< T.stripPrefix "sqs." (T.toLower host)
    guard (T.all (/= '.') region)
    case T.splitOn "/" (T.drop 1 slashPath) of
        [Text
account, Text
queueName]
            | Text -> Bool
isAccountId Text
account Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Text -> Maybe Text
nonBlank Text
queueName) ->
                QueueTarget -> Maybe QueueTarget
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> QueueTarget
SqsTarget Text
region)
        [Text]
_ -> Maybe QueueTarget
forall a. Maybe a
Nothing

pubSubTargetOf :: Text -> Maybe QueueTarget
pubSubTargetOf :: Text -> Maybe QueueTarget
pubSubTargetOf Text
raw = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
raw of
    [Text
"projects", Text
project, Text
"topics", Text
topic] ->
        Text -> Text -> QueueTarget
PubSubTarget (Text -> Text -> QueueTarget)
-> Maybe Text -> Maybe (Text -> QueueTarget)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text
nonBlank Text
project Maybe (Text -> QueueTarget) -> Maybe Text -> Maybe QueueTarget
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Text
nonBlank Text
topic
    [Text]
_ -> Maybe QueueTarget
forall a. Maybe a
Nothing