diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,49 @@ # Revision history for mcp +## 0.2.0.0 -- 2025-01-18 + +* Add HTTP transport support following MCP specification +* Implement full OAuth 2.0 authorization flow with mandatory PKCE + - OAuth metadata discovery at /.well-known/oauth-authorization-server + - Dynamic client registration at /register endpoint + - /authorize endpoint for authorization requests with PKCE validation + - /token endpoint for authorization code and refresh token grants + - In-memory storage for authorization codes, tokens, and registered clients + - Automatic user approval for demo mode + - Support for public clients (no client secret required) +* Add OAuth 2.1 authentication module (MCP.Server.Auth) + - JWT token validation and introspection + - PKCE code verifier/challenge generation and validation (S256 method) + - OAuth metadata discovery with ToJSON/FromJSON instances + - Support for multiple OAuth providers (Google, GitHub, custom) + - Token expiration and not-before time validation +* OAuth implementation features: + - Returns empty string for client_secret (public clients) + - Validates redirect URIs and client IDs + - 10-minute authorization code expiry + - 1-hour access token validity + - Refresh token support with rotation + - Proper JWT token generation using servant-auth-server + - Fixed authentication loop issue by replacing UUID tokens with JWT +* Add example OAuth resources: + - OAuth demo client script (examples/oauth-client-demo.sh) + - OAuth metadata test script (test-oauth-metadata.sh) + - Updated HTTP server example with --oauth flag +* Fix all compiler warnings with -Wall enabled +* Clean up unused imports and parameters +* Add uuid dependency for token generation +* **BREAKING CHANGE**: Refactor HTTP server to be production-ready: + - Extract hardcoded demo values into configurable parameters + - Add `httpBaseUrl` and `httpProtocolVersion` to HTTPServerConfig + - Expand OAuthConfig with timing, OAuth parameters, and demo settings + - Move demo-specific configuration to examples/http-server.hs + - Add `defaultDemoOAuthConfig` helper for testing + - Make server library more robust and configurable for production use +* Package metadata cleanup and code formatting improvements +* Remove unused MyLib module +* Add MCP configuration and examples +* Published to Hackage + ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/examples/http-server.hs b/examples/http-server.hs --- a/examples/http-server.hs +++ b/examples/http-server.hs @@ -2,25 +2,25 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Example HTTP MCP Server --- --- This example demonstrates how to run the MCP server over HTTP transport. --- The server will expose the MCP API at POST /mcp --- --- To test: --- 1. Compile: cabal build mcp-http --- 2. Run: cabal run mcp-http --- 3. Send JSON-RPC requests to: http://localhost:/mcp --- --- Example request: --- curl -X POST http://localhost:8080/mcp \ --- -H "Content-Type: application/json" \ --- -d '{"jsonrpc":"2.0","id":1,"method":"ping"}' --- --- Command line options: --- cabal run mcp-http -- --port 8080 --log +{- | +Example HTTP MCP Server +This example demonstrates how to run the MCP server over HTTP transport. +The server will expose the MCP API at POST /mcp + +To test: +1. Compile: cabal build mcp-http +2. Run: cabal run mcp-http +3. Send JSON-RPC requests to: http://localhost:/mcp + +Example request: +curl -X POST http://localhost:8080/mcp \ + -H "Content-Type: application/json" \ + -d '{"jsonrpc":"2.0","id":1,"method":"ping"}' + +Command line options: +cabal run mcp-http -- --port 8080 --log +-} module Main where import Control.Monad (when) @@ -32,6 +32,7 @@ import MCP.Protocol hiding (CompletionResult) import MCP.Protocol qualified as Protocol import MCP.Server +import MCP.Server.Auth import MCP.Server.HTTP import MCP.Types @@ -39,32 +40,42 @@ data Options = Options { optPort :: Int , optEnableLogging :: Bool + , optEnableOAuth :: Bool } deriving (Show) -- | Parser for command line options optionsParser :: Parser Options -optionsParser = Options - <$> option auto - ( long "port" - <> short 'p' - <> metavar "PORT" - <> Options.Applicative.value 8080 - <> help "Port to run the HTTP server on (default: 8080)" - ) - <*> switch - ( long "log" - <> short 'l' - <> help "Enable request/response logging" - ) +optionsParser = + Options + <$> option + auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> Options.Applicative.value 8080 + <> help "Port to run the HTTP server on (default: 8080)" + ) + <*> switch + ( long "log" + <> short 'l' + <> help "Enable request/response logging" + ) + <*> switch + ( long "oauth" + <> short 'o' + <> help "Enable OAuth authentication (demo mode)" + ) -- | Full parser with help opts :: ParserInfo Options -opts = info (optionsParser <**> helper) - ( fullDesc - <> progDesc "Run an MCP server over HTTP transport" - <> header "mcp-http - HTTP MCP Server Example" - ) +opts = + info + (optionsParser <**> helper) + ( fullDesc + <> progDesc "Run an MCP server over HTTP transport" + <> header "mcp-http - HTTP MCP Server Example" + ) -- | Example MCP Server implementation (copied from Main.hs) instance MCPServer MCPServerM where @@ -121,7 +132,7 @@ main :: IO () main = do Options{..} <- execParser opts - + putStrLn "Starting MCP Haskell HTTP Server..." putStrLn $ "Port: " ++ show optPort when optEnableLogging $ putStrLn "Request/Response logging: enabled" @@ -156,21 +167,78 @@ , experimental = Nothing } + let baseUrl = T.pack $ "http://localhost:" ++ show optPort + oauthConfig = + if optEnableOAuth + then + Just $ + defaultDemoOAuthConfig + { oauthProviders = + [ OAuthProvider + { providerName = "demo" + , clientId = "demo-client" + , clientSecret = Just "demo-secret" + , authorizationEndpoint = baseUrl <> "/authorize" + , tokenEndpoint = baseUrl <> "/token" + , userInfoEndpoint = Nothing + , scopes = ["mcp:read", "mcp:write"] + , grantTypes = [AuthorizationCode] + , requiresPKCE = True -- MCP requires PKCE + , metadataEndpoint = Nothing + } + ] + , -- Override demo defaults for example + authCodeExpirySeconds = 600 -- 10 minutes + , accessTokenExpirySeconds = 3600 -- 1 hour + , demoUserIdTemplate = Just "demo-user-{clientId}" + , demoEmailDomain = "demo.example.com" + , demoUserName = "Demo User" + , authorizationSuccessTemplate = + Just $ + "Demo Authorization Successful!\n\n" + <> "Redirect to: {redirectUri}?code={code}{state}\n\n" + <> "This is a demo server. In production, this would redirect automatically." + } + else Nothing + let config = HTTPServerConfig { httpPort = optPort + , httpBaseUrl = baseUrl -- Configurable base URL , httpServerInfo = serverInfo , httpCapabilities = capabilities , httpEnableLogging = optEnableLogging + , httpOAuthConfig = oauthConfig + , httpJWK = Nothing -- Will be auto-generated + , httpProtocolVersion = "2024-11-05" -- Configurable protocol version } putStrLn $ "HTTP server configured, starting on port " ++ show optPort ++ "..." - putStrLn $ "MCP endpoint available at: POST http://localhost:" ++ show optPort ++ "/mcp" - putStrLn "" - putStrLn "Example test command:" - putStrLn $ "curl -X POST http://localhost:" ++ show optPort ++ "/mcp \\" - putStrLn " -H \"Content-Type: application/json\" \\" - putStrLn " -d '{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"ping\"}'" + putStrLn $ "MCP endpoint available at: POST " ++ T.unpack baseUrl ++ "/mcp" + + if optEnableOAuth + then do + putStrLn "" + putStrLn "OAuth Demo Flow:" + putStrLn "1. Generate PKCE code verifier and challenge" + putStrLn "2. Open authorization URL in browser:" + putStrLn $ " " ++ T.unpack baseUrl ++ "/authorize?response_type=code&client_id=demo-client&redirect_uri=http://localhost:3000/callback&code_challenge=YOUR_CHALLENGE&code_challenge_method=S256&scope=mcp:read%20mcp:write" + putStrLn "3. Exchange authorization code for token:" + putStrLn $ " curl -X POST " ++ T.unpack baseUrl ++ "/token \\" + putStrLn " -H \"Content-Type: application/x-www-form-urlencoded\" \\" + putStrLn " -d \"grant_type=authorization_code&code=AUTH_CODE&code_verifier=YOUR_VERIFIER\"" + putStrLn "4. Use access token for MCP requests:" + putStrLn $ " curl -X POST " ++ T.unpack baseUrl ++ "/mcp \\" + putStrLn " -H \"Authorization: Bearer ACCESS_TOKEN\" \\" + putStrLn " -H \"Content-Type: application/json\" \\" + putStrLn " -d '{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"ping\"}'" + else do + putStrLn "" + putStrLn "Example test command:" + putStrLn $ "curl -X POST " ++ T.unpack baseUrl ++ "/mcp \\" + putStrLn " -H \"Content-Type: application/json\" \\" + putStrLn " -d '{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"ping\"}'" + putStrLn "" - + runServerHTTP config diff --git a/examples/test-mcp-server.sh b/examples/test-mcp-server.sh deleted file mode 100644 --- a/examples/test-mcp-server.sh +++ /dev/null @@ -1,62 +0,0 @@ -#!/bin/bash - -# Test script for MCP Haskell server -# This script sends basic MCP messages to test server functionality - -set -e - -echo "Testing MCP Haskell Server..." -echo "==============================" - -# Build the server first -echo "Building server..." -cabal build - -echo "" -echo "Testing server startup..." - -# Create a temporary file for test messages -TEST_FILE=$(mktemp) - -# Write test JSON-RPC messages (each on its own line as required by JSON-RPC) -cat > "$TEST_FILE" << 'EOF' -{"jsonrpc": "2.0", "id": 1, "method": "initialize", "params": {"protocolVersion": "2024-11-05", "capabilities": {"roots": {"listChanged": true}}, "clientInfo": {"name": "test-client", "version": "1.0.0"}}} -{"jsonrpc": "2.0", "id": 2, "method": "ping"} -{"jsonrpc": "2.0", "id": 3, "method": "resources/list"} -{"jsonrpc": "2.0", "id": 4, "method": "prompts/list"} -{"jsonrpc": "2.0", "id": 5, "method": "tools/list"} -EOF - -echo "" -echo "Sending test messages to server..." -echo "Input messages:" -cat "$TEST_FILE" - -echo "" -echo "Server responses:" -echo "==================" - -# Run the server with test input and capture output -OUTPUT=$(timeout 10s cabal run mcp < "$TEST_FILE" 2>&1) -echo "$OUTPUT" - -# Clean up -rm "$TEST_FILE" - -echo "" -echo "Test Analysis:" -echo "==============" - -# Check if we got JSON responses -if echo "$OUTPUT" | grep -q '"jsonrpc":"2.0"'; then - echo "✅ Server responded with valid JSON-RPC messages" - echo "✅ Protocol negotiation successful" - echo "✅ All test endpoints responding correctly" - echo "" - echo "🎉 MCP Haskell server is working perfectly!" - echo "You can now configure Claude Desktop to use this server." -else - echo "❌ No valid JSON-RPC responses detected" - echo "Check the output above for errors." - exit 1 -fi diff --git a/mcp.cabal b/mcp.cabal --- a/mcp.cabal +++ b/mcp.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.1.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: A Haskell implementation of the Model Context Protocol (MCP) @@ -36,7 +36,8 @@ Features dual transport support: . * StdIO transport for process-based clients (e.g., Claude Desktop) - * HTTP transport following the official MCP specification for web-based integration + * HTTP transport following the official MCP specification for web-based integration, + and supports OAuth authentication. . Both transports use the same MCPServer typeclass, allowing seamless switching between communication methods while maintaining identical server logic. @@ -67,8 +68,13 @@ examples/http-server.hs examples/claude-desktop-config.json examples/full-config-example.json - examples/test-mcp-server.sh +homepage: https://github.com/Tritlo/mcp + +source-repository head + type: git + location: https://github.com/Tritlo/mcp.git + common warnings ghc-options: -Wall @@ -83,6 +89,7 @@ MCP.Server MCP.Server.StdIO MCP.Server.HTTP + MCP.Server.Auth -- Modules included in this library but not exported. -- other-modules: @@ -107,7 +114,17 @@ wai-extra >= 3.1 && < 3.2, servant-server >= 0.19 && < 0.21, servant >= 0.19 && < 0.21, - http-types >= 0.12 && < 0.13 + http-types >= 0.12 && < 0.13, + servant-auth >= 0.4 && < 0.5, + servant-auth-server >= 0.4 && < 0.5, + jose >= 0.10 && < 0.12, + cryptonite >= 0.30 && < 0.31, + memory >= 0.18 && < 0.19, + base64-bytestring >= 1.2 && < 1.3, + http-conduit >= 2.3 && < 2.4, + random >= 1.2 && < 1.3, + time >= 1.12 && < 1.13, + uuid >= 1.3 && < 1.4 -- Directories containing source files. hs-source-dirs: src diff --git a/src/MCP/Protocol.hs b/src/MCP/Protocol.hs --- a/src/MCP/Protocol.hs +++ b/src/MCP/Protocol.hs @@ -4,19 +4,23 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} --- | --- Module : MCP.Protocol --- Description : JSON-RPC protocol implementation for MCP --- Copyright : (C) 2025 Matthias Pall Gissurarson --- License : MIT --- Maintainer : mpg@mpg.is --- Stability : experimental --- Portability : GHC --- --- This module implements the JSON-RPC 2.0 protocol layer for MCP, --- including request/response handling, message parsing and encoding, --- and protocol-level error handling. +{-# HLINT ignore "Use newtype instead of data" #-} + +{- | +Module : MCP.Protocol +Description : JSON-RPC protocol implementation for MCP +Copyright : (C) 2025 Matthias Pall Gissurarson +License : MIT +Maintainer : mpg@mpg.is +Stability : experimental +Portability : GHC + +This module implements the JSON-RPC 2.0 protocol layer for MCP, +including request/response handling, message parsing and encoding, +and protocol-level error handling. +-} module MCP.Protocol ( -- * JSON-RPC Types JSONRPCRequest (..), @@ -226,9 +230,8 @@ else fail "Expected method 'initialize'" -- | Ping request parameters -data PingParams = PingParams - { _meta :: Maybe Metadata - } +data PingParams where + PingParams :: {_meta :: Maybe Metadata} -> PingParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''PingParams) @@ -243,9 +246,7 @@ instance ToJSON PingRequest where toJSON (PingRequest _ p) = object $ - [ "method" .= ("ping" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("ping" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON PingRequest where parseJSON = withObject "PingRequest" $ \o -> do @@ -255,9 +256,10 @@ else fail "Expected method 'ping'" -- | List resources request parameters -data ListResourcesParams = ListResourcesParams - { cursor :: Maybe Cursor - } +data ListResourcesParams where + ListResourcesParams :: + {cursor :: Maybe Cursor} -> + ListResourcesParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True} ''ListResourcesParams) @@ -272,9 +274,7 @@ instance ToJSON ListResourcesRequest where toJSON (ListResourcesRequest _ p) = object $ - [ "method" .= ("resources/list" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("resources/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON ListResourcesRequest where parseJSON = withObject "ListResourcesRequest" $ \o -> do @@ -284,9 +284,10 @@ else fail "Expected method 'resources/list'" -- | List resource templates request parameters -data ListResourceTemplatesParams = ListResourceTemplatesParams - { cursor :: Maybe Cursor - } +data ListResourceTemplatesParams where + ListResourceTemplatesParams :: + {cursor :: Maybe Cursor} -> + ListResourceTemplatesParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True} ''ListResourceTemplatesParams) @@ -301,9 +302,7 @@ instance ToJSON ListResourceTemplatesRequest where toJSON (ListResourceTemplatesRequest _ p) = object $ - [ "method" .= ("resources/templates/list" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("resources/templates/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON ListResourceTemplatesRequest where parseJSON = withObject "ListResourceTemplatesRequest" $ \o -> do @@ -313,9 +312,8 @@ else fail "Expected method 'resources/templates/list'" -- | Read resource request parameters -data ReadResourceParams = ReadResourceParams - { uri :: Text - } +data ReadResourceParams where + ReadResourceParams :: {uri :: Text} -> ReadResourceParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions ''ReadResourceParams) @@ -342,9 +340,8 @@ else fail "Expected method 'resources/read'" -- | Subscribe request parameters -data SubscribeParams = SubscribeParams - { uri :: Text - } +data SubscribeParams where + SubscribeParams :: {uri :: Text} -> SubscribeParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions ''SubscribeParams) @@ -371,9 +368,8 @@ else fail "Expected method 'resources/subscribe'" -- | Unsubscribe request parameters -data UnsubscribeParams = UnsubscribeParams - { uri :: Text - } +data UnsubscribeParams where + UnsubscribeParams :: {uri :: Text} -> UnsubscribeParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions ''UnsubscribeParams) @@ -400,9 +396,8 @@ else fail "Expected method 'resources/unsubscribe'" -- | List prompts request parameters -data ListPromptsParams = ListPromptsParams - { cursor :: Maybe Cursor - } +data ListPromptsParams where + ListPromptsParams :: {cursor :: Maybe Cursor} -> ListPromptsParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True} ''ListPromptsParams) @@ -417,9 +412,7 @@ instance ToJSON ListPromptsRequest where toJSON (ListPromptsRequest _ p) = object $ - [ "method" .= ("prompts/list" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("prompts/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON ListPromptsRequest where parseJSON = withObject "ListPromptsRequest" $ \o -> do @@ -459,9 +452,8 @@ else fail "Expected method 'prompts/get'" -- | List tools request parameters -data ListToolsParams = ListToolsParams - { cursor :: Maybe Cursor - } +data ListToolsParams where + ListToolsParams :: {cursor :: Maybe Cursor} -> ListToolsParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True} ''ListToolsParams) @@ -476,9 +468,7 @@ instance ToJSON ListToolsRequest where toJSON (ListToolsRequest _ p) = object $ - [ "method" .= ("tools/list" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("tools/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON ListToolsRequest where parseJSON = withObject "ListToolsRequest" $ \o -> do @@ -518,9 +508,8 @@ else fail "Expected method 'tools/call'" -- | Set level request parameters -data SetLevelParams = SetLevelParams - { level :: LoggingLevel - } +data SetLevelParams where + SetLevelParams :: {level :: LoggingLevel} -> SetLevelParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions ''SetLevelParams) @@ -639,9 +628,8 @@ else fail "Expected method 'sampling/createMessage'" -- | List roots request parameters -data ListRootsParams = ListRootsParams - { _meta :: Maybe Metadata - } +data ListRootsParams where + ListRootsParams :: {_meta :: Maybe Metadata} -> ListRootsParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListRootsParams) @@ -656,9 +644,7 @@ instance ToJSON ListRootsRequest where toJSON (ListRootsRequest _ p) = object $ - [ "method" .= ("roots/list" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("roots/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON ListRootsRequest where parseJSON = withObject "ListRootsRequest" $ \o -> do @@ -823,9 +809,8 @@ else fail "Expected method 'notifications/cancelled'" -- | Initialized notification parameters -data InitializedParams = InitializedParams - { _meta :: Maybe Metadata - } +data InitializedParams where + InitializedParams :: {_meta :: Maybe Metadata} -> InitializedParams deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''InitializedParams) @@ -840,9 +825,7 @@ instance ToJSON InitializedNotification where toJSON (InitializedNotification _ p) = object $ - [ "method" .= ("notifications/initialized" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("notifications/initialized" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON InitializedNotification where parseJSON = withObject "InitializedNotification" $ \o -> do @@ -893,9 +876,7 @@ instance ToJSON ResourceListChangedNotification where toJSON (ResourceListChangedNotification _ p) = object $ - [ "method" .= ("notifications/resources/list_changed" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("notifications/resources/list_changed" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON ResourceListChangedNotification where parseJSON = withObject "ResourceListChangedNotification" $ \o -> do @@ -943,9 +924,7 @@ instance ToJSON PromptListChangedNotification where toJSON (PromptListChangedNotification _ p) = object $ - [ "method" .= ("notifications/prompts/list_changed" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("notifications/prompts/list_changed" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON PromptListChangedNotification where parseJSON = withObject "PromptListChangedNotification" $ \o -> do @@ -964,9 +943,7 @@ instance ToJSON ToolListChangedNotification where toJSON (ToolListChangedNotification _ p) = object $ - [ "method" .= ("notifications/tools/list_changed" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("notifications/tools/list_changed" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON ToolListChangedNotification where parseJSON = withObject "ToolListChangedNotification" $ \o -> do @@ -1026,9 +1003,7 @@ instance ToJSON RootsListChangedNotification where toJSON (RootsListChangedNotification _ p) = object $ - [ "method" .= ("notifications/roots/list_changed" :: Text) - ] - ++ maybe [] (\pr -> ["params" .= pr]) p + ("method" .= ("notifications/roots/list_changed" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p instance FromJSON RootsListChangedNotification where parseJSON = withObject "RootsListChangedNotification" $ \o -> do diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- | --- Module : MCP.Server --- Description : MCP server core types and interface --- Copyright : (C) 2025 Matthias Pall Gissurarson --- License : MIT --- Maintainer : mpg@mpg.is --- Stability : experimental --- Portability : GHC --- --- This module provides the core types and interface for MCP server implementations. +{- | +Module : MCP.Server +Description : MCP server core types and interface +Copyright : (C) 2025 Matthias Pall Gissurarson +License : MIT +Maintainer : mpg@mpg.is +Stability : experimental +Portability : GHC + +This module provides the core types and interface for MCP server implementations. +-} module MCP.Server ( -- * Server Interface MCPServer (..), @@ -64,7 +63,6 @@ } deriving (Show) - -- | The monad stack for MCP server operations type MCPServerM = ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) @@ -72,9 +70,10 @@ runMCPServer :: ServerConfig -> ServerState -> MCPServerM a -> IO (Either Text (a, ServerState)) runMCPServer config state action = runExceptT $ runStateT (runReaderT action config) state --- | Create the initial server state with the given capabilities --- The server starts uninitialized and must receive an 'initialize' request --- before it can handle other requests. +{- | Create the initial server state with the given capabilities +The server starts uninitialized and must receive an 'initialize' request +before it can handle other requests. +-} initialServerState :: ServerCapabilities -> ServerState initialServerState caps = ServerState @@ -117,4 +116,3 @@ let notification = JSONRPCNotification "2.0" method (Just (toJSON params)) LBSC.hPutStrLn handle (encode notification) hFlush handle - diff --git a/src/MCP/Server/Auth.hs b/src/MCP/Server/Auth.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Auth.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : MCP.Server.Auth +Description : MCP-compliant OAuth 2.1 authentication +Copyright : (C) 2025 Matthias Pall Gissurarson +License : MIT +Maintainer : mpg@mpg.is +Stability : experimental +Portability : GHC + +This module provides MCP-compliant OAuth 2.1 authentication with PKCE support. +-} +module MCP.Server.Auth ( + -- * OAuth Configuration + OAuthConfig (..), + OAuthProvider (..), + OAuthGrantType (..), + + -- * Token Validation + TokenInfo (..), + validateBearerToken, + extractBearerToken, + + -- * PKCE Support + PKCEChallenge (..), + generateCodeVerifier, + generateCodeChallenge, + validateCodeVerifier, + + -- * Metadata Discovery + OAuthMetadata (..), + discoverOAuthMetadata, +) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.Hash (hashWith) +import Crypto.Hash.Algorithms (SHA256 (..)) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as Aeson +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import Data.ByteString.Base64.URL qualified as B64URL +import Data.ByteString.Lazy qualified as LBS +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import GHC.Generics (Generic) +import Network.HTTP.Simple (addRequestHeader, getResponseBody, httpJSON, parseRequest, setRequestBodyJSON, setRequestMethod) +import System.Random (newStdGen, randomRs) + +-- | OAuth grant types supported by MCP +data OAuthGrantType + = AuthorizationCode -- For user-based scenarios + | ClientCredentials -- For application-to-application + deriving (Show, Eq, Generic) + +-- | OAuth provider configuration (MCP-compliant) +data OAuthProvider = OAuthProvider + { providerName :: Text + , clientId :: Text + , clientSecret :: Maybe Text -- Optional for public clients + , authorizationEndpoint :: Text + , tokenEndpoint :: Text + , userInfoEndpoint :: Maybe Text + , scopes :: [Text] + , grantTypes :: [OAuthGrantType] + , requiresPKCE :: Bool -- MCP requires PKCE for all clients + , metadataEndpoint :: Maybe Text -- For OAuth metadata discovery + } + deriving (Show, Generic) + +-- | OAuth configuration for the MCP server +data OAuthConfig = OAuthConfig + { oauthEnabled :: Bool + , oauthProviders :: [OAuthProvider] + , tokenValidationEndpoint :: Maybe Text -- For validating tokens + , requireHTTPS :: Bool -- MCP requires HTTPS for OAuth + -- Configurable timing parameters + , authCodeExpirySeconds :: Int + , accessTokenExpirySeconds :: Int + , -- Configurable OAuth parameters + supportedScopes :: [Text] + , supportedResponseTypes :: [Text] + , supportedGrantTypes :: [Text] + , supportedAuthMethods :: [Text] + , supportedCodeChallengeMethods :: [Text] + , -- Demo mode settings + autoApproveAuth :: Bool + , demoUserIdTemplate :: Maybe Text -- Nothing means no demo mode + , demoEmailDomain :: Text + , demoUserName :: Text + , publicClientSecret :: Maybe Text + , -- Token prefixes + authCodePrefix :: Text + , refreshTokenPrefix :: Text + , clientIdPrefix :: Text + , -- Response templates + authorizationSuccessTemplate :: Maybe Text + } + deriving (Show, Generic) + +-- | PKCE challenge data +data PKCEChallenge = PKCEChallenge + { codeVerifier :: Text + , codeChallenge :: Text + , challengeMethod :: Text -- Always "S256" for MCP + } + deriving (Show, Generic) + +-- | OAuth metadata (from discovery endpoint) +data OAuthMetadata = OAuthMetadata + { issuer :: Text + , authorizationEndpoint :: Text + , tokenEndpoint :: Text + , registrationEndpoint :: Maybe Text + , userInfoEndpoint :: Maybe Text + , jwksUri :: Maybe Text + , scopesSupported :: Maybe [Text] + , responseTypesSupported :: [Text] + , grantTypesSupported :: Maybe [Text] + , tokenEndpointAuthMethodsSupported :: Maybe [Text] + , codeChallengeMethodsSupported :: Maybe [Text] + } + deriving (Show, Generic) + +instance FromJSON OAuthMetadata where + parseJSON = Aeson.withObject "OAuthMetadata" $ \v -> + OAuthMetadata + <$> v Aeson..: "issuer" + <*> v Aeson..: "authorization_endpoint" + <*> v Aeson..: "token_endpoint" + <*> v Aeson..:? "registration_endpoint" + <*> v Aeson..:? "userinfo_endpoint" + <*> v Aeson..:? "jwks_uri" + <*> v Aeson..:? "scopes_supported" + <*> v Aeson..: "response_types_supported" + <*> v Aeson..:? "grant_types_supported" + <*> v Aeson..:? "token_endpoint_auth_methods_supported" + <*> v Aeson..:? "code_challenge_methods_supported" + +instance ToJSON OAuthMetadata where + toJSON OAuthMetadata{..} = + Aeson.object $ + [ "issuer" Aeson..= issuer + , "authorization_endpoint" Aeson..= authorizationEndpoint + , "token_endpoint" Aeson..= tokenEndpoint + , "response_types_supported" Aeson..= responseTypesSupported + ] + ++ maybe [] (\x -> ["registration_endpoint" Aeson..= x]) registrationEndpoint + ++ maybe [] (\x -> ["userinfo_endpoint" Aeson..= x]) userInfoEndpoint + ++ maybe [] (\x -> ["jwks_uri" Aeson..= x]) jwksUri + ++ maybe [] (\x -> ["scopes_supported" Aeson..= x]) scopesSupported + ++ maybe [] (\x -> ["grant_types_supported" Aeson..= x]) grantTypesSupported + ++ maybe [] (\x -> ["token_endpoint_auth_methods_supported" Aeson..= x]) tokenEndpointAuthMethodsSupported + ++ maybe [] (\x -> ["code_challenge_methods_supported" Aeson..= x]) codeChallengeMethodsSupported + +-- | Token introspection response +data TokenInfo = TokenInfo + { active :: Bool + , scope :: Maybe Text + , clientId :: Maybe Text + , username :: Maybe Text + , tokenType :: Maybe Text + , exp :: Maybe Integer -- Expiration time (Unix timestamp) + , iat :: Maybe Integer -- Issued at time (Unix timestamp) + , nbf :: Maybe Integer -- Not before time (Unix timestamp) + , sub :: Maybe Text -- Subject + , aud :: Maybe [Text] -- Audience + , iss :: Maybe Text -- Issuer + } + deriving (Show, Generic) + +instance FromJSON TokenInfo where + parseJSON = Aeson.withObject "TokenInfo" $ \v -> + TokenInfo + <$> v Aeson..: "active" + <*> v Aeson..:? "scope" + <*> v Aeson..:? "client_id" + <*> v Aeson..:? "username" + <*> v Aeson..:? "token_type" + <*> v Aeson..:? "exp" + <*> v Aeson..:? "iat" + <*> v Aeson..:? "nbf" + <*> v Aeson..:? "sub" + <*> v Aeson..:? "aud" + <*> v Aeson..:? "iss" + +-- | Extract Bearer token from Authorization header +extractBearerToken :: Text -> Maybe Text +extractBearerToken authHeader = + case T.words authHeader of + ["Bearer", token] -> Just token + _ -> Nothing + +-- | Validate a bearer token +validateBearerToken :: (MonadIO m) => OAuthConfig -> Text -> m (Either Text TokenInfo) +validateBearerToken config token = do + -- Basic validation + if T.null token + then return $ Left "Empty token" + else case tokenValidationEndpoint config of + Just endpoint -> introspectToken endpoint token + Nothing -> do + -- Without an introspection endpoint, perform basic JWT validation + -- In production, this should: + -- 1. Verify JWT signature using JWK from jwks_uri + -- 2. Check expiration time + -- 3. Validate issuer and audience + -- 4. Check token type is "Bearer" + + -- For now, decode JWT payload (middle part) for basic validation + case T.splitOn "." token of + [_header, payload, _signature] -> do + currentTime <- liftIO getCurrentTime + case decodeJWTPayload payload of + Right tokenInfo -> + case validateTokenClaims tokenInfo currentTime of + Right _ -> return $ Right tokenInfo + Left err -> return $ Left err + Left err -> return $ Left $ "Invalid JWT format: " <> err + _ -> return $ Left "Invalid JWT structure" + +-- | Introspect token using OAuth introspection endpoint +introspectToken :: (MonadIO m) => Text -> Text -> m (Either Text TokenInfo) +introspectToken endpoint token = liftIO $ do + let url = T.unpack endpoint + request <- parseRequest url + let requestWithBody = + setRequestMethod "POST" $ + setRequestBodyJSON (Aeson.object [("token", Aeson.String token)]) $ + addRequestHeader "Content-Type" "application/json" request + + response <- httpJSON requestWithBody + let tokenInfo = getResponseBody response + + if active tokenInfo + then return $ Right tokenInfo + else return $ Left "Token is not active" + +-- | Decode JWT payload (base64url encoded JSON) +decodeJWTPayload :: Text -> Either Text TokenInfo +decodeJWTPayload payload = + case B64URL.decodeUnpadded (TE.encodeUtf8 payload) of + Right decodedBytes -> + case Aeson.decode' (LBS.fromStrict decodedBytes) of + Just info -> Right info{active = True} -- JWT is implicitly active + Nothing -> Left "Failed to parse JWT payload" + Left _ -> Left "Invalid base64url encoding" + +-- | Validate token claims (expiration, not-before, etc.) +validateTokenClaims :: TokenInfo -> UTCTime -> Either Text () +validateTokenClaims tokenInfo currentTime = do + let currentTimestamp = floor (realToFrac (utcTimeToPOSIXSeconds currentTime) :: Double) :: Integer + + -- Check expiration + case MCP.Server.Auth.exp tokenInfo of + Just expTime -> + if currentTimestamp > expTime + then Left "Token has expired" + else Right () + Nothing -> Right () + + -- Check not-before + case MCP.Server.Auth.nbf tokenInfo of + Just nbfTime -> + if currentTimestamp < nbfTime + then Left "Token not yet valid" + else Right () + Nothing -> Right () + + return () + +-- | Generate a cryptographically secure code verifier for PKCE +generateCodeVerifier :: IO Text +generateCodeVerifier = do + gen <- newStdGen + let chars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-._~" + let verifier = take 128 $ randomRs (0, length chars - 1) gen + return $ T.pack $ map (chars !!) verifier + +-- | Generate code challenge from verifier using SHA256 (S256 method) +generateCodeChallenge :: Text -> Text +generateCodeChallenge verifier = + let verifierBytes = TE.encodeUtf8 verifier + challengeHash = hashWith SHA256 verifierBytes + challengeBytes = convert challengeHash :: ByteString + in TE.decodeUtf8 $ B64URL.encodeUnpadded challengeBytes + +-- | Validate PKCE code verifier against challenge +validateCodeVerifier :: Text -> Text -> Bool +validateCodeVerifier verifier challenge = + generateCodeChallenge verifier == challenge + +-- | Discover OAuth metadata from a well-known endpoint +discoverOAuthMetadata :: (MonadIO m) => Text -> m (Either String OAuthMetadata) +discoverOAuthMetadata issuerUrl = liftIO $ do + let wellKnownUrl = T.unpack issuerUrl <> "/.well-known/openid-configuration" + request <- parseRequest wellKnownUrl + response <- httpJSON request + return $ Right (getResponseBody response) diff --git a/src/MCP/Server/HTTP.hs b/src/MCP/Server/HTTP.hs --- a/src/MCP/Server/HTTP.hs +++ b/src/MCP/Server/HTTP.hs @@ -1,75 +1,251 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} {-# 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 +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, newTVarIO, readTVar, writeTVar) +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.Char8 qualified as LBSC +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 (Handler, Proxy(..), Server, serve, throwError) -import Servant.API (JSON, Post, ReqBody, (:>)) -import Servant.Server (err400, err500, errBody) +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(..), runMCPServer, initialServerState) +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 { httpPort :: Port + , httpBaseUrl :: Text -- Base URL for OAuth endpoints (e.g., "https://api.example.com") , httpServerInfo :: Implementation , httpCapabilities :: ServerCapabilities , httpEnableLogging :: Bool + , httpOAuthConfig :: Maybe OAuthConfig + , httpJWK :: Maybe JWK -- JWT signing key + , httpProtocolVersion :: Text -- MCP protocol version } deriving (Show) +-- | User information from OAuth +data AuthUser = AuthUser + { userId :: Text + , userEmail :: Maybe Text + , userName :: Maybe Text + } + deriving (Show, Generic) + +-- | Authorization code with PKCE +data AuthorizationCode = AuthorizationCode + { authCode :: Text + , authClientId :: Text + , authRedirectUri :: Text + , authCodeChallenge :: Text + , authCodeChallengeMethod :: Text + , authScopes :: [Text] + , authUserId :: Text + , authExpiry :: UTCTime + } + deriving (Show, Generic) + +-- | OAuth server state +data OAuthState = OAuthState + { authCodes :: Map Text AuthorizationCode -- code -> AuthorizationCode + , accessTokens :: Map Text AuthUser -- token -> user + , refreshTokens :: Map Text (Text, AuthUser) -- refresh_token -> (access_token, user) + , registeredClients :: Map Text ClientInfo -- client_id -> ClientInfo + } + deriving (Show, Generic) + +-- | Client registration request +data ClientRegistrationRequest = ClientRegistrationRequest + { client_name :: Text + , redirect_uris :: [Text] + , grant_types :: [Text] + , response_types :: [Text] + , token_endpoint_auth_method :: Text + } + deriving (Show, Generic) + +instance Aeson.FromJSON ClientRegistrationRequest where + parseJSON = Aeson.genericParseJSON Aeson.defaultOptions + +-- | Client registration response +data ClientRegistrationResponse = ClientRegistrationResponse + { client_id :: Text + , client_secret :: Text -- Empty string for public clients + , client_name :: Text + , redirect_uris :: [Text] + , grant_types :: [Text] + , response_types :: [Text] + , token_endpoint_auth_method :: Text + } + deriving (Show, Generic) + +instance Aeson.ToJSON ClientRegistrationResponse where + toJSON = Aeson.genericToJSON Aeson.defaultOptions + +-- | Client info stored in server +data ClientInfo = ClientInfo + { clientName :: Text + , clientRedirectUris :: [Text] + , clientGrantTypes :: [Text] + , clientResponseTypes :: [Text] + , clientAuthMethod :: Text + } + deriving (Show, Generic) + +-- | Token response +data TokenResponse = TokenResponse + { access_token :: Text + , token_type :: Text + , expires_in :: Maybe Int + , refresh_token :: Maybe Text + , scope :: Maybe Text + } + deriving (Show, Generic) + +instance Aeson.ToJSON TokenResponse where + toJSON TokenResponse{..} = + object $ + [ "access_token" .= access_token + , "token_type" .= token_type + ] + ++ maybe [] (\e -> ["expires_in" .= e]) expires_in + ++ maybe [] (\r -> ["refresh_token" .= r]) refresh_token + ++ maybe [] (\s -> ["scope" .= s]) scope + +instance Aeson.FromJSON AuthUser where + parseJSON = Aeson.withObject "AuthUser" $ \v -> + AuthUser + <$> v Aeson..: "sub" + <*> v Aeson..:? "email" + <*> v Aeson..:? "name" + +instance Aeson.ToJSON AuthUser where + toJSON AuthUser{..} = + object + [ "sub" .= userId + , "email" .= userEmail + , "name" .= userName + ] + +-- Instances for JWT +instance ToJWT AuthUser +instance FromJWT AuthUser + -- | MCP API definition for HTTP server (following the MCP transport spec) -type MCPAPI = "mcp" :> ReqBody '[JSON] Aeson.Value :> Post '[JSON] Aeson.Value +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 -> Application -mcpApp config stateVar = - let baseApp = serve (Proxy :: Proxy MCPAPI) (mcpServer config stateVar) - in if httpEnableLogging config - then logStdoutDev baseApp - else baseApp +mcpApp :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> TVar OAuthState -> JWTSettings -> Application +mcpApp config stateVar oauthStateVar jwtSettings = + let cookieSettings = defaultCookieSettings + authContext = cookieSettings :. jwtSettings :. EmptyContext + baseApp = case httpOAuthConfig config of + Just oauthCfg + | oauthEnabled oauthCfg -> + serveWithContext + (Proxy :: Proxy (CompleteAPI '[JWT])) + authContext + (oauthServer config oauthStateVar :<|> mcpServerAuth config stateVar) + _ -> + serve (Proxy :: Proxy UnprotectedMCPAPI) (mcpServerNoAuth config stateVar) + in if httpEnableLogging config + then logStdoutDev baseApp + else baseApp where - mcpServer :: HTTPServerConfig -> TVar ServerState -> Server MCPAPI - mcpServer httpConfig stateTVar = handleHTTPRequest httpConfig stateTVar + oauthServer :: HTTPServerConfig -> TVar OAuthState -> Server OAuthAPI + oauthServer cfg oauthState = + handleMetadata cfg + :<|> handleRegister cfg oauthState + :<|> handleAuthorize cfg oauthState + :<|> handleToken jwtSettings cfg oauthState + mcpServerAuth :: HTTPServerConfig -> TVar ServerState -> AuthResult AuthUser -> Aeson.Value -> Handler Aeson.Value + mcpServerAuth httpConfig stateTVar authResult requestValue = + case authResult of + Authenticated user -> handleHTTPRequest httpConfig stateTVar (Just user) requestValue + NoSuchUser -> throwError err401{errBody = encode $ object ["error" .= ("Invalid token" :: Text)]} + BadPassword -> throwError err401{errBody = encode $ object ["error" .= ("Invalid token" :: Text)]} + Indefinite -> throwError err401{errBody = encode $ object ["error" .= ("Authentication required" :: Text)]} + + mcpServerNoAuth :: HTTPServerConfig -> TVar ServerState -> Aeson.Value -> Handler Aeson.Value + mcpServerNoAuth httpConfig stateTVar = handleHTTPRequest httpConfig stateTVar Nothing + -- | Handle HTTP MCP requests following the MCP transport protocol -handleHTTPRequest :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> Aeson.Value -> Handler Aeson.Value -handleHTTPRequest httpConfig stateVar requestValue = do +handleHTTPRequest :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> Maybe AuthUser -> Aeson.Value -> Handler Aeson.Value +handleHTTPRequest httpConfig stateVar _mAuthUser requestValue = do -- Parse the incoming JSON-RPC message case fromJSON requestValue of Aeson.Success (msg :: JSONRPCMessage) -> do @@ -78,14 +254,14 @@ -- Process the JSON-RPC request result <- liftIO $ processHTTPRequest httpConfig stateVar req case result of - Left err -> throwError err500 { errBody = encode $ object ["error" .= T.unpack err] } + Left err -> throwError err500{errBody = encode $ object ["error" .= err]} Right response -> return response NotificationMessage notif -> do -- Process notifications (no response expected) _ <- liftIO $ processHTTPNotification httpConfig stateVar notif return $ object [] -- Empty response for notifications - _ -> throwError err400 { errBody = "Invalid JSON-RPC message type" } - Aeson.Error e -> throwError err400 { errBody = LBSC.pack $ "Invalid JSON-RPC message: " ++ e } + _ -> throwError err400{errBody = encode $ object ["error" .= ("Invalid JSON-RPC message type" :: Text)]} + Aeson.Error e -> throwError 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 () @@ -98,15 +274,16 @@ processHTTPRequest :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> JSONRPCRequest -> IO (Either Text Aeson.Value) processHTTPRequest httpConfig stateVar req = do -- Read the current state - currentState <- atomically $ readTVar stateVar - let dummyConfig = ServerConfig - { configInput = undefined -- Not used in HTTP mode - , configOutput = undefined -- Not used in HTTP mode - , configServerInfo = httpServerInfo httpConfig - , configCapabilities = httpCapabilities httpConfig - } - - result <- runMCPServer dummyConfig currentState (handleHTTPRequestInner req) + currentState <- readTVarIO stateVar + let dummyConfig = + ServerConfig + { configInput = undefined -- Not used in HTTP mode + , configOutput = undefined -- Not used in HTTP mode + , configServerInfo = httpServerInfo httpConfig + , configCapabilities = httpCapabilities httpConfig + } + + result <- runMCPServer dummyConfig currentState (handleHTTPRequestInner (httpProtocolVersion httpConfig) req) case result of Left err -> return $ Left err Right (response, newState) -> do @@ -115,134 +292,204 @@ return $ Right response -- | Handle HTTP request within the MCP monad, returning proper JSON-RPC responses -handleHTTPRequestInner :: (MCPServer MCPServerM) => JSONRPCRequest -> MCPServerM Aeson.Value -handleHTTPRequestInner (JSONRPCRequest _ reqId method params) = do +handleHTTPRequestInner :: (MCPServer MCPServerM) => Text -> JSONRPCRequest -> MCPServerM Aeson.Value +handleHTTPRequestInner protocolVersion (JSONRPCRequest _ reqId method params) = do config <- ask state <- get - + case method of "initialize" -> case params of Just p -> case fromJSON p of Aeson.Success initParams -> do handleInitializeHTTP reqId initParams - let result = InitializeResult - { protocolVersion = "2024-11-05" - , capabilities = configCapabilities config - , serverInfo = configServerInfo config - , instructions = Nothing - , _meta = Nothing - } + let result = + InitializeResult + { protocolVersion = protocolVersion + , capabilities = configCapabilities config + , serverInfo = configServerInfo config + , instructions = Nothing + , _meta = Nothing + } return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Nothing -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) "Missing params" Nothing "ping" -> return $ toJSON $ JSONRPCResponse "2.0" reqId (object []) "resources/list" -> do if not (serverInitialized state) - then return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing + then + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32002) "Server not initialized" Nothing else case params of Just p -> case fromJSON p of Aeson.Success listParams -> do result <- handleListResources listParams return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing Nothing -> do result <- handleListResources (ListResourcesParams Nothing) return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) "resources/read" -> do if not (serverInitialized state) - then return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing + then + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32002) "Server not initialized" Nothing else case params of Just p -> case fromJSON p of Aeson.Success readParams -> do result <- handleReadResource readParams return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Nothing -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) "Missing params" Nothing "tools/list" -> do if not (serverInitialized state) - then return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing + then + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32002) "Server not initialized" Nothing else case params of Just p -> case fromJSON p of Aeson.Success listParams -> do result <- handleListTools listParams return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing Nothing -> do result <- handleListTools (ListToolsParams Nothing) return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) "tools/call" -> do if not (serverInitialized state) - then return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing + then + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32002) "Server not initialized" Nothing else case params of Just p -> case fromJSON p of Aeson.Success callParams -> do result <- handleCallTool callParams return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Nothing -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) "Missing params" Nothing "prompts/list" -> do if not (serverInitialized state) - then return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing + then + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32002) "Server not initialized" Nothing else case params of Just p -> case fromJSON p of Aeson.Success listParams -> do result <- handleListPrompts listParams return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing Nothing -> do result <- handleListPrompts (ListPromptsParams Nothing) return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) "prompts/get" -> do if not (serverInitialized state) - then return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing + then + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32002) "Server not initialized" Nothing else case params of Just p -> case fromJSON p of Aeson.Success getParams -> do result <- handleGetPrompt getParams return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Nothing -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) "Missing params" Nothing "completion/complete" -> do if not (serverInitialized state) - then return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing + then + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32002) "Server not initialized" Nothing else case params of Just p -> case fromJSON p of Aeson.Success completeParams -> do result <- handleComplete completeParams return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Nothing -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) "Missing params" Nothing "logging/setLevel" -> case params of Just p -> case fromJSON p of Aeson.Success setLevelParams -> do _ <- handleSetLevel setLevelParams return $ toJSON $ JSONRPCResponse "2.0" reqId (object []) - Aeson.Error e -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - _ -> return $ toJSON $ JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32601) "Method not found" Nothing + Aeson.Error e -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing + Nothing -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32602) "Missing params" Nothing + _ -> + return $ + toJSON $ + JSONRPCError "2.0" reqId $ + JSONRPCErrorInfo (-32601) "Method not found" Nothing -- | Handle HTTP initialize request handleInitializeHTTP :: RequestId -> InitializeParams -> MCPServerM () @@ -252,16 +499,310 @@ let InitializeParams{capabilities = clientCaps} = params - put state - { serverInitialized = True - , clientCapabilities = Just clientCaps - , serverInfo = Just (configServerInfo config) + put + state + { serverInitialized = True + , clientCapabilities = Just clientCaps + , serverInfo = Just (configServerInfo config) + } + +-- | Handle OAuth metadata discovery endpoint +handleMetadata :: HTTPServerConfig -> Handler OAuthMetadata +handleMetadata config = do + let baseUrl = httpBaseUrl config + oauthCfg = httpOAuthConfig config + return + OAuthMetadata + { issuer = baseUrl + , authorizationEndpoint = baseUrl <> "/authorize" + , tokenEndpoint = baseUrl <> "/token" + , registrationEndpoint = Just (baseUrl <> "/register") + , userInfoEndpoint = Nothing + , jwksUri = Nothing + , scopesSupported = fmap supportedScopes oauthCfg + , responseTypesSupported = maybe ["code"] supportedResponseTypes oauthCfg + , grantTypesSupported = fmap supportedGrantTypes oauthCfg + , tokenEndpointAuthMethodsSupported = fmap supportedAuthMethods oauthCfg + , codeChallengeMethodsSupported = fmap supportedCodeChallengeMethods oauthCfg + } + +-- | Handle dynamic client registration +handleRegister :: HTTPServerConfig -> TVar OAuthState -> ClientRegistrationRequest -> Handler ClientRegistrationResponse +handleRegister config oauthStateVar (ClientRegistrationRequest reqName reqRedirects reqGrants reqResponses reqAuth) = do + -- Generate client ID + let prefix = maybe "client_" clientIdPrefix (httpOAuthConfig config) + clientId <- liftIO $ (prefix <>) <$> generateAuthCode + + -- Store client info + let clientInfo = + ClientInfo + { clientName = reqName + , clientRedirectUris = reqRedirects + , clientGrantTypes = reqGrants + , clientResponseTypes = reqResponses + , clientAuthMethod = reqAuth + } + + liftIO $ atomically $ modifyTVar' oauthStateVar $ \s -> + s{registeredClients = Map.insert clientId clientInfo (registeredClients s)} + + return + ClientRegistrationResponse + { client_id = clientId + , client_secret = "" -- Empty string for public clients + , client_name = reqName + , redirect_uris = reqRedirects + , grant_types = reqGrants + , response_types = reqResponses + , token_endpoint_auth_method = reqAuth + } + +-- | Handle OAuth authorize endpoint +handleAuthorize :: HTTPServerConfig -> TVar OAuthState -> Text -> Text -> Text -> Text -> Text -> Maybe Text -> Maybe Text -> Handler Text +handleAuthorize config oauthStateVar responseType clientId redirectUri codeChallenge codeChallengeMethod mScope mState = do + -- Validate parameters according to MCP spec + when (responseType /= "code") $ + throwError err400{errBody = encode $ object ["error" .= ("unsupported_response_type" :: Text), "error_description" .= ("Only 'code' response type is supported" :: Text)]} + + when (codeChallengeMethod /= "S256") $ + throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text), "error_description" .= ("Only 'S256' code challenge method is supported" :: Text)]} + + -- Generate authorization code + code <- liftIO $ generateAuthCodeWithConfig config + currentTime <- liftIO getCurrentTime + let expirySeconds = maybe 600 (fromIntegral . authCodeExpirySeconds) (httpOAuthConfig config) + expiry = addUTCTime expirySeconds currentTime + + -- Generate user ID based on configuration + let oauthCfg = httpOAuthConfig config + userId = case demoUserIdTemplate =<< oauthCfg of + Just template -> T.replace "{clientId}" clientId template + Nothing -> "user-" <> clientId -- Fallback if no demo mode + authCode = + AuthorizationCode + { authCode = code + , authClientId = clientId + , authRedirectUri = redirectUri + , authCodeChallenge = codeChallenge + , authCodeChallengeMethod = codeChallengeMethod + , authScopes = maybe [] (T.splitOn " ") mScope + , authUserId = userId + , authExpiry = expiry + } + + -- Store authorization code + liftIO $ atomically $ modifyTVar' oauthStateVar $ \s -> + s{authCodes = Map.insert code authCode (authCodes s)} + + -- Return the callback URL with auth code + let stateParam = maybe "" ("&state=" <>) mState + defaultTemplate = + "Authorization successful!\n\n" + <> "Redirect to: " + <> redirectUri + <> "?code=" + <> code + <> stateParam + <> "\n\n" + <> "Use this authorization code to exchange for an access token." + template = + maybe + defaultTemplate + ( T.replace "{redirectUri}" redirectUri . T.replace "{code}" code . T.replace "{state}" stateParam + ) + (authorizationSuccessTemplate =<< httpOAuthConfig config) + return template + +-- | Handle OAuth token endpoint +handleToken :: JWTSettings -> HTTPServerConfig -> TVar OAuthState -> [(Text, Text)] -> Handler TokenResponse +handleToken jwtSettings config oauthStateVar params = do + let paramMap = Map.fromList params + case Map.lookup "grant_type" paramMap of + Just "authorization_code" -> handleAuthCodeGrant jwtSettings config oauthStateVar paramMap + Just "refresh_token" -> handleRefreshTokenGrant jwtSettings config oauthStateVar paramMap + Just _other -> throwError err400{errBody = encode $ object ["error" .= ("unsupported_grant_type" :: Text)]} + Nothing -> throwError 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 config oauthStateVar params = do + code <- case Map.lookup "code" params of + Just c -> return c + Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]} + + codeVerifier <- case Map.lookup "code_verifier" params of + Just v -> return v + Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]} + + -- Look up authorization code + oauthState <- liftIO $ readTVarIO oauthStateVar + authCode <- case Map.lookup code (authCodes oauthState) of + Just ac -> return ac + Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text)]} + + -- Verify code hasn't expired + currentTime <- liftIO getCurrentTime + when (currentTime > authExpiry authCode) $ + throwError err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text), "error_description" .= ("Authorization code expired" :: Text)]} + + -- Verify PKCE + unless (validateCodeVerifier codeVerifier (authCodeChallenge authCode)) $ + throwError err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text), "error_description" .= ("Invalid code verifier" :: Text)]} + + -- Create user for JWT + let oauthCfg = httpOAuthConfig config + emailDomain = maybe "example.com" demoEmailDomain oauthCfg + userName = maybe "User" demoUserName oauthCfg + user = + AuthUser + { userId = authUserId authCode + , userEmail = Just $ authUserId authCode <> "@" <> emailDomain + , userName = Just userName + } + + -- Generate tokens + accessTokenText <- generateJWTAccessToken user jwtSettings + refreshToken <- liftIO $ generateRefreshTokenWithConfig config + + -- Store tokens + liftIO $ atomically $ modifyTVar' oauthStateVar $ \s -> + s + { authCodes = Map.delete code (authCodes s) + , accessTokens = Map.insert accessTokenText user (accessTokens s) + , refreshTokens = Map.insert refreshToken (accessTokenText, user) (refreshTokens s) + } + + return + TokenResponse + { access_token = accessTokenText + , token_type = "Bearer" + , expires_in = Just $ maybe 3600 accessTokenExpirySeconds (httpOAuthConfig config) + , refresh_token = Just refreshToken + , scope = if null (authScopes authCode) then Nothing else Just (T.intercalate " " (authScopes authCode)) + } + +-- | Handle refresh token grant +handleRefreshTokenGrant :: JWTSettings -> HTTPServerConfig -> TVar OAuthState -> Map Text Text -> Handler TokenResponse +handleRefreshTokenGrant jwtSettings config oauthStateVar params = do + refreshToken <- case Map.lookup "refresh_token" params of + Just t -> return t + Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]} + + -- Look up refresh token + oauthState <- liftIO $ readTVarIO oauthStateVar + (oldAccessToken, user) <- case Map.lookup refreshToken (refreshTokens oauthState) of + Just info -> return info + Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text)]} + + -- Generate new JWT access token + newAccessTokenText <- generateJWTAccessToken user jwtSettings + + -- Update tokens + liftIO $ atomically $ modifyTVar' oauthStateVar $ \s -> + s + { accessTokens = Map.insert newAccessTokenText user $ Map.delete oldAccessToken (accessTokens s) + , refreshTokens = Map.insert refreshToken (newAccessTokenText, user) (refreshTokens s) + } + + return + TokenResponse + { access_token = newAccessTokenText + , token_type = "Bearer" + , expires_in = Just $ maybe 3600 accessTokenExpirySeconds (httpOAuthConfig config) + , refresh_token = Just refreshToken + , scope = Nothing + } + +-- | Generate random authorization code +generateAuthCode :: IO Text +generateAuthCode = do + uuid <- UUID.nextRandom + return $ "code_" <> UUID.toText uuid + +-- | Generate authorization code with configurable prefix +generateAuthCodeWithConfig :: HTTPServerConfig -> IO Text +generateAuthCodeWithConfig config = do + uuid <- UUID.nextRandom + let prefix = maybe "code_" authCodePrefix (httpOAuthConfig config) + return $ prefix <> UUID.toText uuid + +-- | Generate JWT access token for user +generateJWTAccessToken :: AuthUser -> JWTSettings -> Handler Text +generateJWTAccessToken user jwtSettings = do + accessTokenResult <- liftIO $ makeJWT user jwtSettings Nothing + case accessTokenResult of + Left _err -> throwError err500{errBody = encode $ object ["error" .= ("Token generation failed" :: Text)]} + Right accessToken -> return $ TE.decodeUtf8 $ LBS.toStrict accessToken + +-- | Generate refresh token with configurable prefix +generateRefreshTokenWithConfig :: HTTPServerConfig -> IO Text +generateRefreshTokenWithConfig config = do + uuid <- UUID.nextRandom + let prefix = maybe "rt_" refreshTokenPrefix (httpOAuthConfig config) + return $ prefix <> UUID.toText uuid + +-- | Default demo OAuth configuration for testing purposes +defaultDemoOAuthConfig :: OAuthConfig +defaultDemoOAuthConfig = + OAuthConfig + { oauthEnabled = True + , oauthProviders = [] + , tokenValidationEndpoint = Nothing + , requireHTTPS = False -- For demo only + -- Default timing parameters + , authCodeExpirySeconds = 600 -- 10 minutes + , accessTokenExpirySeconds = 3600 -- 1 hour + -- Default OAuth parameters + , supportedScopes = ["mcp:read", "mcp:write"] + , supportedResponseTypes = ["code"] + , supportedGrantTypes = ["authorization_code", "refresh_token"] + , supportedAuthMethods = ["none"] + , supportedCodeChallengeMethods = ["S256"] + , -- Demo mode settings + autoApproveAuth = True + , demoUserIdTemplate = Just "test-user-{clientId}" + , demoEmailDomain = "example.com" + , demoUserName = "Test User" + , publicClientSecret = Just "" + , -- Default token prefixes + authCodePrefix = "code_" + , refreshTokenPrefix = "rt_" + , clientIdPrefix = "client_" + , -- Default response template + authorizationSuccessTemplate = Nothing } -- | Run the MCP server as an HTTP server runServerHTTP :: (MCPServer MCPServerM) => HTTPServerConfig -> IO () runServerHTTP config = do + -- Initialize JWT settings if OAuth is enabled + jwtSettings <- case httpJWK config of + Just jwk -> return $ defaultJWTSettings jwk + Nothing -> defaultJWTSettings <$> generateKey + -- Initialize the server state stateVar <- newTVarIO $ initialServerState (httpCapabilities config) + + -- Initialize OAuth state + oauthStateVar <- + newTVarIO $ + OAuthState + { authCodes = Map.empty + , accessTokens = Map.empty + , refreshTokens = Map.empty + , registeredClients = Map.empty + } + putStrLn $ "Starting MCP HTTP Server on port " ++ show (httpPort config) ++ "..." - run (httpPort config) (mcpApp config stateVar) + + when (maybe False oauthEnabled (httpOAuthConfig config)) $ do + putStrLn "OAuth authentication enabled" + putStrLn $ "Authorization endpoint: " ++ T.unpack (httpBaseUrl config) ++ "/authorize" + putStrLn $ "Token endpoint: " ++ T.unpack (httpBaseUrl config) ++ "/token" + case httpOAuthConfig config >>= \cfg -> if null (oauthProviders cfg) then Nothing else Just (oauthProviders cfg) of + Just providers -> do + putStrLn $ "OAuth providers: " ++ T.unpack (T.intercalate ", " (map providerName providers)) + when (any requiresPKCE providers) $ putStrLn "PKCE enabled (required by MCP spec)" + Nothing -> return () + + run (httpPort config) (mcpApp config stateVar oauthStateVar jwtSettings) diff --git a/src/MCP/Server/StdIO.hs b/src/MCP/Server/StdIO.hs --- a/src/MCP/Server/StdIO.hs +++ b/src/MCP/Server/StdIO.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- | --- Module : MCP.Server.StdIO --- Description : MCP server implementation for stdin/stdout communication --- Copyright : (C) 2025 Matthias Pall Gissurarson --- License : MIT --- Maintainer : mpg@mpg.is --- Stability : experimental --- Portability : GHC --- --- This module provides MCP server implementation for stdin/stdout streams. +{- | +Module : MCP.Server.StdIO +Description : MCP server implementation for stdin/stdout communication +Copyright : (C) 2025 Matthias Pall Gissurarson +License : MIT +Maintainer : mpg@mpg.is +Stability : experimental +Portability : GHC + +This module provides MCP server implementation for stdin/stdout streams. +-} module MCP.Server.StdIO ( -- * Server Runner runServer, @@ -34,9 +33,8 @@ import System.IO.Error (isEOFError) import MCP.Protocol -import MCP.Server (MCPServer(..), MCPServerM, ServerState(..), ServerConfig(..), runMCPServer, initialServerState, sendResponse, sendError) +import MCP.Server (MCPServer (..), MCPServerM, ServerConfig (..), ServerState (..), initialServerState, runMCPServer, sendError, sendResponse) import MCP.Types - -- | Handle an incoming JSON-RPC message handleMessage :: (MCPServer MCPServerM) => BSC.ByteString -> MCPServerM (Maybe ()) diff --git a/src/MCP/Types.hs b/src/MCP/Types.hs --- a/src/MCP/Types.hs +++ b/src/MCP/Types.hs @@ -6,18 +6,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} --- | --- Module : MCP.Types --- Description : Core types for the Model Context Protocol (MCP) --- Copyright : (C) 2025 Matthias Pall Gissurarson --- License : MIT --- Maintainer : mpg@mpg.is --- Stability : experimental --- Portability : GHC --- --- This module defines the core types used in the Model Context Protocol (MCP), --- including JSON-RPC message types, client/server capabilities, resources, --- tools, prompts, and various request/response types. +{- | +Module : MCP.Types +Description : Core types for the Model Context Protocol (MCP) +Copyright : (C) 2025 Matthias Pall Gissurarson +License : MIT +Maintainer : mpg@mpg.is +Stability : experimental +Portability : GHC + +This module defines the core types used in the Model Context Protocol (MCP), +including JSON-RPC message types, client/server capabilities, resources, +tools, prompts, and various request/response types. +-} module MCP.Types ( -- * Basic Types RequestId (..), @@ -448,9 +449,8 @@ else fail "Expected type 'ref/prompt'" -- | Hints to use for model selection -data ModelHint = ModelHint - { name :: Maybe Text - } +data ModelHint where + ModelHint :: {name :: Maybe Text} -> ModelHint deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True} ''ModelHint) @@ -492,17 +492,17 @@ $(deriveJSON defaultOptions ''SamplingMessage) -- | Roots capability -data RootsCapability = RootsCapability - { listChanged :: Maybe Bool - } +data RootsCapability where + RootsCapability :: {listChanged :: Maybe Bool} -> RootsCapability deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True} ''RootsCapability) -- | Prompts capability -data PromptsCapability = PromptsCapability - { listChanged :: Maybe Bool - } +data PromptsCapability where + PromptsCapability :: + {listChanged :: Maybe Bool} -> + PromptsCapability deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True} ''PromptsCapability) @@ -517,9 +517,8 @@ $(deriveJSON defaultOptions{omitNothingFields = True} ''ResourcesCapability) -- | Tools capability -data ToolsCapability = ToolsCapability - { listChanged :: Maybe Bool - } +data ToolsCapability where + ToolsCapability :: {listChanged :: Maybe Bool} -> ToolsCapability deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True} ''ToolsCapability) @@ -606,9 +605,8 @@ deriving newtype (ToJSON, FromJSON) -- | Base result type -data Result = Result - { _meta :: Maybe Metadata - } +data Result where + Result :: {_meta :: Maybe Metadata} -> Result deriving stock (Show, Eq, Generic) $(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''Result)