{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{- |
Module      : MCP.Server.HTTP
Description : MCP server implementation for HTTP communication
Copyright   : (C) 2025 Matthias Pall Gissurarson
License     : MIT
Maintainer  : mpg@mpg.is
Stability   : experimental
Portability : GHC

This module provides MCP server implementation for HTTP communication.
-}
module MCP.Server.HTTP (
    -- * Server Runner
    runServerHTTP,
    HTTPServerConfig (..),

    -- * Demo Configuration Helpers
    defaultDemoOAuthConfig,
) where

import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Control.Monad.State.Strict (get, put)
import Crypto.JOSE (JWK)
import Data.Aeson (encode, fromJSON, object, toJSON, (.=))
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as LBS
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import Data.UUID qualified as UUID
import Data.UUID.V4 qualified as UUID
import GHC.Generics (Generic)
import Network.Wai (Application)
import Network.Wai.Handler.Warp (Port, run)
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
import Servant (Context (..), Handler, Proxy (..), Server, serve, serveWithContext, throwError)
import Servant.API (FormUrlEncoded, Get, JSON, PlainText, Post, QueryParam, QueryParam', ReqBody, Required, (:<|>) (..), (:>))
import Servant.Auth.Server (Auth, AuthResult (..), FromJWT, JWT, JWTSettings, ToJWT, defaultCookieSettings, defaultJWTSettings, generateKey, makeJWT)
import Servant.Server (err400, err401, err500, errBody)

import Control.Monad (unless, when)
import MCP.Protocol
import MCP.Server (MCPServer (..), MCPServerM, ServerConfig (..), ServerState (..), initialServerState, runMCPServer)
import MCP.Server.Auth (OAuthConfig (..), OAuthMetadata (..), OAuthProvider (..), validateCodeVerifier)
import MCP.Types

-- | Configuration for running an MCP HTTP server
data HTTPServerConfig = HTTPServerConfig
    { HTTPServerConfig -> Int
httpPort :: Port
    , HTTPServerConfig -> Text
httpBaseUrl :: Text -- Base URL for OAuth endpoints (e.g., "https://api.example.com")
    , HTTPServerConfig -> Implementation
httpServerInfo :: Implementation
    , HTTPServerConfig -> ServerCapabilities
httpCapabilities :: ServerCapabilities
    , HTTPServerConfig -> Bool
httpEnableLogging :: Bool
    , HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig :: Maybe OAuthConfig
    , HTTPServerConfig -> Maybe JWK
httpJWK :: Maybe JWK -- JWT signing key
    , HTTPServerConfig -> Text
httpProtocolVersion :: Text -- MCP protocol version
    }
    deriving (Int -> HTTPServerConfig -> ShowS
[HTTPServerConfig] -> ShowS
HTTPServerConfig -> String
(Int -> HTTPServerConfig -> ShowS)
-> (HTTPServerConfig -> String)
-> ([HTTPServerConfig] -> ShowS)
-> Show HTTPServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HTTPServerConfig -> ShowS
showsPrec :: Int -> HTTPServerConfig -> ShowS
$cshow :: HTTPServerConfig -> String
show :: HTTPServerConfig -> String
$cshowList :: [HTTPServerConfig] -> ShowS
showList :: [HTTPServerConfig] -> ShowS
Show)

-- | User information from OAuth
data AuthUser = AuthUser
    { AuthUser -> Text
userId :: Text
    , AuthUser -> Maybe Text
userEmail :: Maybe Text
    , AuthUser -> Maybe Text
userName :: Maybe Text
    }
    deriving (Int -> AuthUser -> ShowS
[AuthUser] -> ShowS
AuthUser -> String
(Int -> AuthUser -> ShowS)
-> (AuthUser -> String) -> ([AuthUser] -> ShowS) -> Show AuthUser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthUser -> ShowS
showsPrec :: Int -> AuthUser -> ShowS
$cshow :: AuthUser -> String
show :: AuthUser -> String
$cshowList :: [AuthUser] -> ShowS
showList :: [AuthUser] -> ShowS
Show, (forall x. AuthUser -> Rep AuthUser x)
-> (forall x. Rep AuthUser x -> AuthUser) -> Generic AuthUser
forall x. Rep AuthUser x -> AuthUser
forall x. AuthUser -> Rep AuthUser x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AuthUser -> Rep AuthUser x
from :: forall x. AuthUser -> Rep AuthUser x
$cto :: forall x. Rep AuthUser x -> AuthUser
to :: forall x. Rep AuthUser x -> AuthUser
Generic)

-- | Authorization code with PKCE
data AuthorizationCode = AuthorizationCode
    { AuthorizationCode -> Text
authCode :: Text
    , AuthorizationCode -> Text
authClientId :: Text
    , AuthorizationCode -> Text
authRedirectUri :: Text
    , AuthorizationCode -> Text
authCodeChallenge :: Text
    , AuthorizationCode -> Text
authCodeChallengeMethod :: Text
    , AuthorizationCode -> [Text]
authScopes :: [Text]
    , AuthorizationCode -> Text
authUserId :: Text
    , AuthorizationCode -> UTCTime
authExpiry :: UTCTime
    }
    deriving (Int -> AuthorizationCode -> ShowS
[AuthorizationCode] -> ShowS
AuthorizationCode -> String
(Int -> AuthorizationCode -> ShowS)
-> (AuthorizationCode -> String)
-> ([AuthorizationCode] -> ShowS)
-> Show AuthorizationCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthorizationCode -> ShowS
showsPrec :: Int -> AuthorizationCode -> ShowS
$cshow :: AuthorizationCode -> String
show :: AuthorizationCode -> String
$cshowList :: [AuthorizationCode] -> ShowS
showList :: [AuthorizationCode] -> ShowS
Show, (forall x. AuthorizationCode -> Rep AuthorizationCode x)
-> (forall x. Rep AuthorizationCode x -> AuthorizationCode)
-> Generic AuthorizationCode
forall x. Rep AuthorizationCode x -> AuthorizationCode
forall x. AuthorizationCode -> Rep AuthorizationCode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AuthorizationCode -> Rep AuthorizationCode x
from :: forall x. AuthorizationCode -> Rep AuthorizationCode x
$cto :: forall x. Rep AuthorizationCode x -> AuthorizationCode
to :: forall x. Rep AuthorizationCode x -> AuthorizationCode
Generic)

-- | OAuth server state
data OAuthState = OAuthState
    { OAuthState -> Map Text AuthorizationCode
authCodes :: Map Text AuthorizationCode -- code -> AuthorizationCode
    , OAuthState -> Map Text AuthUser
accessTokens :: Map Text AuthUser -- token -> user
    , OAuthState -> Map Text (Text, AuthUser)
refreshTokens :: Map Text (Text, AuthUser) -- refresh_token -> (access_token, user)
    , OAuthState -> Map Text ClientInfo
registeredClients :: Map Text ClientInfo -- client_id -> ClientInfo
    }
    deriving (Int -> OAuthState -> ShowS
[OAuthState] -> ShowS
OAuthState -> String
(Int -> OAuthState -> ShowS)
-> (OAuthState -> String)
-> ([OAuthState] -> ShowS)
-> Show OAuthState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OAuthState -> ShowS
showsPrec :: Int -> OAuthState -> ShowS
$cshow :: OAuthState -> String
show :: OAuthState -> String
$cshowList :: [OAuthState] -> ShowS
showList :: [OAuthState] -> ShowS
Show, (forall x. OAuthState -> Rep OAuthState x)
-> (forall x. Rep OAuthState x -> OAuthState) -> Generic OAuthState
forall x. Rep OAuthState x -> OAuthState
forall x. OAuthState -> Rep OAuthState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OAuthState -> Rep OAuthState x
from :: forall x. OAuthState -> Rep OAuthState x
$cto :: forall x. Rep OAuthState x -> OAuthState
to :: forall x. Rep OAuthState x -> OAuthState
Generic)

-- | Client registration request
data ClientRegistrationRequest = ClientRegistrationRequest
    { ClientRegistrationRequest -> Text
client_name :: Text
    , ClientRegistrationRequest -> [Text]
redirect_uris :: [Text]
    , ClientRegistrationRequest -> [Text]
grant_types :: [Text]
    , ClientRegistrationRequest -> [Text]
response_types :: [Text]
    , ClientRegistrationRequest -> Text
token_endpoint_auth_method :: Text
    }
    deriving (Int -> ClientRegistrationRequest -> ShowS
[ClientRegistrationRequest] -> ShowS
ClientRegistrationRequest -> String
(Int -> ClientRegistrationRequest -> ShowS)
-> (ClientRegistrationRequest -> String)
-> ([ClientRegistrationRequest] -> ShowS)
-> Show ClientRegistrationRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientRegistrationRequest -> ShowS
showsPrec :: Int -> ClientRegistrationRequest -> ShowS
$cshow :: ClientRegistrationRequest -> String
show :: ClientRegistrationRequest -> String
$cshowList :: [ClientRegistrationRequest] -> ShowS
showList :: [ClientRegistrationRequest] -> ShowS
Show, (forall x.
 ClientRegistrationRequest -> Rep ClientRegistrationRequest x)
-> (forall x.
    Rep ClientRegistrationRequest x -> ClientRegistrationRequest)
-> Generic ClientRegistrationRequest
forall x.
Rep ClientRegistrationRequest x -> ClientRegistrationRequest
forall x.
ClientRegistrationRequest -> Rep ClientRegistrationRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
ClientRegistrationRequest -> Rep ClientRegistrationRequest x
from :: forall x.
ClientRegistrationRequest -> Rep ClientRegistrationRequest x
$cto :: forall x.
Rep ClientRegistrationRequest x -> ClientRegistrationRequest
to :: forall x.
Rep ClientRegistrationRequest x -> ClientRegistrationRequest
Generic)

instance Aeson.FromJSON ClientRegistrationRequest where
    parseJSON :: Value -> Parser ClientRegistrationRequest
parseJSON = Options -> Value -> Parser ClientRegistrationRequest
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON Options
Aeson.defaultOptions

-- | Client registration response
data ClientRegistrationResponse = ClientRegistrationResponse
    { ClientRegistrationResponse -> Text
client_id :: Text
    , ClientRegistrationResponse -> Text
client_secret :: Text -- Empty string for public clients
    , ClientRegistrationResponse -> Text
client_name :: Text
    , ClientRegistrationResponse -> [Text]
redirect_uris :: [Text]
    , ClientRegistrationResponse -> [Text]
grant_types :: [Text]
    , ClientRegistrationResponse -> [Text]
response_types :: [Text]
    , ClientRegistrationResponse -> Text
token_endpoint_auth_method :: Text
    }
    deriving (Int -> ClientRegistrationResponse -> ShowS
[ClientRegistrationResponse] -> ShowS
ClientRegistrationResponse -> String
(Int -> ClientRegistrationResponse -> ShowS)
-> (ClientRegistrationResponse -> String)
-> ([ClientRegistrationResponse] -> ShowS)
-> Show ClientRegistrationResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientRegistrationResponse -> ShowS
showsPrec :: Int -> ClientRegistrationResponse -> ShowS
$cshow :: ClientRegistrationResponse -> String
show :: ClientRegistrationResponse -> String
$cshowList :: [ClientRegistrationResponse] -> ShowS
showList :: [ClientRegistrationResponse] -> ShowS
Show, (forall x.
 ClientRegistrationResponse -> Rep ClientRegistrationResponse x)
-> (forall x.
    Rep ClientRegistrationResponse x -> ClientRegistrationResponse)
-> Generic ClientRegistrationResponse
forall x.
Rep ClientRegistrationResponse x -> ClientRegistrationResponse
forall x.
ClientRegistrationResponse -> Rep ClientRegistrationResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
ClientRegistrationResponse -> Rep ClientRegistrationResponse x
from :: forall x.
ClientRegistrationResponse -> Rep ClientRegistrationResponse x
$cto :: forall x.
Rep ClientRegistrationResponse x -> ClientRegistrationResponse
to :: forall x.
Rep ClientRegistrationResponse x -> ClientRegistrationResponse
Generic)

instance Aeson.ToJSON ClientRegistrationResponse where
    toJSON :: ClientRegistrationResponse -> Value
toJSON = Options -> ClientRegistrationResponse -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON Options
Aeson.defaultOptions

-- | Client info stored in server
data ClientInfo = ClientInfo
    { ClientInfo -> Text
clientName :: Text
    , ClientInfo -> [Text]
clientRedirectUris :: [Text]
    , ClientInfo -> [Text]
clientGrantTypes :: [Text]
    , ClientInfo -> [Text]
clientResponseTypes :: [Text]
    , ClientInfo -> Text
clientAuthMethod :: Text
    }
    deriving (Int -> ClientInfo -> ShowS
[ClientInfo] -> ShowS
ClientInfo -> String
(Int -> ClientInfo -> ShowS)
-> (ClientInfo -> String)
-> ([ClientInfo] -> ShowS)
-> Show ClientInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientInfo -> ShowS
showsPrec :: Int -> ClientInfo -> ShowS
$cshow :: ClientInfo -> String
show :: ClientInfo -> String
$cshowList :: [ClientInfo] -> ShowS
showList :: [ClientInfo] -> ShowS
Show, (forall x. ClientInfo -> Rep ClientInfo x)
-> (forall x. Rep ClientInfo x -> ClientInfo) -> Generic ClientInfo
forall x. Rep ClientInfo x -> ClientInfo
forall x. ClientInfo -> Rep ClientInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ClientInfo -> Rep ClientInfo x
from :: forall x. ClientInfo -> Rep ClientInfo x
$cto :: forall x. Rep ClientInfo x -> ClientInfo
to :: forall x. Rep ClientInfo x -> ClientInfo
Generic)

-- | Token response
data TokenResponse = TokenResponse
    { TokenResponse -> Text
access_token :: Text
    , TokenResponse -> Text
token_type :: Text
    , TokenResponse -> Maybe Int
expires_in :: Maybe Int
    , TokenResponse -> Maybe Text
refresh_token :: Maybe Text
    , TokenResponse -> Maybe Text
scope :: Maybe Text
    }
    deriving (Int -> TokenResponse -> ShowS
[TokenResponse] -> ShowS
TokenResponse -> String
(Int -> TokenResponse -> ShowS)
-> (TokenResponse -> String)
-> ([TokenResponse] -> ShowS)
-> Show TokenResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokenResponse -> ShowS
showsPrec :: Int -> TokenResponse -> ShowS
$cshow :: TokenResponse -> String
show :: TokenResponse -> String
$cshowList :: [TokenResponse] -> ShowS
showList :: [TokenResponse] -> ShowS
Show, (forall x. TokenResponse -> Rep TokenResponse x)
-> (forall x. Rep TokenResponse x -> TokenResponse)
-> Generic TokenResponse
forall x. Rep TokenResponse x -> TokenResponse
forall x. TokenResponse -> Rep TokenResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TokenResponse -> Rep TokenResponse x
from :: forall x. TokenResponse -> Rep TokenResponse x
$cto :: forall x. Rep TokenResponse x -> TokenResponse
to :: forall x. Rep TokenResponse x -> TokenResponse
Generic)

instance Aeson.ToJSON TokenResponse where
    toJSON :: TokenResponse -> Value
toJSON TokenResponse{Maybe Int
Maybe Text
Text
$sel:access_token:TokenResponse :: TokenResponse -> Text
$sel:token_type:TokenResponse :: TokenResponse -> Text
$sel:expires_in:TokenResponse :: TokenResponse -> Maybe Int
$sel:refresh_token:TokenResponse :: TokenResponse -> Maybe Text
$sel:scope:TokenResponse :: TokenResponse -> Maybe Text
access_token :: Text
token_type :: Text
expires_in :: Maybe Int
refresh_token :: Maybe Text
scope :: Maybe Text
..} =
        [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
            [ Key
"access_token" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
access_token
            , Key
"token_type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
token_type
            ]
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Int -> [Pair]) -> Maybe Int -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Int
e -> [Key
"expires_in" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
e]) Maybe Int
expires_in
                [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
r -> [Key
"refresh_token" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
r]) Maybe Text
refresh_token
                [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
s -> [Key
"scope" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
s]) Maybe Text
scope

instance Aeson.FromJSON AuthUser where
    parseJSON :: Value -> Parser AuthUser
parseJSON = String -> (Object -> Parser AuthUser) -> Value -> Parser AuthUser
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"AuthUser" ((Object -> Parser AuthUser) -> Value -> Parser AuthUser)
-> (Object -> Parser AuthUser) -> Value -> Parser AuthUser
forall a b. (a -> b) -> a -> b
$ \Object
v ->
        Text -> Maybe Text -> Maybe Text -> AuthUser
AuthUser
            (Text -> Maybe Text -> Maybe Text -> AuthUser)
-> Parser Text -> Parser (Maybe Text -> Maybe Text -> AuthUser)
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
"sub"
            Parser (Maybe Text -> Maybe Text -> AuthUser)
-> Parser (Maybe Text) -> Parser (Maybe Text -> AuthUser)
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
"email"
            Parser (Maybe Text -> AuthUser)
-> Parser (Maybe Text) -> Parser AuthUser
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
"name"

instance Aeson.ToJSON AuthUser where
    toJSON :: AuthUser -> Value
toJSON AuthUser{Maybe Text
Text
$sel:userId:AuthUser :: AuthUser -> Text
$sel:userEmail:AuthUser :: AuthUser -> Maybe Text
$sel:userName:AuthUser :: AuthUser -> Maybe Text
userId :: Text
userEmail :: Maybe Text
userName :: Maybe Text
..} =
        [Pair] -> Value
object
            [ Key
"sub" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
userId
            , Key
"email" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
userEmail
            , Key
"name" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
userName
            ]

-- Instances for JWT
instance ToJWT AuthUser
instance FromJWT AuthUser

-- | MCP API definition for HTTP server (following the MCP transport spec)
type MCPAPI auths = Auth auths AuthUser :> "mcp" :> ReqBody '[JSON] Aeson.Value :> Post '[JSON] Aeson.Value

-- | Unprotected MCP API (for backward compatibility)
type UnprotectedMCPAPI = "mcp" :> ReqBody '[JSON] Aeson.Value :> Post '[JSON] Aeson.Value

-- | OAuth endpoints
type OAuthAPI =
    ".well-known" :> "oauth-authorization-server" :> Get '[JSON] OAuthMetadata
        :<|> "register"
            :> ReqBody '[JSON] ClientRegistrationRequest
            :> Post '[JSON] ClientRegistrationResponse
        :<|> "authorize"
            :> QueryParam' '[Required] "response_type" Text
            :> QueryParam' '[Required] "client_id" Text
            :> QueryParam' '[Required] "redirect_uri" Text
            :> QueryParam' '[Required] "code_challenge" Text
            :> QueryParam' '[Required] "code_challenge_method" Text
            :> QueryParam "scope" Text
            :> QueryParam "state" Text
            :> Get '[PlainText] Text
        :<|> "token"
            :> ReqBody '[FormUrlEncoded] [(Text, Text)]
            :> Post '[JSON] TokenResponse

-- | Complete API with OAuth
type CompleteAPI auths = OAuthAPI :<|> MCPAPI auths

-- | Create a WAI Application for the MCP HTTP server
mcpApp :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> TVar OAuthState -> JWTSettings -> Application
mcpApp :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState
-> TVar OAuthState
-> JWTSettings
-> Application
mcpApp HTTPServerConfig
config TVar ServerState
stateVar TVar OAuthState
oauthStateVar JWTSettings
jwtSettings =
    let cookieSettings :: CookieSettings
cookieSettings = CookieSettings
defaultCookieSettings
        authContext :: Context '[CookieSettings, JWTSettings]
authContext = CookieSettings
cookieSettings CookieSettings
-> Context '[JWTSettings] -> Context '[CookieSettings, JWTSettings]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. JWTSettings
jwtSettings JWTSettings -> Context '[] -> Context '[JWTSettings]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext
        baseApp :: Application
baseApp = case HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config of
            Just OAuthConfig
oauthCfg
                | OAuthConfig -> Bool
oauthEnabled OAuthConfig
oauthCfg ->
                    Proxy (CompleteAPI '[JWT])
-> Context '[CookieSettings, JWTSettings]
-> Server (CompleteAPI '[JWT])
-> Application
forall {k} (api :: k) (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext
                        (Proxy (CompleteAPI '[JWT])
forall {k} (t :: k). Proxy t
Proxy :: Proxy (CompleteAPI '[JWT]))
                        Context '[CookieSettings, JWTSettings]
authContext
                        (HTTPServerConfig
-> TVar OAuthState
-> Server
     ((".well-known"
       :> ("oauth-authorization-server" :> Get '[JSON] OAuthMetadata))
      :<|> (("register"
             :> (ReqBody '[JSON] ClientRegistrationRequest
                 :> Post '[JSON] ClientRegistrationResponse))
            :<|> (("authorize"
                   :> (QueryParam' '[Required] "response_type" Text
                       :> (QueryParam' '[Required] "client_id" Text
                           :> (QueryParam' '[Required] "redirect_uri" Text
                               :> (QueryParam' '[Required] "code_challenge" Text
                                   :> (QueryParam' '[Required] "code_challenge_method" Text
                                       :> (QueryParam "scope" Text
                                           :> (QueryParam "state" Text
                                               :> Get '[PlainText] Text))))))))
                  :<|> ("token"
                        :> (ReqBody '[FormUrlEncoded] [(Text, Text)]
                            :> Post '[JSON] TokenResponse)))))
oauthServer HTTPServerConfig
config TVar OAuthState
oauthStateVar (Handler OAuthMetadata
 :<|> ((ClientRegistrationRequest
        -> Handler ClientRegistrationResponse)
       :<|> ((Text
              -> Text
              -> Text
              -> Text
              -> Text
              -> Maybe Text
              -> Maybe Text
              -> Handler Text)
             :<|> ([(Text, Text)] -> Handler TokenResponse))))
-> (AuthResult AuthUser -> Value -> Handler Value)
-> (Handler OAuthMetadata
    :<|> ((ClientRegistrationRequest
           -> Handler ClientRegistrationResponse)
          :<|> ((Text
                 -> Text
                 -> Text
                 -> Text
                 -> Text
                 -> Maybe Text
                 -> Maybe Text
                 -> Handler Text)
                :<|> ([(Text, Text)] -> Handler TokenResponse))))
   :<|> (AuthResult AuthUser -> Value -> Handler Value)
forall a b. a -> b -> a :<|> b
:<|> HTTPServerConfig
-> TVar ServerState
-> AuthResult AuthUser
-> Value
-> Handler Value
mcpServerAuth HTTPServerConfig
config TVar ServerState
stateVar)
            Maybe OAuthConfig
_ ->
                Proxy UnprotectedMCPAPI
-> ServerT UnprotectedMCPAPI Handler -> Application
forall {k} (api :: k).
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (Proxy UnprotectedMCPAPI
forall {k} (t :: k). Proxy t
Proxy :: Proxy UnprotectedMCPAPI) (HTTPServerConfig -> TVar ServerState -> Value -> Handler Value
mcpServerNoAuth HTTPServerConfig
config TVar ServerState
stateVar)
     in if HTTPServerConfig -> Bool
httpEnableLogging HTTPServerConfig
config
            then Middleware
logStdoutDev Application
baseApp
            else Application
baseApp
  where
    oauthServer :: HTTPServerConfig -> TVar OAuthState -> Server OAuthAPI
    oauthServer :: HTTPServerConfig
-> TVar OAuthState
-> Server
     ((".well-known"
       :> ("oauth-authorization-server" :> Get '[JSON] OAuthMetadata))
      :<|> (("register"
             :> (ReqBody '[JSON] ClientRegistrationRequest
                 :> Post '[JSON] ClientRegistrationResponse))
            :<|> (("authorize"
                   :> (QueryParam' '[Required] "response_type" Text
                       :> (QueryParam' '[Required] "client_id" Text
                           :> (QueryParam' '[Required] "redirect_uri" Text
                               :> (QueryParam' '[Required] "code_challenge" Text
                                   :> (QueryParam' '[Required] "code_challenge_method" Text
                                       :> (QueryParam "scope" Text
                                           :> (QueryParam "state" Text
                                               :> Get '[PlainText] Text))))))))
                  :<|> ("token"
                        :> (ReqBody '[FormUrlEncoded] [(Text, Text)]
                            :> Post '[JSON] TokenResponse)))))
oauthServer HTTPServerConfig
cfg TVar OAuthState
oauthState =
        HTTPServerConfig -> Handler OAuthMetadata
handleMetadata HTTPServerConfig
cfg
            Handler OAuthMetadata
-> ((ClientRegistrationRequest
     -> Handler ClientRegistrationResponse)
    :<|> ((Text
           -> Text
           -> Text
           -> Text
           -> Text
           -> Maybe Text
           -> Maybe Text
           -> Handler Text)
          :<|> ([(Text, Text)] -> Handler TokenResponse)))
-> Handler OAuthMetadata
   :<|> ((ClientRegistrationRequest
          -> Handler ClientRegistrationResponse)
         :<|> ((Text
                -> Text
                -> Text
                -> Text
                -> Text
                -> Maybe Text
                -> Maybe Text
                -> Handler Text)
               :<|> ([(Text, Text)] -> Handler TokenResponse)))
forall a b. a -> b -> a :<|> b
:<|> HTTPServerConfig
-> TVar OAuthState
-> ClientRegistrationRequest
-> Handler ClientRegistrationResponse
handleRegister HTTPServerConfig
cfg TVar OAuthState
oauthState
            (ClientRegistrationRequest -> Handler ClientRegistrationResponse)
-> ((Text
     -> Text
     -> Text
     -> Text
     -> Text
     -> Maybe Text
     -> Maybe Text
     -> Handler Text)
    :<|> ([(Text, Text)] -> Handler TokenResponse))
-> (ClientRegistrationRequest
    -> Handler ClientRegistrationResponse)
   :<|> ((Text
          -> Text
          -> Text
          -> Text
          -> Text
          -> Maybe Text
          -> Maybe Text
          -> Handler Text)
         :<|> ([(Text, Text)] -> Handler TokenResponse))
forall a b. a -> b -> a :<|> b
:<|> HTTPServerConfig
-> TVar OAuthState
-> Text
-> Text
-> Text
-> Text
-> Text
-> Maybe Text
-> Maybe Text
-> Handler Text
handleAuthorize HTTPServerConfig
cfg TVar OAuthState
oauthState
            (Text
 -> Text
 -> Text
 -> Text
 -> Text
 -> Maybe Text
 -> Maybe Text
 -> Handler Text)
-> ([(Text, Text)] -> Handler TokenResponse)
-> (Text
    -> Text
    -> Text
    -> Text
    -> Text
    -> Maybe Text
    -> Maybe Text
    -> Handler Text)
   :<|> ([(Text, Text)] -> Handler TokenResponse)
forall a b. a -> b -> a :<|> b
:<|> JWTSettings
-> HTTPServerConfig
-> TVar OAuthState
-> [(Text, Text)]
-> Handler TokenResponse
handleToken JWTSettings
jwtSettings HTTPServerConfig
cfg TVar OAuthState
oauthState

    mcpServerAuth :: HTTPServerConfig -> TVar ServerState -> AuthResult AuthUser -> Aeson.Value -> Handler Aeson.Value
    mcpServerAuth :: HTTPServerConfig
-> TVar ServerState
-> AuthResult AuthUser
-> Value
-> Handler Value
mcpServerAuth HTTPServerConfig
httpConfig TVar ServerState
stateTVar AuthResult AuthUser
authResult Value
requestValue =
        case AuthResult AuthUser
authResult of
            Authenticated AuthUser
user -> MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState -> Maybe AuthUser -> Value -> Handler Value
HTTPServerConfig
-> TVar ServerState -> Maybe AuthUser -> Value -> Handler Value
handleHTTPRequest HTTPServerConfig
httpConfig TVar ServerState
stateTVar (AuthUser -> Maybe AuthUser
forall a. a -> Maybe a
Just AuthUser
user) Value
requestValue
            AuthResult AuthUser
NoSuchUser -> ServerError -> Handler Value
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401{errBody = encode $ object ["error" .= ("Invalid token" :: Text)]}
            AuthResult AuthUser
BadPassword -> ServerError -> Handler Value
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401{errBody = encode $ object ["error" .= ("Invalid token" :: Text)]}
            AuthResult AuthUser
Indefinite -> ServerError -> Handler Value
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401{errBody = encode $ object ["error" .= ("Authentication required" :: Text)]}

    mcpServerNoAuth :: HTTPServerConfig -> TVar ServerState -> Aeson.Value -> Handler Aeson.Value
    mcpServerNoAuth :: HTTPServerConfig -> TVar ServerState -> Value -> Handler Value
mcpServerNoAuth HTTPServerConfig
httpConfig TVar ServerState
stateTVar = MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState -> Maybe AuthUser -> Value -> Handler Value
HTTPServerConfig
-> TVar ServerState -> Maybe AuthUser -> Value -> Handler Value
handleHTTPRequest HTTPServerConfig
httpConfig TVar ServerState
stateTVar Maybe AuthUser
forall a. Maybe a
Nothing

-- | Handle HTTP MCP requests following the MCP transport protocol
handleHTTPRequest :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> Maybe AuthUser -> Aeson.Value -> Handler Aeson.Value
handleHTTPRequest :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState -> Maybe AuthUser -> Value -> Handler Value
handleHTTPRequest HTTPServerConfig
httpConfig TVar ServerState
stateVar Maybe AuthUser
_mAuthUser Value
requestValue = do
    -- Parse the incoming JSON-RPC message
    case Value -> Result JSONRPCMessage
forall a. FromJSON a => Value -> Result a
fromJSON Value
requestValue of
        Aeson.Success (JSONRPCMessage
msg :: JSONRPCMessage) -> do
            case JSONRPCMessage
msg of
                RequestMessage JSONRPCRequest
req -> do
                    -- Process the JSON-RPC request
                    Either Text Value
result <- IO (Either Text Value) -> Handler (Either Text Value)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Value) -> Handler (Either Text Value))
-> IO (Either Text Value) -> Handler (Either Text Value)
forall a b. (a -> b) -> a -> b
$ MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState -> JSONRPCRequest -> IO (Either Text Value)
HTTPServerConfig
-> TVar ServerState -> JSONRPCRequest -> IO (Either Text Value)
processHTTPRequest HTTPServerConfig
httpConfig TVar ServerState
stateVar JSONRPCRequest
req
                    case Either Text Value
result of
                        Left Text
err -> ServerError -> Handler Value
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err500{errBody = encode $ object ["error" .= err]}
                        Right Value
response -> Value -> Handler Value
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
response
                NotificationMessage JSONRPCNotification
notif -> do
                    -- Process notifications (no response expected)
                    ()
_ <- IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState -> JSONRPCNotification -> IO ()
HTTPServerConfig
-> TVar ServerState -> JSONRPCNotification -> IO ()
processHTTPNotification HTTPServerConfig
httpConfig TVar ServerState
stateVar JSONRPCNotification
notif
                    Value -> Handler Value
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Handler Value) -> Value -> Handler Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [] -- Empty response for notifications
                JSONRPCMessage
_ -> ServerError -> Handler Value
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("Invalid JSON-RPC message type" :: Text)]}
        Aeson.Error String
e -> ServerError -> Handler Value
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("Invalid JSON-RPC message" :: Text), "error_description" .= T.pack e]}

-- | Process an HTTP MCP notification
processHTTPNotification :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> JSONRPCNotification -> IO ()
processHTTPNotification :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState -> JSONRPCNotification -> IO ()
processHTTPNotification HTTPServerConfig
_ TVar ServerState
_ JSONRPCNotification
_ = do
    -- For now, just ignore notifications since they don't need responses
    -- In a more complete implementation, this would handle logging/setLevel notifications
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Process an HTTP MCP request
processHTTPRequest :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> JSONRPCRequest -> IO (Either Text Aeson.Value)
processHTTPRequest :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState -> JSONRPCRequest -> IO (Either Text Value)
processHTTPRequest HTTPServerConfig
httpConfig TVar ServerState
stateVar JSONRPCRequest
req = do
    -- Read the current state
    ServerState
currentState <- TVar ServerState -> IO ServerState
forall a. TVar a -> IO a
readTVarIO TVar ServerState
stateVar
    let dummyConfig :: ServerConfig
dummyConfig =
            ServerConfig
                { $sel:configInput:ServerConfig :: Handle
configInput = Handle
forall a. HasCallStack => a
undefined -- Not used in HTTP mode
                , $sel:configOutput:ServerConfig :: Handle
configOutput = Handle
forall a. HasCallStack => a
undefined -- Not used in HTTP mode
                , $sel:configServerInfo:ServerConfig :: Implementation
configServerInfo = HTTPServerConfig -> Implementation
httpServerInfo HTTPServerConfig
httpConfig
                , $sel:configCapabilities:ServerConfig :: ServerCapabilities
configCapabilities = HTTPServerConfig -> ServerCapabilities
httpCapabilities HTTPServerConfig
httpConfig
                }

    Either Text (Value, ServerState)
result <- ServerConfig
-> ServerState
-> MCPServerM Value
-> IO (Either Text (Value, ServerState))
forall a.
ServerConfig
-> ServerState -> MCPServerM a -> IO (Either Text (a, ServerState))
runMCPServer ServerConfig
dummyConfig ServerState
currentState (Text -> JSONRPCRequest -> MCPServerM Value
MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
Text -> JSONRPCRequest -> MCPServerM Value
handleHTTPRequestInner (HTTPServerConfig -> Text
httpProtocolVersion HTTPServerConfig
httpConfig) JSONRPCRequest
req)
    case Either Text (Value, ServerState)
result of
        Left Text
err -> Either Text Value -> IO (Either Text Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Value -> IO (Either Text Value))
-> Either Text Value -> IO (Either Text Value)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Value
forall a b. a -> Either a b
Left Text
err
        Right (Value
response, ServerState
newState) -> do
            -- Update the state atomically
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ServerState -> ServerState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ServerState
stateVar ServerState
newState
            Either Text Value -> IO (Either Text Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Value -> IO (Either Text Value))
-> Either Text Value -> IO (Either Text Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either Text Value
forall a b. b -> Either a b
Right Value
response

-- | Handle HTTP request within the MCP monad, returning proper JSON-RPC responses
handleHTTPRequestInner :: (MCPServer MCPServerM) => Text -> JSONRPCRequest -> MCPServerM Aeson.Value
handleHTTPRequestInner :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
Text -> JSONRPCRequest -> MCPServerM Value
handleHTTPRequestInner Text
protocolVersion (JSONRPCRequest Text
_ RequestId
reqId Text
method Maybe Value
params) = do
    ServerConfig
config <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ServerState
state <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerState
forall s (m :: * -> *). MonadState s m => m s
get

    case Text
method of
        Text
"initialize" -> case Maybe Value
params of
            Just Value
p -> case Value -> Result InitializeParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                Aeson.Success InitializeParams
initParams -> do
                    RequestId -> InitializeParams -> MCPServerM ()
handleInitializeHTTP RequestId
reqId InitializeParams
initParams
                    let result :: InitializeResult
result =
                            InitializeResult
                                { $sel:protocolVersion:InitializeResult :: Text
protocolVersion = Text
protocolVersion
                                , $sel:capabilities:InitializeResult :: ServerCapabilities
capabilities = ServerConfig -> ServerCapabilities
configCapabilities ServerConfig
config
                                , $sel:serverInfo:InitializeResult :: Implementation
serverInfo = ServerConfig -> Implementation
configServerInfo ServerConfig
config
                                , $sel:instructions:InitializeResult :: Maybe Text
instructions = Maybe Text
forall a. Maybe a
Nothing
                                , $sel:_meta:InitializeResult :: Maybe Metadata
_meta = Maybe Metadata
forall a. Maybe a
Nothing
                                }
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (InitializeResult -> Value
forall a. ToJSON a => a -> Value
toJSON InitializeResult
result)
                Aeson.Error String
e ->
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
            Maybe Value
Nothing ->
                Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                    JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                        Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                            Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"ping" -> Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId ([Pair] -> Value
object [])
        Text
"resources/list" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ListResourcesParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ListResourcesParams
listParams -> do
                            ListResourcesResult
result <- ListResourcesParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListResourcesResult
forall (m :: * -> *).
MCPServer m =>
ListResourcesParams -> m ListResourcesResult
handleListResources ListResourcesParams
listParams
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (ListResourcesResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListResourcesResult
result)
                        Aeson.Error String
e ->
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                                JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                    Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing -> do
                        ListResourcesResult
result <- ListResourcesParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListResourcesResult
forall (m :: * -> *).
MCPServer m =>
ListResourcesParams -> m ListResourcesResult
handleListResources (Maybe Cursor -> ListResourcesParams
ListResourcesParams Maybe Cursor
forall a. Maybe a
Nothing)
                        Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (ListResourcesResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListResourcesResult
result)
        Text
"resources/read" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ReadResourceParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ReadResourceParams
readParams -> do
                            ReadResourceResult
result <- ReadResourceParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ReadResourceResult
forall (m :: * -> *).
MCPServer m =>
ReadResourceParams -> m ReadResourceResult
handleReadResource ReadResourceParams
readParams
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (ReadResourceResult -> Value
forall a. ToJSON a => a -> Value
toJSON ReadResourceResult
result)
                        Aeson.Error String
e ->
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                                JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                    Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing ->
                        Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                            JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                    Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"tools/list" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ListToolsParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ListToolsParams
listParams -> do
                            ListToolsResult
result <- ListToolsParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) ListToolsResult
forall (m :: * -> *).
MCPServer m =>
ListToolsParams -> m ListToolsResult
handleListTools ListToolsParams
listParams
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (ListToolsResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListToolsResult
result)
                        Aeson.Error String
e ->
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                                JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                    Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing -> do
                        ListToolsResult
result <- ListToolsParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) ListToolsResult
forall (m :: * -> *).
MCPServer m =>
ListToolsParams -> m ListToolsResult
handleListTools (Maybe Cursor -> ListToolsParams
ListToolsParams Maybe Cursor
forall a. Maybe a
Nothing)
                        Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (ListToolsResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListToolsResult
result)
        Text
"tools/call" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result CallToolParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success CallToolParams
callParams -> do
                            CallToolResult
result <- CallToolParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) CallToolResult
forall (m :: * -> *).
MCPServer m =>
CallToolParams -> m CallToolResult
handleCallTool CallToolParams
callParams
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (CallToolResult -> Value
forall a. ToJSON a => a -> Value
toJSON CallToolResult
result)
                        Aeson.Error String
e ->
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                                JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                    Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing ->
                        Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                            JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                    Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"prompts/list" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ListPromptsParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ListPromptsParams
listParams -> do
                            ListPromptsResult
result <- ListPromptsParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListPromptsResult
forall (m :: * -> *).
MCPServer m =>
ListPromptsParams -> m ListPromptsResult
handleListPrompts ListPromptsParams
listParams
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (ListPromptsResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListPromptsResult
result)
                        Aeson.Error String
e ->
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                                JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                    Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing -> do
                        ListPromptsResult
result <- ListPromptsParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListPromptsResult
forall (m :: * -> *).
MCPServer m =>
ListPromptsParams -> m ListPromptsResult
handleListPrompts (Maybe Cursor -> ListPromptsParams
ListPromptsParams Maybe Cursor
forall a. Maybe a
Nothing)
                        Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (ListPromptsResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListPromptsResult
result)
        Text
"prompts/get" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result GetPromptParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success GetPromptParams
getParams -> do
                            GetPromptResult
result <- GetPromptParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) GetPromptResult
forall (m :: * -> *).
MCPServer m =>
GetPromptParams -> m GetPromptResult
handleGetPrompt GetPromptParams
getParams
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (GetPromptResult -> Value
forall a. ToJSON a => a -> Value
toJSON GetPromptResult
result)
                        Aeson.Error String
e ->
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                                JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                    Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing ->
                        Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                            JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                    Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"completion/complete" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result CompleteParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success CompleteParams
completeParams -> do
                            CompleteResult
result <- CompleteParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) CompleteResult
forall (m :: * -> *).
MCPServer m =>
CompleteParams -> m CompleteResult
handleComplete CompleteParams
completeParams
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (CompleteResult -> Value
forall a. ToJSON a => a -> Value
toJSON CompleteResult
result)
                        Aeson.Error String
e ->
                            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                                JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                    Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing ->
                        Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                            JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                                Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                    Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"logging/setLevel" -> case Maybe Value
params of
            Just Value
p -> case Value -> Result SetLevelParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                Aeson.Success SetLevelParams
setLevelParams -> do
                    ()
_ <- SetLevelParams -> MCPServerM ()
forall (m :: * -> *). MCPServer m => SetLevelParams -> m ()
handleSetLevel SetLevelParams
setLevelParams
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$ JSONRPCResponse -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCResponse -> Value) -> JSONRPCResponse -> Value
forall a b. (a -> b) -> a -> b
$ Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId ([Pair] -> Value
object [])
                Aeson.Error String
e ->
                    Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                        JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                            Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
            Maybe Value
Nothing ->
                Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                    JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                        Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                            Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
_ ->
            Value -> MCPServerM Value
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MCPServerM Value) -> Value -> MCPServerM Value
forall a b. (a -> b) -> a -> b
$
                JSONRPCError -> Value
forall a. ToJSON a => a -> Value
toJSON (JSONRPCError -> Value) -> JSONRPCError -> Value
forall a b. (a -> b) -> a -> b
$
                    Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId (JSONRPCErrorInfo -> JSONRPCError)
-> JSONRPCErrorInfo -> JSONRPCError
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32601) Text
"Method not found" Maybe Value
forall a. Maybe a
Nothing

-- | Handle HTTP initialize request
handleInitializeHTTP :: RequestId -> InitializeParams -> MCPServerM ()
handleInitializeHTTP :: RequestId -> InitializeParams -> MCPServerM ()
handleInitializeHTTP RequestId
_ InitializeParams
params = do
    ServerConfig
config <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ServerState
state <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerState
forall s (m :: * -> *). MonadState s m => m s
get

    let InitializeParams{$sel:capabilities:InitializeParams :: InitializeParams -> ClientCapabilities
capabilities = ClientCapabilities
clientCaps} = InitializeParams
params

    ServerState -> MCPServerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
        ServerState
state
            { serverInitialized = True
            , clientCapabilities = Just clientCaps
            , serverInfo = Just (configServerInfo config)
            }

-- | Handle OAuth metadata discovery endpoint
handleMetadata :: HTTPServerConfig -> Handler OAuthMetadata
handleMetadata :: HTTPServerConfig -> Handler OAuthMetadata
handleMetadata HTTPServerConfig
config = do
    let baseUrl :: Text
baseUrl = HTTPServerConfig -> Text
httpBaseUrl HTTPServerConfig
config
        oauthCfg :: Maybe OAuthConfig
oauthCfg = HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config
    OAuthMetadata -> Handler OAuthMetadata
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return
        OAuthMetadata
            { $sel:issuer:OAuthMetadata :: Text
issuer = Text
baseUrl
            , $sel:authorizationEndpoint:OAuthMetadata :: Text
authorizationEndpoint = Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/authorize"
            , $sel:tokenEndpoint:OAuthMetadata :: Text
tokenEndpoint = Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/token"
            , $sel:registrationEndpoint:OAuthMetadata :: Maybe Text
registrationEndpoint = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/register")
            , $sel:userInfoEndpoint:OAuthMetadata :: Maybe Text
userInfoEndpoint = Maybe Text
forall a. Maybe a
Nothing
            , $sel:jwksUri:OAuthMetadata :: Maybe Text
jwksUri = Maybe Text
forall a. Maybe a
Nothing
            , $sel:scopesSupported:OAuthMetadata :: Maybe [Text]
scopesSupported = (OAuthConfig -> [Text]) -> Maybe OAuthConfig -> Maybe [Text]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OAuthConfig -> [Text]
supportedScopes Maybe OAuthConfig
oauthCfg
            , $sel:responseTypesSupported:OAuthMetadata :: [Text]
responseTypesSupported = [Text] -> (OAuthConfig -> [Text]) -> Maybe OAuthConfig -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Text
"code"] OAuthConfig -> [Text]
supportedResponseTypes Maybe OAuthConfig
oauthCfg
            , $sel:grantTypesSupported:OAuthMetadata :: Maybe [Text]
grantTypesSupported = (OAuthConfig -> [Text]) -> Maybe OAuthConfig -> Maybe [Text]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OAuthConfig -> [Text]
supportedGrantTypes Maybe OAuthConfig
oauthCfg
            , $sel:tokenEndpointAuthMethodsSupported:OAuthMetadata :: Maybe [Text]
tokenEndpointAuthMethodsSupported = (OAuthConfig -> [Text]) -> Maybe OAuthConfig -> Maybe [Text]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OAuthConfig -> [Text]
supportedAuthMethods Maybe OAuthConfig
oauthCfg
            , $sel:codeChallengeMethodsSupported:OAuthMetadata :: Maybe [Text]
codeChallengeMethodsSupported = (OAuthConfig -> [Text]) -> Maybe OAuthConfig -> Maybe [Text]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OAuthConfig -> [Text]
supportedCodeChallengeMethods Maybe OAuthConfig
oauthCfg
            }

-- | Handle dynamic client registration
handleRegister :: HTTPServerConfig -> TVar OAuthState -> ClientRegistrationRequest -> Handler ClientRegistrationResponse
handleRegister :: HTTPServerConfig
-> TVar OAuthState
-> ClientRegistrationRequest
-> Handler ClientRegistrationResponse
handleRegister HTTPServerConfig
config TVar OAuthState
oauthStateVar (ClientRegistrationRequest Text
reqName [Text]
reqRedirects [Text]
reqGrants [Text]
reqResponses Text
reqAuth) = do
    -- Generate client ID
    let prefix :: Text
prefix = Text -> (OAuthConfig -> Text) -> Maybe OAuthConfig -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"client_" OAuthConfig -> Text
clientIdPrefix (HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config)
    Text
clientId <- IO Text -> Handler Text
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Handler Text) -> IO Text -> Handler Text
forall a b. (a -> b) -> a -> b
$ (Text
prefix <>) (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
generateAuthCode

    -- Store client info
    let clientInfo :: ClientInfo
clientInfo =
            ClientInfo
                { $sel:clientName:ClientInfo :: Text
clientName = Text
reqName
                , $sel:clientRedirectUris:ClientInfo :: [Text]
clientRedirectUris = [Text]
reqRedirects
                , $sel:clientGrantTypes:ClientInfo :: [Text]
clientGrantTypes = [Text]
reqGrants
                , $sel:clientResponseTypes:ClientInfo :: [Text]
clientResponseTypes = [Text]
reqResponses
                , $sel:clientAuthMethod:ClientInfo :: Text
clientAuthMethod = Text
reqAuth
                }

    IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar OAuthState -> (OAuthState -> OAuthState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar OAuthState
oauthStateVar ((OAuthState -> OAuthState) -> STM ())
-> (OAuthState -> OAuthState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \OAuthState
s ->
        OAuthState
s{registeredClients = Map.insert clientId clientInfo (registeredClients s)}

    ClientRegistrationResponse -> Handler ClientRegistrationResponse
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ClientRegistrationResponse
            { $sel:client_id:ClientRegistrationResponse :: Text
client_id = Text
clientId
            , $sel:client_secret:ClientRegistrationResponse :: Text
client_secret = Text
"" -- Empty string for public clients
            , $sel:client_name:ClientRegistrationResponse :: Text
client_name = Text
reqName
            , $sel:redirect_uris:ClientRegistrationResponse :: [Text]
redirect_uris = [Text]
reqRedirects
            , $sel:grant_types:ClientRegistrationResponse :: [Text]
grant_types = [Text]
reqGrants
            , $sel:response_types:ClientRegistrationResponse :: [Text]
response_types = [Text]
reqResponses
            , $sel:token_endpoint_auth_method:ClientRegistrationResponse :: Text
token_endpoint_auth_method = Text
reqAuth
            }

-- | Handle OAuth authorize endpoint
handleAuthorize :: HTTPServerConfig -> TVar OAuthState -> Text -> Text -> Text -> Text -> Text -> Maybe Text -> Maybe Text -> Handler Text
handleAuthorize :: HTTPServerConfig
-> TVar OAuthState
-> Text
-> Text
-> Text
-> Text
-> Text
-> Maybe Text
-> Maybe Text
-> Handler Text
handleAuthorize HTTPServerConfig
config TVar OAuthState
oauthStateVar Text
responseType Text
clientId Text
redirectUri Text
codeChallenge Text
codeChallengeMethod Maybe Text
mScope Maybe Text
mState = do
    -- Validate parameters according to MCP spec
    Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
responseType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"code") (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
        ServerError -> Handler ()
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("unsupported_response_type" :: Text), "error_description" .= ("Only 'code' response type is supported" :: Text)]}

    Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
codeChallengeMethod Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"S256") (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
        ServerError -> Handler ()
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text), "error_description" .= ("Only 'S256' code challenge method is supported" :: Text)]}

    -- Generate authorization code
    Text
code <- IO Text -> Handler Text
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Handler Text) -> IO Text -> Handler Text
forall a b. (a -> b) -> a -> b
$ HTTPServerConfig -> IO Text
generateAuthCodeWithConfig HTTPServerConfig
config
    UTCTime
currentTime <- IO UTCTime -> Handler UTCTime
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    let expirySeconds :: NominalDiffTime
expirySeconds = NominalDiffTime
-> (OAuthConfig -> NominalDiffTime)
-> Maybe OAuthConfig
-> NominalDiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NominalDiffTime
600 (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> NominalDiffTime)
-> (OAuthConfig -> Int) -> OAuthConfig -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OAuthConfig -> Int
authCodeExpirySeconds) (HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config)
        expiry :: UTCTime
expiry = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
expirySeconds UTCTime
currentTime

    -- Generate user ID based on configuration
    let oauthCfg :: Maybe OAuthConfig
oauthCfg = HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config
        userId :: Text
userId = case OAuthConfig -> Maybe Text
demoUserIdTemplate (OAuthConfig -> Maybe Text) -> Maybe OAuthConfig -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe OAuthConfig
oauthCfg of
            Just Text
template -> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"{clientId}" Text
clientId Text
template
            Maybe Text
Nothing -> Text
"user-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
clientId -- Fallback if no demo mode
        authCode :: AuthorizationCode
authCode =
            AuthorizationCode
                { $sel:authCode:AuthorizationCode :: Text
authCode = Text
code
                , $sel:authClientId:AuthorizationCode :: Text
authClientId = Text
clientId
                , $sel:authRedirectUri:AuthorizationCode :: Text
authRedirectUri = Text
redirectUri
                , $sel:authCodeChallenge:AuthorizationCode :: Text
authCodeChallenge = Text
codeChallenge
                , $sel:authCodeChallengeMethod:AuthorizationCode :: Text
authCodeChallengeMethod = Text
codeChallengeMethod
                , $sel:authScopes:AuthorizationCode :: [Text]
authScopes = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
" ") Maybe Text
mScope
                , $sel:authUserId:AuthorizationCode :: Text
authUserId = Text
userId
                , $sel:authExpiry:AuthorizationCode :: UTCTime
authExpiry = UTCTime
expiry
                }

    -- Store authorization code
    IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar OAuthState -> (OAuthState -> OAuthState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar OAuthState
oauthStateVar ((OAuthState -> OAuthState) -> STM ())
-> (OAuthState -> OAuthState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \OAuthState
s ->
        OAuthState
s{authCodes = Map.insert code authCode (authCodes s)}

    -- Return the callback URL with auth code
    let stateParam :: Text
stateParam = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text
"&state=" <>) Maybe Text
mState
        defaultTemplate :: Text
defaultTemplate =
            Text
"Authorization successful!\n\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Redirect to: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
redirectUri
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"?code="
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
code
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stateParam
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Use this authorization code to exchange for an access token."
        template :: Text
template =
            Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                Text
defaultTemplate
                ( HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"{redirectUri}" Text
redirectUri (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"{code}" Text
code (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"{state}" Text
stateParam
                )
                (OAuthConfig -> Maybe Text
authorizationSuccessTemplate (OAuthConfig -> Maybe Text) -> Maybe OAuthConfig -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config)
    Text -> Handler Text
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
template

-- | Handle OAuth token endpoint
handleToken :: JWTSettings -> HTTPServerConfig -> TVar OAuthState -> [(Text, Text)] -> Handler TokenResponse
handleToken :: JWTSettings
-> HTTPServerConfig
-> TVar OAuthState
-> [(Text, Text)]
-> Handler TokenResponse
handleToken JWTSettings
jwtSettings HTTPServerConfig
config TVar OAuthState
oauthStateVar [(Text, Text)]
params = do
    let paramMap :: Map Text Text
paramMap = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
params
    case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"grant_type" Map Text Text
paramMap of
        Just Text
"authorization_code" -> JWTSettings
-> HTTPServerConfig
-> TVar OAuthState
-> Map Text Text
-> Handler TokenResponse
handleAuthCodeGrant JWTSettings
jwtSettings HTTPServerConfig
config TVar OAuthState
oauthStateVar Map Text Text
paramMap
        Just Text
"refresh_token" -> JWTSettings
-> HTTPServerConfig
-> TVar OAuthState
-> Map Text Text
-> Handler TokenResponse
handleRefreshTokenGrant JWTSettings
jwtSettings HTTPServerConfig
config TVar OAuthState
oauthStateVar Map Text Text
paramMap
        Just Text
_other -> ServerError -> Handler TokenResponse
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("unsupported_grant_type" :: Text)]}
        Maybe Text
Nothing -> ServerError -> Handler TokenResponse
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text), "error_description" .= ("Missing grant_type" :: Text)]}

-- | Handle authorization code grant
handleAuthCodeGrant :: JWTSettings -> HTTPServerConfig -> TVar OAuthState -> Map Text Text -> Handler TokenResponse
handleAuthCodeGrant :: JWTSettings
-> HTTPServerConfig
-> TVar OAuthState
-> Map Text Text
-> Handler TokenResponse
handleAuthCodeGrant JWTSettings
jwtSettings HTTPServerConfig
config TVar OAuthState
oauthStateVar Map Text Text
params = do
    Text
code <- case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"code" Map Text Text
params of
        Just Text
c -> Text -> Handler Text
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
c
        Maybe Text
Nothing -> ServerError -> Handler Text
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]}

    Text
codeVerifier <- case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"code_verifier" Map Text Text
params of
        Just Text
v -> Text -> Handler Text
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
v
        Maybe Text
Nothing -> ServerError -> Handler Text
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]}

    -- Look up authorization code
    OAuthState
oauthState <- IO OAuthState -> Handler OAuthState
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OAuthState -> Handler OAuthState)
-> IO OAuthState -> Handler OAuthState
forall a b. (a -> b) -> a -> b
$ TVar OAuthState -> IO OAuthState
forall a. TVar a -> IO a
readTVarIO TVar OAuthState
oauthStateVar
    AuthorizationCode
authCode <- case Text -> Map Text AuthorizationCode -> Maybe AuthorizationCode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
code (OAuthState -> Map Text AuthorizationCode
authCodes OAuthState
oauthState) of
        Just AuthorizationCode
ac -> AuthorizationCode -> Handler AuthorizationCode
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthorizationCode
ac
        Maybe AuthorizationCode
Nothing -> ServerError -> Handler AuthorizationCode
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text)]}

    -- Verify code hasn't expired
    UTCTime
currentTime <- IO UTCTime -> Handler UTCTime
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
currentTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> AuthorizationCode -> UTCTime
authExpiry AuthorizationCode
authCode) (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
        ServerError -> Handler ()
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text), "error_description" .= ("Authorization code expired" :: Text)]}

    -- Verify PKCE
    Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Text -> Bool
validateCodeVerifier Text
codeVerifier (AuthorizationCode -> Text
authCodeChallenge AuthorizationCode
authCode)) (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
        ServerError -> Handler ()
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text), "error_description" .= ("Invalid code verifier" :: Text)]}

    -- Create user for JWT
    let oauthCfg :: Maybe OAuthConfig
oauthCfg = HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config
        emailDomain :: Text
emailDomain = Text -> (OAuthConfig -> Text) -> Maybe OAuthConfig -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"example.com" OAuthConfig -> Text
demoEmailDomain Maybe OAuthConfig
oauthCfg
        userName :: Text
userName = Text -> (OAuthConfig -> Text) -> Maybe OAuthConfig -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"User" OAuthConfig -> Text
demoUserName Maybe OAuthConfig
oauthCfg
        user :: AuthUser
user =
            AuthUser
                { $sel:userId:AuthUser :: Text
userId = AuthorizationCode -> Text
authUserId AuthorizationCode
authCode
                , $sel:userEmail:AuthUser :: Maybe Text
userEmail = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ AuthorizationCode -> Text
authUserId AuthorizationCode
authCode Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
emailDomain
                , $sel:userName:AuthUser :: Maybe Text
userName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
userName
                }

    -- Generate tokens
    Text
accessTokenText <- AuthUser -> JWTSettings -> Handler Text
generateJWTAccessToken AuthUser
user JWTSettings
jwtSettings
    Text
refreshToken <- IO Text -> Handler Text
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Handler Text) -> IO Text -> Handler Text
forall a b. (a -> b) -> a -> b
$ HTTPServerConfig -> IO Text
generateRefreshTokenWithConfig HTTPServerConfig
config

    -- Store tokens
    IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar OAuthState -> (OAuthState -> OAuthState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar OAuthState
oauthStateVar ((OAuthState -> OAuthState) -> STM ())
-> (OAuthState -> OAuthState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \OAuthState
s ->
        OAuthState
s
            { authCodes = Map.delete code (authCodes s)
            , accessTokens = Map.insert accessTokenText user (accessTokens s)
            , refreshTokens = Map.insert refreshToken (accessTokenText, user) (refreshTokens s)
            }

    TokenResponse -> Handler TokenResponse
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return
        TokenResponse
            { $sel:access_token:TokenResponse :: Text
access_token = Text
accessTokenText
            , $sel:token_type:TokenResponse :: Text
token_type = Text
"Bearer"
            , $sel:expires_in:TokenResponse :: Maybe Int
expires_in = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> (OAuthConfig -> Int) -> Maybe OAuthConfig -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
3600 OAuthConfig -> Int
accessTokenExpirySeconds (HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config)
            , $sel:refresh_token:TokenResponse :: Maybe Text
refresh_token = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
refreshToken
            , $sel:scope:TokenResponse :: Maybe Text
scope = if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AuthorizationCode -> [Text]
authScopes AuthorizationCode
authCode) then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> [Text] -> Text
T.intercalate Text
" " (AuthorizationCode -> [Text]
authScopes AuthorizationCode
authCode))
            }

-- | Handle refresh token grant
handleRefreshTokenGrant :: JWTSettings -> HTTPServerConfig -> TVar OAuthState -> Map Text Text -> Handler TokenResponse
handleRefreshTokenGrant :: JWTSettings
-> HTTPServerConfig
-> TVar OAuthState
-> Map Text Text
-> Handler TokenResponse
handleRefreshTokenGrant JWTSettings
jwtSettings HTTPServerConfig
config TVar OAuthState
oauthStateVar Map Text Text
params = do
    Text
refreshToken <- case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"refresh_token" Map Text Text
params of
        Just Text
t -> Text -> Handler Text
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
        Maybe Text
Nothing -> ServerError -> Handler Text
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]}

    -- Look up refresh token
    OAuthState
oauthState <- IO OAuthState -> Handler OAuthState
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OAuthState -> Handler OAuthState)
-> IO OAuthState -> Handler OAuthState
forall a b. (a -> b) -> a -> b
$ TVar OAuthState -> IO OAuthState
forall a. TVar a -> IO a
readTVarIO TVar OAuthState
oauthStateVar
    (Text
oldAccessToken, AuthUser
user) <- case Text -> Map Text (Text, AuthUser) -> Maybe (Text, AuthUser)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
refreshToken (OAuthState -> Map Text (Text, AuthUser)
refreshTokens OAuthState
oauthState) of
        Just (Text, AuthUser)
info -> (Text, AuthUser) -> Handler (Text, AuthUser)
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text, AuthUser)
info
        Maybe (Text, AuthUser)
Nothing -> ServerError -> Handler (Text, AuthUser)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text)]}

    -- Generate new JWT access token
    Text
newAccessTokenText <- AuthUser -> JWTSettings -> Handler Text
generateJWTAccessToken AuthUser
user JWTSettings
jwtSettings

    -- Update tokens
    IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar OAuthState -> (OAuthState -> OAuthState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar OAuthState
oauthStateVar ((OAuthState -> OAuthState) -> STM ())
-> (OAuthState -> OAuthState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \OAuthState
s ->
        OAuthState
s
            { accessTokens = Map.insert newAccessTokenText user $ Map.delete oldAccessToken (accessTokens s)
            , refreshTokens = Map.insert refreshToken (newAccessTokenText, user) (refreshTokens s)
            }

    TokenResponse -> Handler TokenResponse
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return
        TokenResponse
            { $sel:access_token:TokenResponse :: Text
access_token = Text
newAccessTokenText
            , $sel:token_type:TokenResponse :: Text
token_type = Text
"Bearer"
            , $sel:expires_in:TokenResponse :: Maybe Int
expires_in = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> (OAuthConfig -> Int) -> Maybe OAuthConfig -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
3600 OAuthConfig -> Int
accessTokenExpirySeconds (HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config)
            , $sel:refresh_token:TokenResponse :: Maybe Text
refresh_token = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
refreshToken
            , $sel:scope:TokenResponse :: Maybe Text
scope = Maybe Text
forall a. Maybe a
Nothing
            }

-- | Generate random authorization code
generateAuthCode :: IO Text
generateAuthCode :: IO Text
generateAuthCode = do
    UUID
uuid <- IO UUID
UUID.nextRandom
    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
$ Text
"code_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UUID -> Text
UUID.toText UUID
uuid

-- | Generate authorization code with configurable prefix
generateAuthCodeWithConfig :: HTTPServerConfig -> IO Text
generateAuthCodeWithConfig :: HTTPServerConfig -> IO Text
generateAuthCodeWithConfig HTTPServerConfig
config = do
    UUID
uuid <- IO UUID
UUID.nextRandom
    let prefix :: Text
prefix = Text -> (OAuthConfig -> Text) -> Maybe OAuthConfig -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"code_" OAuthConfig -> Text
authCodePrefix (HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config)
    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
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UUID -> Text
UUID.toText UUID
uuid

-- | Generate JWT access token for user
generateJWTAccessToken :: AuthUser -> JWTSettings -> Handler Text
generateJWTAccessToken :: AuthUser -> JWTSettings -> Handler Text
generateJWTAccessToken AuthUser
user JWTSettings
jwtSettings = do
    Either Error ByteString
accessTokenResult <- IO (Either Error ByteString) -> Handler (Either Error ByteString)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error ByteString) -> Handler (Either Error ByteString))
-> IO (Either Error ByteString)
-> Handler (Either Error ByteString)
forall a b. (a -> b) -> a -> b
$ AuthUser
-> JWTSettings -> Maybe UTCTime -> IO (Either Error ByteString)
forall a.
ToJWT a =>
a -> JWTSettings -> Maybe UTCTime -> IO (Either Error ByteString)
makeJWT AuthUser
user JWTSettings
jwtSettings Maybe UTCTime
forall a. Maybe a
Nothing
    case Either Error ByteString
accessTokenResult of
        Left Error
_err -> ServerError -> Handler Text
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err500{errBody = encode $ object ["error" .= ("Token generation failed" :: Text)]}
        Right ByteString
accessToken -> Text -> Handler Text
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Handler Text) -> Text -> Handler Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
accessToken

-- | Generate refresh token with configurable prefix
generateRefreshTokenWithConfig :: HTTPServerConfig -> IO Text
generateRefreshTokenWithConfig :: HTTPServerConfig -> IO Text
generateRefreshTokenWithConfig HTTPServerConfig
config = do
    UUID
uuid <- IO UUID
UUID.nextRandom
    let prefix :: Text
prefix = Text -> (OAuthConfig -> Text) -> Maybe OAuthConfig -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"rt_" OAuthConfig -> Text
refreshTokenPrefix (HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config)
    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
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UUID -> Text
UUID.toText UUID
uuid

-- | Default demo OAuth configuration for testing purposes
defaultDemoOAuthConfig :: OAuthConfig
defaultDemoOAuthConfig :: OAuthConfig
defaultDemoOAuthConfig =
    OAuthConfig
        { $sel:oauthEnabled:OAuthConfig :: Bool
oauthEnabled = Bool
True
        , $sel:oauthProviders:OAuthConfig :: [OAuthProvider]
oauthProviders = []
        , $sel:tokenValidationEndpoint:OAuthConfig :: Maybe Text
tokenValidationEndpoint = Maybe Text
forall a. Maybe a
Nothing
        , $sel:requireHTTPS:OAuthConfig :: Bool
requireHTTPS = Bool
False -- For demo only
        -- Default timing parameters
        , $sel:authCodeExpirySeconds:OAuthConfig :: Int
authCodeExpirySeconds = Int
600 -- 10 minutes
        , $sel:accessTokenExpirySeconds:OAuthConfig :: Int
accessTokenExpirySeconds = Int
3600 -- 1 hour
        -- Default OAuth parameters
        , $sel:supportedScopes:OAuthConfig :: [Text]
supportedScopes = [Text
"mcp:read", Text
"mcp:write"]
        , $sel:supportedResponseTypes:OAuthConfig :: [Text]
supportedResponseTypes = [Text
"code"]
        , $sel:supportedGrantTypes:OAuthConfig :: [Text]
supportedGrantTypes = [Text
"authorization_code", Text
"refresh_token"]
        , $sel:supportedAuthMethods:OAuthConfig :: [Text]
supportedAuthMethods = [Text
"none"]
        , $sel:supportedCodeChallengeMethods:OAuthConfig :: [Text]
supportedCodeChallengeMethods = [Text
"S256"]
        , -- Demo mode settings
          $sel:autoApproveAuth:OAuthConfig :: Bool
autoApproveAuth = Bool
True
        , $sel:demoUserIdTemplate:OAuthConfig :: Maybe Text
demoUserIdTemplate = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"test-user-{clientId}"
        , $sel:demoEmailDomain:OAuthConfig :: Text
demoEmailDomain = Text
"example.com"
        , $sel:demoUserName:OAuthConfig :: Text
demoUserName = Text
"Test User"
        , $sel:publicClientSecret:OAuthConfig :: Maybe Text
publicClientSecret = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
        , -- Default token prefixes
          $sel:authCodePrefix:OAuthConfig :: Text
authCodePrefix = Text
"code_"
        , $sel:refreshTokenPrefix:OAuthConfig :: Text
refreshTokenPrefix = Text
"rt_"
        , $sel:clientIdPrefix:OAuthConfig :: Text
clientIdPrefix = Text
"client_"
        , -- Default response template
          $sel:authorizationSuccessTemplate:OAuthConfig :: Maybe Text
authorizationSuccessTemplate = Maybe Text
forall a. Maybe a
Nothing
        }

-- | Run the MCP server as an HTTP server
runServerHTTP :: (MCPServer MCPServerM) => HTTPServerConfig -> IO ()
runServerHTTP :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig -> IO ()
runServerHTTP HTTPServerConfig
config = do
    -- Initialize JWT settings if OAuth is enabled
    JWTSettings
jwtSettings <- case HTTPServerConfig -> Maybe JWK
httpJWK HTTPServerConfig
config of
        Just JWK
jwk -> JWTSettings -> IO JWTSettings
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JWTSettings -> IO JWTSettings) -> JWTSettings -> IO JWTSettings
forall a b. (a -> b) -> a -> b
$ JWK -> JWTSettings
defaultJWTSettings JWK
jwk
        Maybe JWK
Nothing -> JWK -> JWTSettings
defaultJWTSettings (JWK -> JWTSettings) -> IO JWK -> IO JWTSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO JWK
generateKey

    -- Initialize the server state
    TVar ServerState
stateVar <- ServerState -> IO (TVar ServerState)
forall a. a -> IO (TVar a)
newTVarIO (ServerState -> IO (TVar ServerState))
-> ServerState -> IO (TVar ServerState)
forall a b. (a -> b) -> a -> b
$ ServerCapabilities -> ServerState
initialServerState (HTTPServerConfig -> ServerCapabilities
httpCapabilities HTTPServerConfig
config)

    -- Initialize OAuth state
    TVar OAuthState
oauthStateVar <-
        OAuthState -> IO (TVar OAuthState)
forall a. a -> IO (TVar a)
newTVarIO (OAuthState -> IO (TVar OAuthState))
-> OAuthState -> IO (TVar OAuthState)
forall a b. (a -> b) -> a -> b
$
            OAuthState
                { $sel:authCodes:OAuthState :: Map Text AuthorizationCode
authCodes = Map Text AuthorizationCode
forall k a. Map k a
Map.empty
                , $sel:accessTokens:OAuthState :: Map Text AuthUser
accessTokens = Map Text AuthUser
forall k a. Map k a
Map.empty
                , $sel:refreshTokens:OAuthState :: Map Text (Text, AuthUser)
refreshTokens = Map Text (Text, AuthUser)
forall k a. Map k a
Map.empty
                , $sel:registeredClients:OAuthState :: Map Text ClientInfo
registeredClients = Map Text ClientInfo
forall k a. Map k a
Map.empty
                }

    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting MCP HTTP Server on port " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (HTTPServerConfig -> Int
httpPort HTTPServerConfig
config) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> (OAuthConfig -> Bool) -> Maybe OAuthConfig -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False OAuthConfig -> Bool
oauthEnabled (HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn String
"OAuth authentication enabled"
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Authorization endpoint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (HTTPServerConfig -> Text
httpBaseUrl HTTPServerConfig
config) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/authorize"
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Token endpoint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (HTTPServerConfig -> Text
httpBaseUrl HTTPServerConfig
config) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/token"
        case HTTPServerConfig -> Maybe OAuthConfig
httpOAuthConfig HTTPServerConfig
config Maybe OAuthConfig
-> (OAuthConfig -> Maybe [OAuthProvider]) -> Maybe [OAuthProvider]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \OAuthConfig
cfg -> if [OAuthProvider] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OAuthConfig -> [OAuthProvider]
oauthProviders OAuthConfig
cfg) then Maybe [OAuthProvider]
forall a. Maybe a
Nothing else [OAuthProvider] -> Maybe [OAuthProvider]
forall a. a -> Maybe a
Just (OAuthConfig -> [OAuthProvider]
oauthProviders OAuthConfig
cfg) of
            Just [OAuthProvider]
providers -> do
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"OAuth providers: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Text -> [Text] -> Text
T.intercalate Text
", " ((OAuthProvider -> Text) -> [OAuthProvider] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map OAuthProvider -> Text
providerName [OAuthProvider]
providers))
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((OAuthProvider -> Bool) -> [OAuthProvider] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any OAuthProvider -> Bool
requiresPKCE [OAuthProvider]
providers) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"PKCE enabled (required by MCP spec)"
            Maybe [OAuthProvider]
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Int -> Application -> IO ()
run (HTTPServerConfig -> Int
httpPort HTTPServerConfig
config) (MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
HTTPServerConfig
-> TVar ServerState
-> TVar OAuthState
-> JWTSettings
-> Application
HTTPServerConfig
-> TVar ServerState
-> TVar OAuthState
-> JWTSettings
-> Application
mcpApp HTTPServerConfig
config TVar ServerState
stateVar TVar OAuthState
oauthStateVar JWTSettings
jwtSettings)