{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

{- |
Module      : MCP.Server.Auth
Description : MCP-compliant OAuth 2.1 authentication
Copyright   : (C) 2025 Matthias Pall Gissurarson
License     : MIT
Maintainer  : mpg@mpg.is
Stability   : experimental
Portability : GHC

This module provides MCP-compliant OAuth 2.1 authentication with PKCE support.
-}
module MCP.Server.Auth (
    -- * OAuth Configuration
    OAuthConfig (..),
    OAuthProvider (..),
    OAuthGrantType (..),

    -- * Token Validation
    TokenInfo (..),
    validateBearerToken,
    extractBearerToken,

    -- * PKCE Support
    PKCEChallenge (..),
    generateCodeVerifier,
    generateCodeChallenge,
    validateCodeVerifier,

    -- * Metadata Discovery
    OAuthMetadata (..),
    discoverOAuthMetadata,
) where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Crypto.Hash (hashWith)
import Crypto.Hash.Algorithms (SHA256 (..))
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as Aeson
import Data.ByteArray (convert)
import Data.ByteString (ByteString)
import Data.ByteString.Base64.URL qualified as B64URL
import Data.ByteString.Lazy qualified as LBS
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import GHC.Generics (Generic)
import Network.HTTP.Simple (addRequestHeader, getResponseBody, httpJSON, parseRequest, setRequestBodyJSON, setRequestMethod)
import System.Random (newStdGen, randomRs)

-- | OAuth grant types supported by MCP
data OAuthGrantType
    = AuthorizationCode -- For user-based scenarios
    | ClientCredentials -- For application-to-application
    deriving (Int -> OAuthGrantType -> ShowS
[OAuthGrantType] -> ShowS
OAuthGrantType -> String
(Int -> OAuthGrantType -> ShowS)
-> (OAuthGrantType -> String)
-> ([OAuthGrantType] -> ShowS)
-> Show OAuthGrantType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OAuthGrantType -> ShowS
showsPrec :: Int -> OAuthGrantType -> ShowS
$cshow :: OAuthGrantType -> String
show :: OAuthGrantType -> String
$cshowList :: [OAuthGrantType] -> ShowS
showList :: [OAuthGrantType] -> ShowS
Show, OAuthGrantType -> OAuthGrantType -> Bool
(OAuthGrantType -> OAuthGrantType -> Bool)
-> (OAuthGrantType -> OAuthGrantType -> Bool) -> Eq OAuthGrantType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OAuthGrantType -> OAuthGrantType -> Bool
== :: OAuthGrantType -> OAuthGrantType -> Bool
$c/= :: OAuthGrantType -> OAuthGrantType -> Bool
/= :: OAuthGrantType -> OAuthGrantType -> Bool
Eq, (forall x. OAuthGrantType -> Rep OAuthGrantType x)
-> (forall x. Rep OAuthGrantType x -> OAuthGrantType)
-> Generic OAuthGrantType
forall x. Rep OAuthGrantType x -> OAuthGrantType
forall x. OAuthGrantType -> Rep OAuthGrantType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OAuthGrantType -> Rep OAuthGrantType x
from :: forall x. OAuthGrantType -> Rep OAuthGrantType x
$cto :: forall x. Rep OAuthGrantType x -> OAuthGrantType
to :: forall x. Rep OAuthGrantType x -> OAuthGrantType
Generic)

-- | OAuth provider configuration (MCP-compliant)
data OAuthProvider = OAuthProvider
    { OAuthProvider -> Text
providerName :: Text
    , OAuthProvider -> Text
clientId :: Text
    , OAuthProvider -> Maybe Text
clientSecret :: Maybe Text -- Optional for public clients
    , OAuthProvider -> Text
authorizationEndpoint :: Text
    , OAuthProvider -> Text
tokenEndpoint :: Text
    , OAuthProvider -> Maybe Text
userInfoEndpoint :: Maybe Text
    , OAuthProvider -> [Text]
scopes :: [Text]
    , OAuthProvider -> [OAuthGrantType]
grantTypes :: [OAuthGrantType]
    , OAuthProvider -> Bool
requiresPKCE :: Bool -- MCP requires PKCE for all clients
    , OAuthProvider -> Maybe Text
metadataEndpoint :: Maybe Text -- For OAuth metadata discovery
    }
    deriving (Int -> OAuthProvider -> ShowS
[OAuthProvider] -> ShowS
OAuthProvider -> String
(Int -> OAuthProvider -> ShowS)
-> (OAuthProvider -> String)
-> ([OAuthProvider] -> ShowS)
-> Show OAuthProvider
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OAuthProvider -> ShowS
showsPrec :: Int -> OAuthProvider -> ShowS
$cshow :: OAuthProvider -> String
show :: OAuthProvider -> String
$cshowList :: [OAuthProvider] -> ShowS
showList :: [OAuthProvider] -> ShowS
Show, (forall x. OAuthProvider -> Rep OAuthProvider x)
-> (forall x. Rep OAuthProvider x -> OAuthProvider)
-> Generic OAuthProvider
forall x. Rep OAuthProvider x -> OAuthProvider
forall x. OAuthProvider -> Rep OAuthProvider x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OAuthProvider -> Rep OAuthProvider x
from :: forall x. OAuthProvider -> Rep OAuthProvider x
$cto :: forall x. Rep OAuthProvider x -> OAuthProvider
to :: forall x. Rep OAuthProvider x -> OAuthProvider
Generic)

-- | OAuth configuration for the MCP server
data OAuthConfig = OAuthConfig
    { OAuthConfig -> Bool
oauthEnabled :: Bool
    , OAuthConfig -> [OAuthProvider]
oauthProviders :: [OAuthProvider]
    , OAuthConfig -> Maybe Text
tokenValidationEndpoint :: Maybe Text -- For validating tokens
    , OAuthConfig -> Bool
requireHTTPS :: Bool -- MCP requires HTTPS for OAuth
    -- Configurable timing parameters
    , OAuthConfig -> Int
authCodeExpirySeconds :: Int
    , OAuthConfig -> Int
accessTokenExpirySeconds :: Int
    , -- Configurable OAuth parameters
      OAuthConfig -> [Text]
supportedScopes :: [Text]
    , OAuthConfig -> [Text]
supportedResponseTypes :: [Text]
    , OAuthConfig -> [Text]
supportedGrantTypes :: [Text]
    , OAuthConfig -> [Text]
supportedAuthMethods :: [Text]
    , OAuthConfig -> [Text]
supportedCodeChallengeMethods :: [Text]
    , -- Demo mode settings
      OAuthConfig -> Bool
autoApproveAuth :: Bool
    , OAuthConfig -> Maybe Text
demoUserIdTemplate :: Maybe Text -- Nothing means no demo mode
    , OAuthConfig -> Text
demoEmailDomain :: Text
    , OAuthConfig -> Text
demoUserName :: Text
    , OAuthConfig -> Maybe Text
publicClientSecret :: Maybe Text
    , -- Token prefixes
      OAuthConfig -> Text
authCodePrefix :: Text
    , OAuthConfig -> Text
refreshTokenPrefix :: Text
    , OAuthConfig -> Text
clientIdPrefix :: Text
    , -- Response templates
      OAuthConfig -> Maybe Text
authorizationSuccessTemplate :: Maybe Text
    }
    deriving (Int -> OAuthConfig -> ShowS
[OAuthConfig] -> ShowS
OAuthConfig -> String
(Int -> OAuthConfig -> ShowS)
-> (OAuthConfig -> String)
-> ([OAuthConfig] -> ShowS)
-> Show OAuthConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OAuthConfig -> ShowS
showsPrec :: Int -> OAuthConfig -> ShowS
$cshow :: OAuthConfig -> String
show :: OAuthConfig -> String
$cshowList :: [OAuthConfig] -> ShowS
showList :: [OAuthConfig] -> ShowS
Show, (forall x. OAuthConfig -> Rep OAuthConfig x)
-> (forall x. Rep OAuthConfig x -> OAuthConfig)
-> Generic OAuthConfig
forall x. Rep OAuthConfig x -> OAuthConfig
forall x. OAuthConfig -> Rep OAuthConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OAuthConfig -> Rep OAuthConfig x
from :: forall x. OAuthConfig -> Rep OAuthConfig x
$cto :: forall x. Rep OAuthConfig x -> OAuthConfig
to :: forall x. Rep OAuthConfig x -> OAuthConfig
Generic)

-- | PKCE challenge data
data PKCEChallenge = PKCEChallenge
    { PKCEChallenge -> Text
codeVerifier :: Text
    , PKCEChallenge -> Text
codeChallenge :: Text
    , PKCEChallenge -> Text
challengeMethod :: Text -- Always "S256" for MCP
    }
    deriving (Int -> PKCEChallenge -> ShowS
[PKCEChallenge] -> ShowS
PKCEChallenge -> String
(Int -> PKCEChallenge -> ShowS)
-> (PKCEChallenge -> String)
-> ([PKCEChallenge] -> ShowS)
-> Show PKCEChallenge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKCEChallenge -> ShowS
showsPrec :: Int -> PKCEChallenge -> ShowS
$cshow :: PKCEChallenge -> String
show :: PKCEChallenge -> String
$cshowList :: [PKCEChallenge] -> ShowS
showList :: [PKCEChallenge] -> ShowS
Show, (forall x. PKCEChallenge -> Rep PKCEChallenge x)
-> (forall x. Rep PKCEChallenge x -> PKCEChallenge)
-> Generic PKCEChallenge
forall x. Rep PKCEChallenge x -> PKCEChallenge
forall x. PKCEChallenge -> Rep PKCEChallenge x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PKCEChallenge -> Rep PKCEChallenge x
from :: forall x. PKCEChallenge -> Rep PKCEChallenge x
$cto :: forall x. Rep PKCEChallenge x -> PKCEChallenge
to :: forall x. Rep PKCEChallenge x -> PKCEChallenge
Generic)

-- | OAuth metadata (from discovery endpoint)
data OAuthMetadata = OAuthMetadata
    { OAuthMetadata -> Text
issuer :: Text
    , OAuthMetadata -> Text
authorizationEndpoint :: Text
    , OAuthMetadata -> Text
tokenEndpoint :: Text
    , OAuthMetadata -> Maybe Text
registrationEndpoint :: Maybe Text
    , OAuthMetadata -> Maybe Text
userInfoEndpoint :: Maybe Text
    , OAuthMetadata -> Maybe Text
jwksUri :: Maybe Text
    , OAuthMetadata -> Maybe [Text]
scopesSupported :: Maybe [Text]
    , OAuthMetadata -> [Text]
responseTypesSupported :: [Text]
    , OAuthMetadata -> Maybe [Text]
grantTypesSupported :: Maybe [Text]
    , OAuthMetadata -> Maybe [Text]
tokenEndpointAuthMethodsSupported :: Maybe [Text]
    , OAuthMetadata -> Maybe [Text]
codeChallengeMethodsSupported :: Maybe [Text]
    }
    deriving (Int -> OAuthMetadata -> ShowS
[OAuthMetadata] -> ShowS
OAuthMetadata -> String
(Int -> OAuthMetadata -> ShowS)
-> (OAuthMetadata -> String)
-> ([OAuthMetadata] -> ShowS)
-> Show OAuthMetadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OAuthMetadata -> ShowS
showsPrec :: Int -> OAuthMetadata -> ShowS
$cshow :: OAuthMetadata -> String
show :: OAuthMetadata -> String
$cshowList :: [OAuthMetadata] -> ShowS
showList :: [OAuthMetadata] -> ShowS
Show, (forall x. OAuthMetadata -> Rep OAuthMetadata x)
-> (forall x. Rep OAuthMetadata x -> OAuthMetadata)
-> Generic OAuthMetadata
forall x. Rep OAuthMetadata x -> OAuthMetadata
forall x. OAuthMetadata -> Rep OAuthMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OAuthMetadata -> Rep OAuthMetadata x
from :: forall x. OAuthMetadata -> Rep OAuthMetadata x
$cto :: forall x. Rep OAuthMetadata x -> OAuthMetadata
to :: forall x. Rep OAuthMetadata x -> OAuthMetadata
Generic)

instance FromJSON OAuthMetadata where
    parseJSON :: Value -> Parser OAuthMetadata
parseJSON = String
-> (Object -> Parser OAuthMetadata)
-> Value
-> Parser OAuthMetadata
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"OAuthMetadata" ((Object -> Parser OAuthMetadata) -> Value -> Parser OAuthMetadata)
-> (Object -> Parser OAuthMetadata)
-> Value
-> Parser OAuthMetadata
forall a b. (a -> b) -> a -> b
$ \Object
v ->
        Text
-> Text
-> Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe [Text]
-> [Text]
-> Maybe [Text]
-> Maybe [Text]
-> Maybe [Text]
-> OAuthMetadata
OAuthMetadata
            (Text
 -> Text
 -> Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe [Text]
 -> [Text]
 -> Maybe [Text]
 -> Maybe [Text]
 -> Maybe [Text]
 -> OAuthMetadata)
-> Parser Text
-> Parser
     (Text
      -> Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe [Text]
      -> [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> OAuthMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"issuer"
            Parser
  (Text
   -> Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe [Text]
   -> [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> OAuthMetadata)
-> Parser Text
-> Parser
     (Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe [Text]
      -> [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"authorization_endpoint"
            Parser
  (Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe [Text]
   -> [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> OAuthMetadata)
-> Parser Text
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe [Text]
      -> [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"token_endpoint"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe [Text]
   -> [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> OAuthMetadata)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe [Text]
      -> [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"registration_endpoint"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe [Text]
   -> [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> OAuthMetadata)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe [Text]
      -> [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"userinfo_endpoint"
            Parser
  (Maybe Text
   -> Maybe [Text]
   -> [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> OAuthMetadata)
-> Parser (Maybe Text)
-> Parser
     (Maybe [Text]
      -> [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> Maybe [Text]
      -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"jwks_uri"
            Parser
  (Maybe [Text]
   -> [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> Maybe [Text]
   -> OAuthMetadata)
-> Parser (Maybe [Text])
-> Parser
     ([Text]
      -> Maybe [Text] -> Maybe [Text] -> Maybe [Text] -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"scopes_supported"
            Parser
  ([Text]
   -> Maybe [Text] -> Maybe [Text] -> Maybe [Text] -> OAuthMetadata)
-> Parser [Text]
-> Parser
     (Maybe [Text] -> Maybe [Text] -> Maybe [Text] -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"response_types_supported"
            Parser
  (Maybe [Text] -> Maybe [Text] -> Maybe [Text] -> OAuthMetadata)
-> Parser (Maybe [Text])
-> Parser (Maybe [Text] -> Maybe [Text] -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"grant_types_supported"
            Parser (Maybe [Text] -> Maybe [Text] -> OAuthMetadata)
-> Parser (Maybe [Text]) -> Parser (Maybe [Text] -> OAuthMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"token_endpoint_auth_methods_supported"
            Parser (Maybe [Text] -> OAuthMetadata)
-> Parser (Maybe [Text]) -> Parser OAuthMetadata
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"code_challenge_methods_supported"

instance ToJSON OAuthMetadata where
    toJSON :: OAuthMetadata -> Value
toJSON OAuthMetadata{[Text]
Maybe [Text]
Maybe Text
Text
$sel:issuer:OAuthMetadata :: OAuthMetadata -> Text
$sel:authorizationEndpoint:OAuthMetadata :: OAuthMetadata -> Text
$sel:tokenEndpoint:OAuthMetadata :: OAuthMetadata -> Text
$sel:registrationEndpoint:OAuthMetadata :: OAuthMetadata -> Maybe Text
$sel:userInfoEndpoint:OAuthMetadata :: OAuthMetadata -> Maybe Text
$sel:jwksUri:OAuthMetadata :: OAuthMetadata -> Maybe Text
$sel:scopesSupported:OAuthMetadata :: OAuthMetadata -> Maybe [Text]
$sel:responseTypesSupported:OAuthMetadata :: OAuthMetadata -> [Text]
$sel:grantTypesSupported:OAuthMetadata :: OAuthMetadata -> Maybe [Text]
$sel:tokenEndpointAuthMethodsSupported:OAuthMetadata :: OAuthMetadata -> Maybe [Text]
$sel:codeChallengeMethodsSupported:OAuthMetadata :: OAuthMetadata -> Maybe [Text]
issuer :: Text
authorizationEndpoint :: Text
tokenEndpoint :: Text
registrationEndpoint :: Maybe Text
userInfoEndpoint :: Maybe Text
jwksUri :: Maybe Text
scopesSupported :: Maybe [Text]
responseTypesSupported :: [Text]
grantTypesSupported :: Maybe [Text]
tokenEndpointAuthMethodsSupported :: Maybe [Text]
codeChallengeMethodsSupported :: Maybe [Text]
..} =
        [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
            [ Key
"issuer" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
issuer
            , Key
"authorization_endpoint" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
authorizationEndpoint
            , Key
"token_endpoint" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
tokenEndpoint
            , Key
"response_types_supported" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [Text]
responseTypesSupported
            ]
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
x -> [Key
"registration_endpoint" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
x]) Maybe Text
registrationEndpoint
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
x -> [Key
"userinfo_endpoint" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
x]) Maybe Text
userInfoEndpoint
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
x -> [Key
"jwks_uri" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
x]) Maybe Text
jwksUri
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> ([Text] -> [Pair]) -> Maybe [Text] -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\[Text]
x -> [Key
"scopes_supported" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [Text]
x]) Maybe [Text]
scopesSupported
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> ([Text] -> [Pair]) -> Maybe [Text] -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\[Text]
x -> [Key
"grant_types_supported" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [Text]
x]) Maybe [Text]
grantTypesSupported
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> ([Text] -> [Pair]) -> Maybe [Text] -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\[Text]
x -> [Key
"token_endpoint_auth_methods_supported" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [Text]
x]) Maybe [Text]
tokenEndpointAuthMethodsSupported
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> ([Text] -> [Pair]) -> Maybe [Text] -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\[Text]
x -> [Key
"code_challenge_methods_supported" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [Text]
x]) Maybe [Text]
codeChallengeMethodsSupported

-- | Token introspection response
data TokenInfo = TokenInfo
    { TokenInfo -> Bool
active :: Bool
    , TokenInfo -> Maybe Text
scope :: Maybe Text
    , TokenInfo -> Maybe Text
clientId :: Maybe Text
    , TokenInfo -> Maybe Text
username :: Maybe Text
    , TokenInfo -> Maybe Text
tokenType :: Maybe Text
    , TokenInfo -> Maybe Integer
exp :: Maybe Integer -- Expiration time (Unix timestamp)
    , TokenInfo -> Maybe Integer
iat :: Maybe Integer -- Issued at time (Unix timestamp)
    , TokenInfo -> Maybe Integer
nbf :: Maybe Integer -- Not before time (Unix timestamp)
    , TokenInfo -> Maybe Text
sub :: Maybe Text -- Subject
    , TokenInfo -> Maybe [Text]
aud :: Maybe [Text] -- Audience
    , TokenInfo -> Maybe Text
iss :: Maybe Text -- Issuer
    }
    deriving (Int -> TokenInfo -> ShowS
[TokenInfo] -> ShowS
TokenInfo -> String
(Int -> TokenInfo -> ShowS)
-> (TokenInfo -> String)
-> ([TokenInfo] -> ShowS)
-> Show TokenInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokenInfo -> ShowS
showsPrec :: Int -> TokenInfo -> ShowS
$cshow :: TokenInfo -> String
show :: TokenInfo -> String
$cshowList :: [TokenInfo] -> ShowS
showList :: [TokenInfo] -> ShowS
Show, (forall x. TokenInfo -> Rep TokenInfo x)
-> (forall x. Rep TokenInfo x -> TokenInfo) -> Generic TokenInfo
forall x. Rep TokenInfo x -> TokenInfo
forall x. TokenInfo -> Rep TokenInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TokenInfo -> Rep TokenInfo x
from :: forall x. TokenInfo -> Rep TokenInfo x
$cto :: forall x. Rep TokenInfo x -> TokenInfo
to :: forall x. Rep TokenInfo x -> TokenInfo
Generic)

instance FromJSON TokenInfo where
    parseJSON :: Value -> Parser TokenInfo
parseJSON = String -> (Object -> Parser TokenInfo) -> Value -> Parser TokenInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"TokenInfo" ((Object -> Parser TokenInfo) -> Value -> Parser TokenInfo)
-> (Object -> Parser TokenInfo) -> Value -> Parser TokenInfo
forall a b. (a -> b) -> a -> b
$ \Object
v ->
        Bool
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Integer
-> Maybe Integer
-> Maybe Integer
-> Maybe Text
-> Maybe [Text]
-> Maybe Text
-> TokenInfo
TokenInfo
            (Bool
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Integer
 -> Maybe Integer
 -> Maybe Integer
 -> Maybe Text
 -> Maybe [Text]
 -> Maybe Text
 -> TokenInfo)
-> Parser Bool
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Text
      -> Maybe [Text]
      -> Maybe Text
      -> TokenInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"active"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Text
   -> Maybe [Text]
   -> Maybe Text
   -> TokenInfo)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Text
      -> Maybe [Text]
      -> Maybe Text
      -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"scope"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Text
   -> Maybe [Text]
   -> Maybe Text
   -> TokenInfo)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Text
      -> Maybe [Text]
      -> Maybe Text
      -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"client_id"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Text
   -> Maybe [Text]
   -> Maybe Text
   -> TokenInfo)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Text
      -> Maybe [Text]
      -> Maybe Text
      -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"username"
            Parser
  (Maybe Text
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Text
   -> Maybe [Text]
   -> Maybe Text
   -> TokenInfo)
-> Parser (Maybe Text)
-> Parser
     (Maybe Integer
      -> Maybe Integer
      -> Maybe Integer
      -> Maybe Text
      -> Maybe [Text]
      -> Maybe Text
      -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"token_type"
            Parser
  (Maybe Integer
   -> Maybe Integer
   -> Maybe Integer
   -> Maybe Text
   -> Maybe [Text]
   -> Maybe Text
   -> TokenInfo)
-> Parser (Maybe Integer)
-> Parser
     (Maybe Integer
      -> Maybe Integer
      -> Maybe Text
      -> Maybe [Text]
      -> Maybe Text
      -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"exp"
            Parser
  (Maybe Integer
   -> Maybe Integer
   -> Maybe Text
   -> Maybe [Text]
   -> Maybe Text
   -> TokenInfo)
-> Parser (Maybe Integer)
-> Parser
     (Maybe Integer
      -> Maybe Text -> Maybe [Text] -> Maybe Text -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"iat"
            Parser
  (Maybe Integer
   -> Maybe Text -> Maybe [Text] -> Maybe Text -> TokenInfo)
-> Parser (Maybe Integer)
-> Parser (Maybe Text -> Maybe [Text] -> Maybe Text -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"nbf"
            Parser (Maybe Text -> Maybe [Text] -> Maybe Text -> TokenInfo)
-> Parser (Maybe Text)
-> Parser (Maybe [Text] -> Maybe Text -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"sub"
            Parser (Maybe [Text] -> Maybe Text -> TokenInfo)
-> Parser (Maybe [Text]) -> Parser (Maybe Text -> TokenInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"aud"
            Parser (Maybe Text -> TokenInfo)
-> Parser (Maybe Text) -> Parser TokenInfo
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"iss"

-- | Extract Bearer token from Authorization header
extractBearerToken :: Text -> Maybe Text
extractBearerToken :: Text -> Maybe Text
extractBearerToken Text
authHeader =
    case Text -> [Text]
T.words Text
authHeader of
        [Text
"Bearer", Text
token] -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
token
        [Text]
_ -> Maybe Text
forall a. Maybe a
Nothing

-- | Validate a bearer token
validateBearerToken :: (MonadIO m) => OAuthConfig -> Text -> m (Either Text TokenInfo)
validateBearerToken :: forall (m :: * -> *).
MonadIO m =>
OAuthConfig -> Text -> m (Either Text TokenInfo)
validateBearerToken OAuthConfig
config Text
token = do
    -- Basic validation
    if Text -> Bool
T.null Text
token
        then Either Text TokenInfo -> m (Either Text TokenInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text TokenInfo -> m (Either Text TokenInfo))
-> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text TokenInfo
forall a b. a -> Either a b
Left Text
"Empty token"
        else case OAuthConfig -> Maybe Text
tokenValidationEndpoint OAuthConfig
config of
            Just Text
endpoint -> Text -> Text -> m (Either Text TokenInfo)
forall (m :: * -> *).
MonadIO m =>
Text -> Text -> m (Either Text TokenInfo)
introspectToken Text
endpoint Text
token
            Maybe Text
Nothing -> do
                -- Without an introspection endpoint, perform basic JWT validation
                -- In production, this should:
                -- 1. Verify JWT signature using JWK from jwks_uri
                -- 2. Check expiration time
                -- 3. Validate issuer and audience
                -- 4. Check token type is "Bearer"

                -- For now, decode JWT payload (middle part) for basic validation
                case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
token of
                    [Text
_header, Text
payload, Text
_signature] -> do
                        UTCTime
currentTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                        case Text -> Either Text TokenInfo
decodeJWTPayload Text
payload of
                            Right TokenInfo
tokenInfo ->
                                case TokenInfo -> UTCTime -> Either Text ()
validateTokenClaims TokenInfo
tokenInfo UTCTime
currentTime of
                                    Right ()
_ -> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text TokenInfo -> m (Either Text TokenInfo))
-> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a b. (a -> b) -> a -> b
$ TokenInfo -> Either Text TokenInfo
forall a b. b -> Either a b
Right TokenInfo
tokenInfo
                                    Left Text
err -> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text TokenInfo -> m (Either Text TokenInfo))
-> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text TokenInfo
forall a b. a -> Either a b
Left Text
err
                            Left Text
err -> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text TokenInfo -> m (Either Text TokenInfo))
-> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text TokenInfo
forall a b. a -> Either a b
Left (Text -> Either Text TokenInfo) -> Text -> Either Text TokenInfo
forall a b. (a -> b) -> a -> b
$ Text
"Invalid JWT format: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
                    [Text]
_ -> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text TokenInfo -> m (Either Text TokenInfo))
-> Either Text TokenInfo -> m (Either Text TokenInfo)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text TokenInfo
forall a b. a -> Either a b
Left Text
"Invalid JWT structure"

-- | Introspect token using OAuth introspection endpoint
introspectToken :: (MonadIO m) => Text -> Text -> m (Either Text TokenInfo)
introspectToken :: forall (m :: * -> *).
MonadIO m =>
Text -> Text -> m (Either Text TokenInfo)
introspectToken Text
endpoint Text
token = IO (Either Text TokenInfo) -> m (Either Text TokenInfo)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text TokenInfo) -> m (Either Text TokenInfo))
-> IO (Either Text TokenInfo) -> m (Either Text TokenInfo)
forall a b. (a -> b) -> a -> b
$ do
    let url :: String
url = Text -> String
T.unpack Text
endpoint
    Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
    let requestWithBody :: Request
requestWithBody =
            ByteString -> Request -> Request
setRequestMethod ByteString
"POST" (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
                Value -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON ([Pair] -> Value
Aeson.object [(Key
"token", Text -> Value
Aeson.String Text
token)]) (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
                    HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
"Content-Type" ByteString
"application/json" Request
request

    Response TokenInfo
response <- Request -> IO (Response TokenInfo)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON Request
requestWithBody
    let tokenInfo :: TokenInfo
tokenInfo = Response TokenInfo -> TokenInfo
forall a. Response a -> a
getResponseBody Response TokenInfo
response

    if TokenInfo -> Bool
active TokenInfo
tokenInfo
        then Either Text TokenInfo -> IO (Either Text TokenInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text TokenInfo -> IO (Either Text TokenInfo))
-> Either Text TokenInfo -> IO (Either Text TokenInfo)
forall a b. (a -> b) -> a -> b
$ TokenInfo -> Either Text TokenInfo
forall a b. b -> Either a b
Right TokenInfo
tokenInfo
        else Either Text TokenInfo -> IO (Either Text TokenInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text TokenInfo -> IO (Either Text TokenInfo))
-> Either Text TokenInfo -> IO (Either Text TokenInfo)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text TokenInfo
forall a b. a -> Either a b
Left Text
"Token is not active"

-- | Decode JWT payload (base64url encoded JSON)
decodeJWTPayload :: Text -> Either Text TokenInfo
decodeJWTPayload :: Text -> Either Text TokenInfo
decodeJWTPayload Text
payload =
    case ByteString -> Either String ByteString
B64URL.decodeUnpadded (Text -> ByteString
TE.encodeUtf8 Text
payload) of
        Right ByteString
decodedBytes ->
            case ByteString -> Maybe TokenInfo
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode' (ByteString -> ByteString
LBS.fromStrict ByteString
decodedBytes) of
                Just TokenInfo
info -> TokenInfo -> Either Text TokenInfo
forall a b. b -> Either a b
Right TokenInfo
info{active = True} -- JWT is implicitly active
                Maybe TokenInfo
Nothing -> Text -> Either Text TokenInfo
forall a b. a -> Either a b
Left Text
"Failed to parse JWT payload"
        Left String
_ -> Text -> Either Text TokenInfo
forall a b. a -> Either a b
Left Text
"Invalid base64url encoding"

-- | Validate token claims (expiration, not-before, etc.)
validateTokenClaims :: TokenInfo -> UTCTime -> Either Text ()
validateTokenClaims :: TokenInfo -> UTCTime -> Either Text ()
validateTokenClaims TokenInfo
tokenInfo UTCTime
currentTime = do
    let currentTimestamp :: Integer
currentTimestamp = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
currentTime) :: Double) :: Integer

    -- Check expiration
    case TokenInfo -> Maybe Integer
MCP.Server.Auth.exp TokenInfo
tokenInfo of
        Just Integer
expTime ->
            if Integer
currentTimestamp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
expTime
                then Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"Token has expired"
                else () -> Either Text ()
forall a b. b -> Either a b
Right ()
        Maybe Integer
Nothing -> () -> Either Text ()
forall a b. b -> Either a b
Right ()

    -- Check not-before
    case TokenInfo -> Maybe Integer
MCP.Server.Auth.nbf TokenInfo
tokenInfo of
        Just Integer
nbfTime ->
            if Integer
currentTimestamp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
nbfTime
                then Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"Token not yet valid"
                else () -> Either Text ()
forall a b. b -> Either a b
Right ()
        Maybe Integer
Nothing -> () -> Either Text ()
forall a b. b -> Either a b
Right ()

    () -> Either Text ()
forall a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Generate a cryptographically secure code verifier for PKCE
generateCodeVerifier :: IO Text
generateCodeVerifier :: IO Text
generateCodeVerifier = do
    StdGen
gen <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
    let chars :: String
chars = [Char
'A' .. Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a' .. Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-._~"
    let verifier :: [Int]
verifier = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
128 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> StdGen -> [Int]
forall g. RandomGen g => (Int, Int) -> g -> [Int]
forall a g. (Random a, RandomGen g) => (a, a) -> g -> [a]
randomRs (Int
0, String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
chars Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) StdGen
gen
    Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map (String
chars !!) [Int]
verifier

-- | Generate code challenge from verifier using SHA256 (S256 method)
generateCodeChallenge :: Text -> Text
generateCodeChallenge :: Text -> Text
generateCodeChallenge Text
verifier =
    let verifierBytes :: ByteString
verifierBytes = Text -> ByteString
TE.encodeUtf8 Text
verifier
        challengeHash :: Digest SHA256
challengeHash = SHA256 -> ByteString -> Digest SHA256
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256 ByteString
verifierBytes
        challengeBytes :: ByteString
challengeBytes = Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert Digest SHA256
challengeHash :: ByteString
     in ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64URL.encodeUnpadded ByteString
challengeBytes

-- | Validate PKCE code verifier against challenge
validateCodeVerifier :: Text -> Text -> Bool
validateCodeVerifier :: Text -> Text -> Bool
validateCodeVerifier Text
verifier Text
challenge =
    Text -> Text
generateCodeChallenge Text
verifier Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
challenge

-- | Discover OAuth metadata from a well-known endpoint
discoverOAuthMetadata :: (MonadIO m) => Text -> m (Either String OAuthMetadata)
discoverOAuthMetadata :: forall (m :: * -> *).
MonadIO m =>
Text -> m (Either String OAuthMetadata)
discoverOAuthMetadata Text
issuerUrl = IO (Either String OAuthMetadata) -> m (Either String OAuthMetadata)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String OAuthMetadata)
 -> m (Either String OAuthMetadata))
-> IO (Either String OAuthMetadata)
-> m (Either String OAuthMetadata)
forall a b. (a -> b) -> a -> b
$ do
    let wellKnownUrl :: String
wellKnownUrl = Text -> String
T.unpack Text
issuerUrl String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/.well-known/openid-configuration"
    Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
wellKnownUrl
    Response OAuthMetadata
response <- Request -> IO (Response OAuthMetadata)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON Request
request
    Either String OAuthMetadata -> IO (Either String OAuthMetadata)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String OAuthMetadata -> IO (Either String OAuthMetadata))
-> Either String OAuthMetadata -> IO (Either String OAuthMetadata)
forall a b. (a -> b) -> a -> b
$ OAuthMetadata -> Either String OAuthMetadata
forall a b. b -> Either a b
Right (Response OAuthMetadata -> OAuthMetadata
forall a. Response a -> a
getResponseBody Response OAuthMetadata
response)