Domain.hs

-- | The claims embedded in an access token, plus the small newtypes that make the claim
-- fields type-safe.
module Shomei.Authorization.Claims.Domain
  ( Issuer (..),
    Audience (..),
    Scope (..),
    Role (..),
    validRoleName,
    validScopeName,
    Permission (..),
    AuthClaims (..),
    reservedClaimKeys,
    mkExtraClaims,
    noExtraClaims,
  )
where

import Data.Aeson (Object, withText)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Char (isSpace)
import Data.Set (Set)
import Data.Text qualified as Text
import Shomei.Id (SessionId, UserId)
import Shomei.Prelude

newtype Issuer = Issuer Text
  deriving stock (Generic)
  deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)

newtype Audience = Audience Text
  deriving stock (Generic)
  deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)

newtype Scope = Scope Text
  deriving stock (Generic)
  deriving newtype (Eq, Ord, Show, ToJSON)

validScopeName :: Scope -> Bool
validScopeName (Scope t) = not (Text.null t) && Text.length t <= 128 && not (Text.any isSpace t)

instance FromJSON Scope where
  parseJSON = withText "Scope" \t ->
    if validScopeName (Scope t) then pure (Scope t) else fail "invalid scope name"

newtype Role = Role Text
  deriving stock (Generic)
  deriving newtype (Eq, Ord, Show, ToJSON)

-- Preserve the established vocabulary, including internal whitespace in role names.
validRoleName :: Role -> Bool
validRoleName (Role t) = not (Text.null (Text.strip t)) && Text.length t <= 128

instance FromJSON Role where
  parseJSON = withText "Role" \t ->
    if validRoleName (Role t) then pure (Role (Text.strip t)) else fail "invalid role name"

-- | A capability string carried in the @permissions@ claim, resolved at mint time from the
-- subject's roles (the @shomei_role_permissions@ table). Convention: @resource:verb@, e.g.
-- @projects:write@ — a documented convention, not enforced grammar.
newtype Permission = Permission Text
  deriving stock (Generic)
  deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)

data AuthClaims = AuthClaims
  { subject :: !UserId,
    sessionId :: !SessionId,
    issuer :: !Issuer,
    audience :: !Audience,
    issuedAt :: !UTCTime,
    expiresAt :: !UTCTime,
    -- | when the last credential was proven. Unlike 'issuedAt', this is preserved across token
    -- refresh and is the clock for reauthentication gates.
    authTime :: !UTCTime,
    scopes :: !(Set Scope),
    roles :: !(Set Role),
    -- | the capabilities the subject's roles imply (EP-9), resolved at mint time from the
    --     @shomei_role_permissions@ catalog and carried in the @permissions@ claim. Empty for
    --     tokens minted before EP-9 (and for OAuth machine/delegation flows, which do
    --     not go through role enrichment); a token with no @permissions@ claim verifies to the
    --     empty set, exactly as @roles@ does.
    permissions :: !(Set Permission),
    -- | when this token is a delegated (impersonation) token, the real operator
    -- acting on behalf of 'subject'; serialised as the @act@ JWT claim. 'Nothing'
    -- for every ordinary login token.
    actor :: !(Maybe UserId),
    -- | additional top-level JWT claims a consuming service attaches (e.g. TAN's
    -- @userId@, @userInfo@, @impersonated@, @clientAccountId@, or a service token's
    -- @type@/@serviceInfo@). Empty ('noExtraClaims') for ordinary tokens, which then
    -- serialise byte-identically to before this field existed. Keys that collide with
    -- a standard claim are overridden by the standard claim at sign time.
    extraClaims :: !Object
  }
  deriving stock (Generic, Eq, Show)
  deriving anyclass (FromJSON, ToJSON)

-- | The registered and private claim keys Shōmei owns. The signer writes every
-- managed value after the extension bag, the verifier removes every managed value
-- from the recovered extension bag, and 'mkExtraClaims' drops every managed value
-- at construction. Adding a managed claim therefore starts by adding its name here.
reservedClaimKeys :: [Text]
reservedClaimKeys = ["iss", "sub", "aud", "iat", "exp", "nbf", "jti", "sid", "scopes", "roles", "permissions", "act", "auth_time"]

-- | Build an extra-claims object, dropping any reserved key (see 'reservedClaimKeys').
mkExtraClaims :: Object -> Object
mkExtraClaims = KeyMap.filterWithKey (\k _ -> Key.toText k `notElem` reservedClaimKeys)

-- | The empty extra-claims object — the default for ordinary tokens.
noExtraClaims :: Object
noExtraClaims = KeyMap.empty