mcp 0.1.1.0 → 0.2.0.0

raw patch · 10 files changed

+1232/−348 lines, 10 filesdep +base64-bytestringdep +cryptonitedep +http-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, cryptonite, http-conduit, jose, memory, random, servant-auth, servant-auth-server, uuid

API changes (from Hackage documentation)

Files

• CHANGELOG.md +44/−0
• examples/http-server.hs +112/−44
• examples/test-mcp-server.sh +0/−62
• mcp.cabal +21/−4
• src/MCP/Protocol.hs +53/−78
• src/MCP/Server.hs +15/−17
• src/MCP/Server/Auth.hs +307/−0
• src/MCP/Server/HTTP.hs +643/−102
• src/MCP/Server/StdIO.hs +12/−14
• src/MCP/Types.hs +25/−27

@@ -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.

@@ -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:<port>/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:<port>/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

@@ -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

@@ -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

@@ -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

@@ -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-

@@ -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)

@@ -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)

@@ -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 ())

@@ -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)