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

{- | The outbound-credential handle: the bearer token Écluse uses to __write__ approved packages
to the mirror target. It serves Écluse's own store access only, never a read on a user's behalf:
a private-upstream read forwards the client's own credential (see
@docs\/architecture\/registry-model.md@, "Credential flow and authority").

The handle stays apart from the protocol handle "Ecluse.Core.Registry" because every managed
registry speaks one protocol and differs only in how it hands out a token. Refresh, cache and
expiry policy over a per-cloud mint live in "Ecluse.Core.Credential.Refresh".
-}
module Ecluse.Core.Credential (
    -- * Secrets
    Secret,
    mkSecret,
    unSecret,

    -- * A client's presented credential
    ClientCredential (..),
    bareCredential,

    -- * Tokens
    AuthToken (..),

    -- * Provider handle
    CredentialProvider (..),
    mintSecret,

    -- * In-memory double
    staticProvider,
) where

import Data.Aeson (FromJSON (..), ToJSON (..), Value (String), withText)
import Data.ByteArray qualified as BA
import Data.Time (UTCTime)
import Text.Show (showString, showsPrec)

{- | A short-lived secret (an access token). Build one with 'mkSecret' and recover the text
__only__ at the point of use with 'unSecret'.
-}
newtype Secret = Secret Text

{- | Constant-time equality over the UTF-8 encoding. The @ECLUSE_SERVER__AUTH_TOKEN@ edge gate
compares through it, a short-circuit would leak the prefix length. The token length still leaks.
-}
instance Eq Secret where
    Secret Text
a == :: Secret -> Secret -> Bool
== Secret Text
b = ByteString -> ByteString -> Bool
forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
BA.constEq (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
a :: ByteString) (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
b :: ByteString)

{- | Render a fixed placeholder, __never__ the secret text. It defines 'showsPrec' because relude
re-exports a polymorphic @show@ that is not the class method.
-}
instance Show Secret where
    showsPrec :: Int -> Secret -> ShowS
showsPrec Int
_ Secret
_ = String -> ShowS
showString String
"Secret <REDACTED>"

-- | The JSON encoding redacts the secret, so it never leaks into a JSON log.
instance ToJSON Secret where
    toJSON :: Secret -> Value
toJSON Secret
_ = Text -> Value
String Text
"<REDACTED>"

-- | Decoding reads the secret from configuration, for example the environment AST.
instance FromJSON Secret where
    parseJSON :: Value -> Parser Secret
parseJSON = String -> (Text -> Parser Secret) -> Value -> Parser Secret
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Secret" (Secret -> Parser Secret
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Secret -> Parser Secret)
-> (Text -> Secret) -> Text -> Parser Secret
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Secret
mkSecret)

-- | Wrap raw token text as a 'Secret'.
mkSecret :: Text -> Secret
mkSecret :: Text -> Secret
mkSecret = Text -> Secret
Secret

{- | Recover the raw token text. Call this __only__ at the point of use, when setting the auth
header, and never log or otherwise render the result.
-}
unSecret :: Secret -> Text
unSecret :: Secret -> Text
unSecret (Secret Text
s) = Text
s

{- | A credential as a client presents it. The username is not part of the secret: a gate
compares 'credSecret' alone, and a passthrough leg renders the pair verbatim.
-}
data ClientCredential = ClientCredential
    { ClientCredential -> Maybe Text
credUsername :: Maybe Text
    -- ^ The username the client presented, when its scheme carries one.
    , ClientCredential -> Secret
credSecret :: Secret
    -- ^ The secret half, the only half any gate compares.
    }
    deriving stock (ClientCredential -> ClientCredential -> Bool
(ClientCredential -> ClientCredential -> Bool)
-> (ClientCredential -> ClientCredential -> Bool)
-> Eq ClientCredential
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientCredential -> ClientCredential -> Bool
== :: ClientCredential -> ClientCredential -> Bool
$c/= :: ClientCredential -> ClientCredential -> Bool
/= :: ClientCredential -> ClientCredential -> Bool
Eq, Int -> ClientCredential -> ShowS
[ClientCredential] -> ShowS
ClientCredential -> String
(Int -> ClientCredential -> ShowS)
-> (ClientCredential -> String)
-> ([ClientCredential] -> ShowS)
-> Show ClientCredential
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientCredential -> ShowS
showsPrec :: Int -> ClientCredential -> ShowS
$cshow :: ClientCredential -> String
show :: ClientCredential -> String
$cshowList :: [ClientCredential] -> ShowS
showList :: [ClientCredential] -> ShowS
Show)

-- | A credential carrying no username, the form a bearer scheme recovers and a configured token takes.
bareCredential :: Secret -> ClientCredential
bareCredential :: Secret -> ClientCredential
bareCredential = Maybe Text -> Secret -> ClientCredential
ClientCredential Maybe Text
forall a. Maybe a
Nothing

{- | A bearer token for a registry endpoint. Cloud lifetimes run from CodeArtifact's ~12h to
ADC's ~1h, so a refresh schedules off 'authExpiresAt' rather than a fixed interval.
-}
data AuthToken = AuthToken
    { AuthToken -> Secret
authSecret :: Secret
    -- ^ The bearer secret itself (redacted in 'Show').
    , AuthToken -> Maybe UTCTime
authExpiresAt :: Maybe UTCTime
    -- ^ When the token expires. 'Nothing' for a static token, which does not expire.
    }
    deriving stock (AuthToken -> AuthToken -> Bool
(AuthToken -> AuthToken -> Bool)
-> (AuthToken -> AuthToken -> Bool) -> Eq AuthToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthToken -> AuthToken -> Bool
== :: AuthToken -> AuthToken -> Bool
$c/= :: AuthToken -> AuthToken -> Bool
/= :: AuthToken -> AuthToken -> Bool
Eq, Int -> AuthToken -> ShowS
[AuthToken] -> ShowS
AuthToken -> String
(Int -> AuthToken -> ShowS)
-> (AuthToken -> String)
-> ([AuthToken] -> ShowS)
-> Show AuthToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthToken -> ShowS
showsPrec :: Int -> AuthToken -> ShowS
$cshow :: AuthToken -> String
show :: AuthToken -> String
$cshowList :: [AuthToken] -> ShowS
showList :: [AuthToken] -> ShowS
Show)

{- | The credential handle: it yields the token currently valid for the mirror target and
refreshes it before expiry internally, so no caller blocks on a mint on the hot path.
-}
newtype CredentialProvider = CredentialProvider
    { CredentialProvider -> IO AuthToken
currentToken :: IO AuthToken
    -- ^ 'IO', not @App@, so an adapter closing over its own backend state stays off the core.
    }

{- | The secret a provider's current token carries, for a caller that presents it and reads no
expiry. It refreshes behind the provider, so a long-lived caller mints per use.
-}
mintSecret :: CredentialProvider -> IO Secret
mintSecret :: CredentialProvider -> IO Secret
mintSecret = (AuthToken -> Secret) -> IO AuthToken -> IO Secret
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AuthToken -> Secret
authSecret (IO AuthToken -> IO Secret)
-> (CredentialProvider -> IO AuthToken)
-> CredentialProvider
-> IO Secret
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CredentialProvider -> IO AuthToken
currentToken

{- | A 'CredentialProvider' that always returns the same token, the @static@ leaf. It never
refreshes, so it fits a registry reached with a long-lived credential.
-}
staticProvider :: AuthToken -> CredentialProvider
staticProvider :: AuthToken -> CredentialProvider
staticProvider AuthToken
token = CredentialProvider{currentToken :: IO AuthToken
currentToken = AuthToken -> IO AuthToken
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthToken
token}