mcp-server 0.1.0.20 → 0.1.0.21

raw patch · 19 files changed

+413/−261 lines, 19 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +35/−0
• README.md +40/−19
• examples/Complete/Main.hs +12/−12
• examples/HttpSimple/Main.hs +3/−3
• examples/Simple/Main.hs +3/−3
• mcp-server.cabal +3/−1
• src/MCP/Server/Derive.hs +11/−11
• src/MCP/Server/Handlers.hs +40/−36
• src/MCP/Server/Protocol.hs +19/−1
• src/MCP/Server/Transport/Http.hs +96/−37
• src/MCP/Server/Transport/Stdio.hs +1/−1
• src/MCP/Server/Types.hs +19/−7
• test/Spec/AdvancedDerivation.hs +7/−7
• test/Spec/BasicDerivation.hs +4/−4
• test/Spec/ProtocolVersionNegotiation.hs +79/−84
• test/Spec/SchemaValidation.hs +3/−3
• test/Spec/ToolCallParsing.hs +1/−1
• test/Spec/UnicodeHandling.hs +11/−9
• test/TestTypes.hs +26/−22

@@ -1,5 +1,40 @@ # Revision history for mcp-server +## 0.1.0.21 - ???++* **BREAKING**: every handler (prompt/resource/tool; list and get/read/call)+  now receives a `ClientContext` as its first argument, so a server can behave+  differently depending on who is calling. On stdio the context is anonymous;+  on HTTP it carries the request's bearer token and the principal returned by+  the authorization callback.+* **BREAKING**: `HttpConfig` gains an `httpAuthorize` field — an optional+  callback that validates the presented `Authorization: Bearer` token and+  returns an application-defined principal (`Nothing` rejects with 401). As it+  now holds a function, `HttpConfig` no longer derives `Show`/`Eq`.+* HTTP transport: accept requests without an `MCP-Protocol-Version` header+  (the spec says to assume `2025-03-26`), exempt `initialize` from the header+  check (it negotiates its version in the body), and keep rejecting a present+  but unsupported header with 400. Previously every request without the header+  was rejected, locking out pre-`2025-06-18` clients.+* `initialize` now advertises only the capabilities that actually have+  handlers, so strict clients no longer drop the server when e.g.+  `prompts/list` answers "not supported".+* CORS: preflight `OPTIONS` requests are exempt from authorization (browsers+  send no credentials on preflight) and `Authorization` is included in+  `Access-Control-Allow-Headers`.+* `http-simple-example` is now built with `-threaded`, which Warp requires;+  previously every request crashed with a `TimerManager` error.++## 0.1.0.20 - ???++* Fix protocol version negotiation: echo back any compatible revision the client+  proposes (`2024-11-05`, `2025-03-26`, `2025-06-18`, `2025-11-25`) instead of+  always responding with the server's own version. Fixes clients (e.g. Claude+  Code) that disconnect when they receive a different version than requested.+* Apply the same negotiation to the HTTP transport's `MCP-Protocol-Version`+  header check, which previously rejected anything other than `2025-06-18`.+* Default/fallback advertised version bumped to `2025-11-25`.+ ## 0.1.0.19 - ???  * Improve handler code generated by TemplateHaskell functions in `MCP.Server.Derive`:

@@ -4,11 +4,11 @@  ## Features -- **Complete MCP Implementation**: Supports MCP 2025-06-18 specification+- **Complete MCP Implementation**: Negotiates MCP protocol revisions `2024-11-05` through `2025-11-25` (the shared wire format for tool/resource/prompt operations) - **Type-Safe API**: Leverage Haskell's type system for robust MCP servers - **Multiple Abstractions**: Both low-level fine-grained control and high-level derived interfaces - **Template Haskell Support**: Automatic handler derivation from data types-- **Multiple Transports**: STDIO and HTTP Streaming transport (MCP 2025-06-18 Streamable HTTP)+- **Multiple Transports**: STDIO and HTTP Streaming transport (MCP Streamable HTTP)  ## Supported MCP Features @@ -41,18 +41,19 @@ data MyResource = Menu | Specials data MyTool = Search { query :: Text } | Order { item :: Text } --- Implement handlers-handlePrompt :: MyPrompt -> IO Content-handlePrompt (Recipe idea) = pure $ ContentText $ "Recipe for " <> idea-handlePrompt (Shopping items) = pure $ ContentText $ "Shopping list: " <> items+-- Implement handlers. Every handler receives the per-request 'ClientContext'+-- (the caller's bearer token and principal on the HTTP transport) first.+handlePrompt :: ClientContext -> MyPrompt -> IO Content+handlePrompt _ (Recipe idea) = pure $ ContentText $ "Recipe for " <> idea+handlePrompt _ (Shopping items) = pure $ ContentText $ "Shopping list: " <> items -handleResource :: MyResource -> IO Content-handleResource Menu = pure $ ContentText "Today's menu..."-handleResource Specials = pure $ ContentText "Daily specials..."+handleResource :: ClientContext -> URI -> MyResource -> IO ResourceContent+handleResource _ uri Menu = pure $ ResourceText uri "text/plain" "Today's menu..."+handleResource _ uri Specials = pure $ ResourceText uri "text/plain" "Daily specials..." -handleTool :: MyTool -> IO Content-handleTool (Search query) = pure $ ContentText $ "Search results for " <> query-handleTool (Order item) = pure $ ContentText $ "Ordered " <> item+handleTool :: ClientContext -> MyTool -> IO Content+handleTool _ (Search query) = pure $ ContentText $ "Search results for " <> query+handleTool _ (Order item) = pure $ ContentText $ "Ordered " <> item  -- Derive handlers automatically main :: IO ()@@ -163,9 +164,10 @@ ```haskell import MCP.Server --- Manual handler implementation-promptListHandler :: IO [PromptDefinition]-promptGetHandler :: PromptName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content)+-- Manual handler implementation. Every handler receives the per-request+-- 'ClientContext' as its first argument.+promptListHandler :: ClientContext -> IO [PromptDefinition]+promptGetHandler :: ClientContext -> PromptName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content) -- ... implement your custom logic  main :: IO ()@@ -180,7 +182,8 @@  ## HTTP Transport (NEW!) -The library now supports MCP 2025-06-18 Streamable HTTP transport:+The library supports the MCP Streamable HTTP transport. Compile your+executable with `ghc-options: -threaded` — Warp requires the threaded runtime:  ```haskell import MCP.Server.Transport.Http@@ -195,15 +198,33 @@       { httpPort = 8080       , httpHost = "0.0.0.0"       , httpEndpoint = "/api/mcp"-      , httpVerbose = True  -- Enable detailed logging+      , httpVerbose = True     -- Enable detailed logging+      , httpAuthorize = Nothing -- No authentication (see below)       } ``` +**Bearer-token authentication** (optional): supply an `httpAuthorize` callback+to validate the `Authorization: Bearer` token each request presents. Return+`Just principal` to authorize (the principal — any JSON `Value`, e.g. a role —+reaches your handlers as `clientPrincipal` in the `ClientContext`), or+`Nothing` to reject the request with 401. Token policy lives entirely in your+application; the library only threads the identity through:++```haskell+    customConfig = defaultHttpConfig+      { httpAuthorize = Just $ \mtoken -> case mtoken of+          Just "secret-admin-token" -> pure $ Just (String "admin")+          Just "secret-user-token"  -> pure $ Just (String "user")+          _                         -> pure Nothing+      }+```+ **Features:** - CORS enabled for web clients - GET `/mcp` for server discovery - POST `/mcp` for JSON-RPC messages-- Full MCP 2025-06-18 compliance+- Protocol-version negotiation across supported revisions (`2024-11-05`–`2025-11-25`)+- Optional pluggable bearer-token authentication via `httpAuthorize`  ## Examples @@ -245,7 +266,7 @@  ## Documentation -- [MCP Specification](https://modelcontextprotocol.io/specification/2025-06-18/)+- [MCP Specification](https://modelcontextprotocol.io/specification/2025-11-25/) - [API Documentation](https://hackage.haskell.org/package/mcp-server) - [Examples](examples/) 

@@ -10,28 +10,28 @@  -- High-level handler functions -handlePrompt :: MyPrompt -> IO Content-handlePrompt (Recipe idea) =+handlePrompt :: ClientContext -> MyPrompt -> IO Content+handlePrompt _ (Recipe idea) =     pure $ ContentText $ "Recipe prompt for " <> idea <> ": Start by gathering fresh ingredients..."-handlePrompt (Shopping description) =+handlePrompt _ (Shopping description) =     pure $ ContentText $ "Shopping prompt for " <> description <> ": Create a detailed shopping list..." -handleResource :: URI -> MyResource -> IO ResourceContent-handleResource uri ProductCategories =+handleResource :: ClientContext -> URI -> MyResource -> IO ResourceContent+handleResource _ uri ProductCategories =     pure $ ResourceText uri "text/plain" "Fresh Produce, Dairy, Bakery, Meat & Seafood, Frozen Foods"-handleResource uri SaleItems =+handleResource _ uri SaleItems =     pure $ ResourceText uri "text/plain" "Organic Apples $2.99/lb, Free Range Eggs $4.50/dozen, Artisan Bread $3.25/loaf"-handleResource uri HeadlineBannerAd =+handleResource _ uri HeadlineBannerAd =     pure $ ResourceText uri "text/plain" "🛒 Weekly Special: 20% off all organic produce! 🥕🥬🍎" -handleTool :: MyTool -> IO Content-handleTool (SearchForProduct q category) =+handleTool :: ClientContext -> MyTool -> IO Content+handleTool _ (SearchForProduct q category) =     case category of         Nothing -> pure $ ContentText $ "Search results for '" <> q <> "': Found 15 products across all categories"         Just cat -> pure $ ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products"-handleTool (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items"-handleTool Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!"-handleTool (ComplexTool field1 field2 field3 field4 field5) =+handleTool _ (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items"+handleTool _ Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!"+handleTool _ (ComplexTool field1 field2 field3 field4 field5) =     pure $ ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <>                         maybe "" (", " <>) field3 <> ", " <> field4 <>                         maybe "" (", " <>) field5

@@ -16,13 +16,13 @@     -- Create a simple in-memory store     store <- newIORef [] -    let handleTool :: SimpleTool -> IO Content-        handleTool (GetValue k) = do+    let handleTool :: ClientContext -> SimpleTool -> IO Content+        handleTool _ (GetValue k) = do             pairs <- readIORef store             case lookup k pairs of                 Nothing -> pure $ ContentText $ "Key '" <> k <> "' not found"                 Just v  -> pure $ ContentText v-        handleTool (SetValue k v) = do+        handleTool _ (SetValue k v) = do             pairs <- readIORef store             let newPairs = (k, v) : filter ((/= k) . fst) pairs             writeIORef store newPairs

@@ -16,13 +16,13 @@     -- Create a simple in-memory store     store <- newIORef [] -    let handleTool :: SimpleTool -> IO Content-        handleTool (GetValue k) = do+    let handleTool :: ClientContext -> SimpleTool -> IO Content+        handleTool _ (GetValue k) = do             pairs <- readIORef store             case lookup k pairs of                 Nothing -> pure $ ContentText $ "Key '" <> k <> "' not found"                 Just v  -> pure $ ContentText v-        handleTool (SetValue k v) = do+        handleTool _ (SetValue k v) = do             pairs <- readIORef store             let newPairs = (k, v) : filter ((/= k) . fst) pairs             writeIORef store newPairs

@@ -15,7 +15,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.1.0.20+version: 0.1.0.21 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.@@ -156,6 +156,8 @@    -- Directories containing source files.   hs-source-dirs: examples/HttpSimple+  -- Warp requires the threaded RTS (its timeout manager needs it).+  ghc-options: -threaded   -- Base language which the package is written in.   default-language: GHC2021 

@@ -106,13 +106,13 @@       promptDefs <- traverse (mkPromptDefWithDescription descriptions) constructors        -- Generate list handler-      listHandlerExp <- [| pure $(return $ ListE promptDefs) |]+      listHandlerExp <- [| \_ctx -> pure $(return $ ListE promptDefs) |]        -- Generate get handler with cases       cases <- traverse (mkDispatchCase handlerName) constructors       defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |]       let defaultMatch = Match WildP (NormalB defaultCase) []-      let getHandlerExp = LamE [VarP (mkName "name"), VarP (mkName "args")] $+      let getHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "name"), VarP (mkName "args")] $             CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name")))               (map clauseToMatch cases ++ [defaultMatch]) @@ -182,7 +182,7 @@   body <- case con of     NormalC _ [] ->       [| do-          content <- $(varE handlerName) $(conE name)+          content <- $(varE handlerName) $(varE (mkName "ctx")) $(conE name)           pure $ Right content |]     RecC _ fields ->       mkRecordCase name handlerName fields@@ -203,7 +203,7 @@         paramConstructorApp <- buildParameterConstructor paramType fieldVars         let outerConstructorApp = AppE (ConE outerConName) paramConstructorApp         [| do-            content <- $(varE handlerName) $(return outerConstructorApp)+            content <- $(varE handlerName) $(varE (mkName "ctx")) $(return outerConstructorApp)             pure $ Right content |]   inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0   [| let $(varP argMapName) = Map.fromList args in $(return inner) |]@@ -212,14 +212,14 @@ mkRecordCase recConName handlerName fields = do   case fields of     [] -> [| do-        content <- $(varE handlerName) $(conE recConName)+        content <- $(varE handlerName) $(varE (mkName "ctx")) $(conE recConName)         pure $ Right content |]     _ -> do       let argMapName = mkName "argMap"       let mkBaseExp fieldVars = do             let constructorApp = foldl AppE (ConE recConName) (map VarE fieldVars)             [| do-                content <- $(varE handlerName) $(return constructorApp)+                content <- $(varE handlerName) $(varE (mkName "ctx")) $(return constructorApp)                 pure $ Right content |]       inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0       [| let $(varP argMapName) = Map.fromList args in $(return inner) |]@@ -316,14 +316,14 @@     TyConI (DataD _ _ _ _ constructors _) -> do       -- Generate resource definitions       resourceDefs <- traverse (mkResourceDefWithDescription descriptions) constructors-      listHandlerExp <- [| pure $(return $ ListE resourceDefs) |]+      listHandlerExp <- [| \_ctx -> pure $(return $ ListE resourceDefs) |]        -- Generate read handler with cases       cases <- traverse (mkResourceCase handlerName) constructors       defaultCase <- [| pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |]       let defaultMatch = Match (VarP (mkName "unknown")) (NormalB defaultCase) [] -      let readHandlerExp = LamE [VarP (mkName "uri")] $+      let readHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "uri")] $             CaseE (AppE (VarE 'show) (VarE (mkName "uri")))               (map clauseToMatch cases ++ [defaultMatch]) @@ -363,7 +363,7 @@   let resourceName = T.pack . snakeName $ name   let resourceURI = "resource://" <> T.unpack resourceName   clause [litP $ stringL resourceURI]-    (normalB [| Right <$> $(varE handlerName) $(varE (mkName "uri")) $(conE name) |])+    (normalB [| Right <$> $(varE handlerName) $(varE (mkName "ctx")) $(varE (mkName "uri")) $(conE name) |])     [] mkResourceCase _ _ = fail "Unsupported constructor type for resources" @@ -383,13 +383,13 @@       -- Generate tool definitions       toolDefs <- traverse (mkToolDefWithDescription descriptions) constructors -      listHandlerExp <- [| pure $(return $ ListE toolDefs) |]+      listHandlerExp <- [| \_ctx -> pure $(return $ ListE toolDefs) |]        -- Generate call handler with cases       cases <- traverse (mkDispatchCase handlerName) constructors       defaultCase <- [| pure $ Left $ UnknownTool $ "Unknown tool: " <> name |]       let defaultMatch = Match WildP (NormalB defaultCase) []-      let callHandlerExp = LamE [VarP (mkName "name"), VarP (mkName "args")] $+      let callHandlerExp = LamE [VarP (mkName "ctx"), VarP (mkName "name"), VarP (mkName "args")] $             CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name")))               (map clauseToMatch cases ++ [defaultMatch]) 

@@ -64,25 +64,26 @@ -- with another protocol version it supports." validateProtocolVersion :: Text -> Either Text Text validateProtocolVersion clientVersion-  | clientVersion == protocolVersion = Right protocolVersion  -- Exact match-  | otherwise = Right protocolVersion  -- Negotiate: return server's supported version+  | clientVersion `elem` supportedVersions = Right clientVersion  -- Supported: echo the client's own version+  | otherwise = Right protocolVersion  -- Unknown: negotiate down to the server's default version  -- | Handle an MCP message and return a response if needed handleMcpMessage :: (MonadIO m)                  => McpServerInfo                  -> McpServerHandlers m+                 -> ClientContext                  -> JsonRpcMessage                  -> m (Maybe JsonRpcMessage)-handleMcpMessage serverInfo handlers (JsonRpcMessageRequest req) = do+handleMcpMessage serverInfo handlers ctx (JsonRpcMessageRequest req) = do   response <- case requestMethod req of-    "initialize" -> handleInitialize serverInfo req+    "initialize" -> handleInitialize serverInfo handlers req     "ping" -> handlePing req-    "prompts/list" -> handlePromptsList handlers req-    "prompts/get" -> handlePromptsGet handlers req-    "resources/list" -> handleResourcesList handlers req-    "resources/read" -> handleResourcesRead handlers req-    "tools/list" -> handleToolsList handlers req-    "tools/call" -> handleToolsCall handlers req+    "prompts/list" -> handlePromptsList handlers ctx req+    "prompts/get" -> handlePromptsGet handlers ctx req+    "resources/list" -> handleResourcesList handlers ctx req+    "resources/read" -> handleResourcesRead handlers ctx req+    "tools/list" -> handleToolsList handlers ctx req+    "tools/call" -> handleToolsCall handlers ctx req     method -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601       , errorMessage = "Method not found: " <> method@@ -90,7 +91,7 @@       }   return $ Just $ JsonRpcMessageResponse response -handleMcpMessage _ _ (JsonRpcMessageNotification notif) = do+handleMcpMessage _ _ _ (JsonRpcMessageNotification notif) = do   case notificationMethod notif of     "notifications/initialized" -> do       liftIO $ hPutStrLn stderr "Received initialized notification - server is ready for operation"@@ -100,12 +101,12 @@       return ()   return Nothing -handleMcpMessage _ _ (JsonRpcMessageResponse _) =+handleMcpMessage _ _ _ (JsonRpcMessageResponse _) =   return Nothing  -- | Handle initialize request-handleInitialize :: (MonadIO m) => McpServerInfo -> JsonRpcRequest -> m JsonRpcResponse-handleInitialize serverInfo req = do+handleInitialize :: (MonadIO m) => McpServerInfo -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleInitialize serverInfo handlers req = do   case requestParams req of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32602@@ -130,11 +131,14 @@               }             Right negotiatedVersion -> do               liftIO $ hPutStrLn stderr $ "Client version: " ++ T.unpack clientVersion ++ ", using: " ++ T.unpack negotiatedVersion+              -- Only advertise a capability that actually has a handler.+              -- Advertising e.g. "prompts" while prompts/list returns an error+              -- makes strict clients (e.g. Crush) drop the whole server.               let capabilities = ServerCapabilities-                    { capabilityPrompts = Just $ PromptCapabilities { promptListChanged = Nothing }-                    , capabilityResources = Just $ ResourceCapabilities { resourceSubscribe = Nothing, resourceListChanged = Nothing }-                    , capabilityTools = Just $ ToolCapabilities { toolListChanged = Nothing }-                    , capabilityLogging = Nothing  -- Not supported yet+                    { capabilityPrompts   = PromptCapabilities { promptListChanged = Nothing } <$ prompts handlers+                    , capabilityResources = ResourceCapabilities { resourceSubscribe = Nothing, resourceListChanged = Nothing } <$ resources handlers+                    , capabilityTools     = ToolCapabilities { toolListChanged = Nothing } <$ tools handlers+                    , capabilityLogging   = Nothing  -- Not supported yet                     }               let response = InitializeResponse                     { initRespProtocolVersion = negotiatedVersion@@ -148,8 +152,8 @@ handlePing req = return $ makeSuccessResponse (requestId req) (toJSON PongResponse)  -- | Handle prompts/list request-handlePromptsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handlePromptsList handlers req =+handlePromptsList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handlePromptsList handlers ctx req =   case prompts handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -157,15 +161,15 @@       , errorData = Nothing       }     Just (listHandler, _) -> do-      promptsList <- listHandler+      promptsList <- listHandler ctx       let response = PromptsListResponse             { promptsListPrompts = promptsList             }       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle prompts/get request-handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handlePromptsGet handlers req =+handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handlePromptsGet handlers ctx req =   case prompts handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -188,7 +192,7 @@               }             Success getReq -> do               let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (promptsGetArguments getReq)-              result <- getHandler (promptsGetName getReq) args+              result <- getHandler ctx (promptsGetName getReq) args               case result of                 Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError                   { errorCode = errorCodeFromMcpError err@@ -204,8 +208,8 @@                   return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle resources/list request-handleResourcesList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleResourcesList handlers req =+handleResourcesList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handleResourcesList handlers ctx req =   case resources handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -213,15 +217,15 @@       , errorData = Nothing       }     Just (listHandler, _) -> do-      resourcesList <- listHandler+      resourcesList <- listHandler ctx       let response = ResourcesListResponse             { resourcesListResources = resourcesList             }       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle resources/read request-handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleResourcesRead handlers req =+handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handleResourcesRead handlers ctx req =   case resources handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -243,7 +247,7 @@               , errorData = Nothing               }             Success readReq -> do-              result <- readHandler (resourcesReadUri readReq)+              result <- readHandler ctx (resourcesReadUri readReq)               case result of                 Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError                   { errorCode = errorCodeFromMcpError err@@ -257,8 +261,8 @@                   return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle tools/list request-handleToolsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleToolsList handlers req =+handleToolsList :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handleToolsList handlers ctx req =   case tools handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -266,15 +270,15 @@       , errorData = Nothing       }     Just (listHandler, _) -> do-      toolsList <- listHandler+      toolsList <- listHandler ctx       let response = ToolsListResponse             { toolsListTools = toolsList             }       return $ makeSuccessResponse (requestId req) (toJSON response)  -- | Handle tools/call request-handleToolsCall :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleToolsCall handlers req =+handleToolsCall :: (MonadIO m) => McpServerHandlers m -> ClientContext -> JsonRpcRequest -> m JsonRpcResponse+handleToolsCall handlers ctx req =   case tools handlers of     Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError       { errorCode = -32601@@ -297,7 +301,7 @@               }             Success callReq -> do               let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (toolsCallArguments callReq)-              result <- callHandler (toolsCallName callReq) args+              result <- callHandler ctx (toolsCallName callReq) args               case result of                 Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError                   { errorCode = errorCodeFromMcpError err

@@ -34,6 +34,7 @@      -- * Protocol Functions   , protocolVersion+  , supportedVersions   ) where  import           Data.Aeson@@ -42,8 +43,25 @@ import           GHC.Generics     (Generic) import           MCP.Server.Types +-- | The protocol revision the server advertises by default. Used as the+-- fallback when a client proposes a version this library does not recognise. protocolVersion :: Text-protocolVersion = "2025-06-18"+protocolVersion = "2025-11-25"++-- | Date-versioned MCP revisions whose wire format for the basic+-- tool/resource/prompt operations this library implements is identical.+-- The server echoes back any of these a client proposes (see+-- 'MCP.Server.Handlers.validateProtocolVersion'), satisfying the spec+-- requirement that a supported version be answered with the same version.+--+-- Ordered newest-first.+supportedVersions :: [Text]+supportedVersions =+  [ "2025-11-25"+  , "2025-06-18"+  , "2025-03-26"+  , "2024-11-05"+  ]   -- | Initialize request

@@ -10,11 +10,13 @@  import           Control.Monad            (when) import           Data.Aeson+import qualified Data.Aeson.KeyMap        as KM import qualified Data.ByteString.Lazy     as BSL import           Data.String              (IsString (fromString)) import           Data.Text                (Text) import qualified Data.Text                as T import qualified Data.Text.Encoding       as TE+import           Data.Text.Encoding.Error (lenientDecode) import           Network.HTTP.Types import qualified Network.Wai              as Wai import qualified Network.Wai.Handler.Warp as Warp@@ -22,23 +24,37 @@  import           MCP.Server.Handlers import           MCP.Server.JsonRpc+import           MCP.Server.Protocol (protocolVersion, supportedVersions) import           MCP.Server.Types --- | HTTP transport configuration following MCP 2025-06-18 Streamable HTTP specification+-- | HTTP transport configuration following the MCP Streamable HTTP specification+--+-- Note: 'HttpConfig' has no 'Show'/'Eq' instances because 'httpAuthorize' is a+-- function. data HttpConfig = HttpConfig-  { httpPort     :: Int      -- ^ Port to listen on-  , httpHost     :: String   -- ^ Host to bind to (default "localhost")-  , httpEndpoint :: String   -- ^ MCP endpoint path (default "/mcp")-  , httpVerbose  :: Bool     -- ^ Enable verbose logging (default False)-  } deriving (Show, Eq)+  { httpPort      :: Int      -- ^ Port to listen on+  , httpHost      :: String   -- ^ Host to bind to (default "localhost")+  , httpEndpoint  :: String   -- ^ MCP endpoint path (default "/mcp")+  , httpVerbose   :: Bool     -- ^ Enable verbose logging (default False)+  , httpAuthorize :: Maybe (Maybe Text -> IO (Maybe Value))+      -- ^ Optional authorization callback. 'Nothing' disables authentication.+      --   When @'Just' check@, the bearer token presented by each request (or+      --   'Nothing' when absent / not a Bearer credential) is passed to+      --   @check@, which returns the caller's principal: @'Just' principal@+      --   authorizes the request — the principal (e.g. a role) is placed in the+      --   handler 'ClientContext' as 'clientPrincipal' — while 'Nothing' rejects+      --   the request with @401@. Validation and principal assignment are left+      --   entirely to the caller.+  } --- | Default HTTP configuration+-- | Default HTTP configuration (authentication disabled). defaultHttpConfig :: HttpConfig defaultHttpConfig = HttpConfig   { httpPort = 3000   , httpHost = "localhost"   , httpEndpoint = "/mcp"   , httpVerbose = False+  , httpAuthorize = Nothing   }  -- | Helper for conditional logging@@ -62,30 +78,58 @@   -- Log the request   logVerbose config $ "HTTP " ++ show (Wai.requestMethod req) ++ " " ++ T.unpack (TE.decodeUtf8 $ Wai.rawPathInfo req) -  -- Check if this is our MCP endpoint-  if TE.decodeUtf8 (Wai.rawPathInfo req) == T.pack (httpEndpoint config)-    then handleMcpRequest config serverInfo handlers req respond-    else respond $ Wai.responseLBS status404 [("Content-Type", "text/plain")] "Not Found"+  -- Authenticate and obtain the caller's principal (if any) before anything+  -- else. CORS preflight requests are exempt: browsers never attach+  -- credentials to an OPTIONS preflight, and the preflight response is what+  -- tells the browser it may send the Authorization header at all.+  decision <- case httpAuthorize config of+    _ | Wai.requestMethod req == "OPTIONS"+               -> pure (Just Nothing)      -- CORS preflight: no credentials+    Nothing    -> pure (Just Nothing)      -- auth disabled: allowed, no principal+    Just check -> fmap (fmap Just) (check (bearerToken req))+  case decision of+    Nothing -> do+      logVerbose config "Request rejected by authorization callback"+      respond $ Wai.responseLBS+        status401+        [("Content-Type", "application/json"), ("WWW-Authenticate", "Bearer")]+        (encode $ object ["error" .= ("Unauthorized" :: Text)])+    Just principal -> do+      let ctx = ClientContext { clientToken = bearerToken req, clientPrincipal = principal }+      -- Check if this is our MCP endpoint+      if TE.decodeUtf8 (Wai.rawPathInfo req) == T.pack (httpEndpoint config)+        then handleMcpRequest config serverInfo handlers ctx req respond+        else respond $ Wai.responseLBS status404 [("Content-Type", "text/plain")] "Not Found" +-- | The bearer token presented by a request, if any: the value following+-- @Authorization: Bearer @. The scheme is matched case-insensitively per+-- RFC 7235, and invalid UTF-8 in the header is replaced rather than thrown.+bearerToken :: Wai.Request -> Maybe Text+bearerToken req = do+  header <- lookup hAuthorization (Wai.requestHeaders req)+  let (scheme, rest) = T.break (== ' ') (TE.decodeUtf8With lenientDecode header)+  if T.toCaseFold scheme == "bearer" && not (T.null rest)+    then Just (T.stripStart rest)+    else Nothing+ -- | Handle MCP requests according to Streamable HTTP specification-handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleMcpRequest config serverInfo handlers req respond = do-  -- Check for mandatory MCP-Protocol-Version header (2025-06-18 requirement)-  case lookup "MCP-Protocol-Version" (Wai.requestHeaders req) of-    Nothing -> do-      logVerbose config "Request rejected: Missing MCP-Protocol-Version header"+handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleMcpRequest config serverInfo handlers ctx req respond = do+  -- Read the POST body up front so we can identify the `initialize` request:+  -- it negotiates the protocol version in its *body*, so (per the Streamable+  -- HTTP spec, which scopes the MCP-Protocol-Version header to "subsequent+  -- requests") it is exempt from the header check. For any other request a+  -- *missing* header is accepted, while a *present but unsupported* one is+  -- rejected with 400.+  body <- if Wai.requestMethod req == "POST" then Wai.strictRequestBody req else pure ""+  if extractMethod body /= Just "initialize" && not (versionHeaderSupported req)+    then do+      logVerbose config "Request rejected: unsupported MCP-Protocol-Version header"       respond $ Wai.responseLBS         status400         [("Content-Type", "application/json")]-        (encode $ object ["error" .= ("Missing required MCP-Protocol-Version header" :: Text)])-    Just headerValue ->-      if TE.decodeUtf8 headerValue /= "2025-06-18" then do-        logVerbose config $ "Request rejected: Invalid protocol version: " ++ show headerValue-        respond $ Wai.responseLBS-          status400-          [("Content-Type", "application/json")]-          (encode $ object ["error" .= ("Unsupported protocol version. Server only supports 2025-06-18" :: Text)])-      else+        (encode $ object ["error" .= ("Unsupported protocol version. Supported versions: " <> T.intercalate ", " supportedVersions)])+    else         case Wai.requestMethod req of           -- GET requests for endpoint discovery           "GET" -> do@@ -93,7 +137,7 @@                   [ "name" .= serverName serverInfo                   , "version" .= serverVersion serverInfo                   , "description" .= serverInstructions serverInfo-                  , "protocolVersion" .= ("2025-06-18" :: Text)+                  , "protocolVersion" .= protocolVersion                   , "capabilities" .= object                       [ "tools" .= object []                       , "prompts" .= object []@@ -108,17 +152,15 @@            -- POST requests for JSON-RPC messages           "POST" -> do-            -- Read request body-            body <- Wai.strictRequestBody req             logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body)-            handleJsonRpcRequest config serverInfo handlers body respond+            handleJsonRpcRequest config serverInfo handlers ctx body respond            -- OPTIONS for CORS preflight           "OPTIONS" -> respond $ Wai.responseLBS             status200             [ ("Access-Control-Allow-Origin", "*")             , ("Access-Control-Allow-Methods", "GET, POST, OPTIONS")-            , ("Access-Control-Allow-Headers", "Content-Type, MCP-Protocol-Version")+            , ("Access-Control-Allow-Headers", "Content-Type, Authorization, MCP-Protocol-Version")             ]             "" @@ -128,9 +170,26 @@             [("Content-Type", "text/plain"), ("Allow", "GET, POST, OPTIONS")]             "Method Not Allowed" +-- | True unless the request carries a *present but unsupported*+-- MCP-Protocol-Version header. A missing header is treated as acceptable, since+-- the spec allows the server to assume a default protocol version in that case.+versionHeaderSupported :: Wai.Request -> Bool+versionHeaderSupported req =+  case lookup "MCP-Protocol-Version" (Wai.requestHeaders req) of+    Nothing -> True+    Just hv -> TE.decodeUtf8 hv `elem` supportedVersions++-- | Peek at a JSON-RPC message body to read its @method@ (if present).+extractMethod :: BSL.ByteString -> Maybe Text+extractMethod body = case decode body of+  Just (Object o) -> case KM.lookup "method" o of+    Just (String m) -> Just m+    _               -> Nothing+  _ -> Nothing+ -- | Handle JSON-RPC request from HTTP body-handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleJsonRpcRequest config serverInfo handlers body respond = do+handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleJsonRpcRequest config serverInfo handlers ctx body respond = do   case eitherDecode body of     Left err -> do       hPutStrLn stderr $ "JSON parse error: " ++ err@@ -139,11 +198,11 @@         [("Content-Type", "application/json")]         (encode $ object ["error" .= ("Invalid JSON" :: Text)]) -    Right jsonValue -> handleSingleJsonRpc config serverInfo handlers jsonValue respond+    Right jsonValue -> handleSingleJsonRpc config serverInfo handlers ctx jsonValue respond  -- | Handle a single JSON-RPC message-handleSingleJsonRpc :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleSingleJsonRpc config serverInfo handlers jsonValue respond = do+handleSingleJsonRpc :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> ClientContext -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleSingleJsonRpc config serverInfo handlers ctx jsonValue respond = do   case parseJsonRpcMessage jsonValue of     Left err -> do       hPutStrLn stderr $ "JSON-RPC parse error: " ++ err@@ -154,7 +213,7 @@      Right message -> do       logVerbose config $ "Processing HTTP message: " ++ show (getMessageSummary message)-      maybeResponse <- handleMcpMessage serverInfo handlers message+      maybeResponse <- handleMcpMessage serverInfo handlers ctx message        case maybeResponse of         Just responseMsg -> do

@@ -43,7 +43,7 @@               Left err -> liftIO $ TIO.hPutStrLn stderr $ "JSON-RPC parse error: " <> T.pack err               Right message -> do                 liftIO $ TIO.hPutStrLn stderr $ "Processing message: " <> T.pack (show (getMessageSummary message))-                response <- handleMcpMessage serverInfo handlers message+                response <- handleMcpMessage serverInfo handlers (ClientContext Nothing Nothing) message                 case response of                   Just responseMsg -> do                     liftIO $ TIO.hPutStrLn stderr $ "Sending response for: " <> T.pack (show (getMessageSummary message))

@@ -26,6 +26,7 @@     -- * Server Types   , McpServerInfo(..)   , McpServerHandlers(..)+  , ClientContext(..)   , ServerCapabilities(..)   , PromptCapabilities(..)   , ResourceCapabilities(..)@@ -338,15 +339,26 @@     ]  --- | Handler type definitions-type PromptListHandler m = m [PromptDefinition]-type PromptGetHandler m = PromptName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)+-- | Per-request context passed to every handler, so handlers can behave+-- differently depending on who is calling.+data ClientContext = ClientContext+  { clientToken     :: Maybe Text   -- ^ Authenticated bearer token, if any.+  , clientPrincipal :: Maybe Value  -- ^ Application-defined principal returned by+                                    --   the transport's authorization callback+                                    --   (e.g. a role). 'Nothing' when+                                    --   authentication is disabled.+  } deriving (Show, Eq) -type ResourceListHandler m = m [ResourceDefinition]-type ResourceReadHandler m = URI -> m (Either Error ResourceContent)+-- | Handler type definitions. Every handler receives the request's+-- 'ClientContext' as its first argument.+type PromptListHandler m = ClientContext -> m [PromptDefinition]+type PromptGetHandler m = ClientContext -> PromptName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content) -type ToolListHandler m = m [ToolDefinition]-type ToolCallHandler m = ToolName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)+type ResourceListHandler m = ClientContext -> m [ResourceDefinition]+type ResourceReadHandler m = ClientContext -> URI -> m (Either Error ResourceContent)++type ToolListHandler m = ClientContext -> m [ToolDefinition]+type ToolCallHandler m = ClientContext -> ToolName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)  -- | Server handlers data McpServerHandlers m = McpServerHandlers

@@ -42,7 +42,7 @@  assertToolCallResult :: (ToolCallHandler IO) -> Text -> [(Text, Text)] -> Text -> IO () assertToolCallResult handler toolName args expectedContent = do-  result <- handler toolName args+  result <- handler anonCtx toolName args   case result of     Right (ContentText content) -> content `shouldBe` expectedContent     other -> expectationFailure $ "Expected ContentText but got: " ++ show other@@ -66,7 +66,7 @@   describe "Separate Parameter Types" $ do     it "generates correct schema for separate parameter tools" $ do       let (listHandler, _) = testSeparateParamsToolHandlers-      toolDefs <- listHandler+      toolDefs <- listHandler anonCtx        -- Test GetValue tool schema       let getValueDef = findToolByName "get_value" toolDefs@@ -84,7 +84,7 @@   describe "Recursive Parameter Types" $ do     it "generates correct schema for recursive parameter tools" $ do       let (listHandler, _) = testRecursiveToolHandlers-      toolDefs <- listHandler+      toolDefs <- listHandler anonCtx        let processDataDef = findToolByName "process_data" toolDefs       assertSchemaHasProperties ["_ipName", "_ipAge"] processDataDef@@ -97,7 +97,7 @@   describe "Custom Descriptions with Separate Parameters" $ do     it "applies correct tool descriptions for separate parameter tools" $ do       let (listHandler, _) = testSeparateParamsToolHandlersWithDescriptions-      toolDefs <- listHandler+      toolDefs <- listHandler anonCtx        let getValueDef = findToolByName "get_value" toolDefs       assertToolHasDescription "get_value" "Retrieves a value from the key-value store" getValueDef@@ -107,7 +107,7 @@      it "applies correct field descriptions for separate parameter tools" $ do       let (listHandler, _) = testSeparateParamsToolHandlersWithDescriptions-      toolDefs <- listHandler+      toolDefs <- listHandler anonCtx        let getValueDef = findToolByName "get_value" toolDefs       assertPropertyHasDescription "_gvpKey" "The key to retrieve the value for" getValueDef@@ -119,14 +119,14 @@   describe "Recursive Tool Descriptions" $ do     it "applies correct descriptions for recursive parameter tools" $ do       let (listHandler, _) = testRecursiveToolHandlersWithDescriptions-      toolDefs <- listHandler+      toolDefs <- listHandler anonCtx        let processDataDef = findToolByName "process_data" toolDefs       assertToolHasDescription "process_data" "Processes user data with age validation" processDataDef      it "applies correct field descriptions for recursive parameters" $ do       let (listHandler, _) = testRecursiveToolHandlersWithDescriptions-      toolDefs <- listHandler+      toolDefs <- listHandler anonCtx        let processDataDef = findToolByName "process_data" toolDefs       assertPropertyHasDescription "_ipName" "The person's full name" processDataDef

@@ -40,13 +40,13 @@  testPromptCall :: PromptGetHandler IO -> Text -> [(Text, Text)] -> Text -> IO () testPromptCall handler name args expected =-  shouldReturnContentText (handler name args) expected+  shouldReturnContentText (handler anonCtx name args) expected  testResourceCall :: ResourceReadHandler IO -> String -> Text -> IO () testResourceCall handler uriString expected = do   case parseURI uriString of     Just uri -> do-      result <- handler uri+      result <- handler anonCtx uri       case result of         Right (ResourceText _ _ content) -> content `shouldBe` expected         Right (ResourceBlob _ _ _) -> expectationFailure "Expected ResourceText but got ResourceBlob"@@ -55,7 +55,7 @@  testToolCall :: ToolCallHandler IO -> Text -> [(Text, Text)] -> Text -> IO () testToolCall handler name args expected =-  shouldReturnContentText (handler name args) expected+  shouldReturnContentText (handler anonCtx name args) expected  spec :: Spec spec = describe "Basic Template Haskell Derivation" $ do@@ -76,7 +76,7 @@           Just uri ->             if useSubstringMatch testCase               then do-                result <- readHandler uri+                result <- readHandler anonCtx uri                 case result of                   Right (ResourceText _ _ content) ->                     T.isInfixOf (resourceExpectedContent testCase) content `shouldBe` True

@@ -4,30 +4,25 @@  import Data.Aeson (Value(..), object, (.=)) import qualified Data.Aeson.KeyMap as KM+import Data.Text (Text) import Test.Hspec  import MCP.Server.Handlers (handleInitialize) import MCP.Server.JsonRpc (JsonRpcRequest(..), RequestId(..), JsonRpcResponse(..), JsonRpcError(..))-import MCP.Server.Types (McpServerInfo(..))+import MCP.Server.Protocol (protocolVersion)+import MCP.Server.Types (Error(..), McpServerHandlers(..), McpServerInfo(..)) --- | Test that server performs proper version negotiation according to MCP spec+-- | Test that server performs proper version negotiation according to MCP spec. -- -- From the spec: "If the server supports the requested protocol version, -- it MUST respond with the same version. Otherwise, the server MUST respond -- with another protocol version it supports." ----- This means if a client sends protocolVersion "2025-11-25" and the server--- only supports "2025-06-18", the server should respond with:--- {---   "jsonrpc": "2.0",---   "id": 0,---   "result": {---     "protocolVersion": "2025-06-18",---     ...---   }--- }------ NOT with an error like: {"jsonrpc":"2.0","id":0,"error":{"code":-32602,...}}+-- The wire format for the basic tool/resource/prompt operations this library+-- implements is unchanged across the date-versioned revisions 2024-11-05,+-- 2025-03-26, 2025-06-18 and 2025-11-25, so the server echoes back any of+-- these the client proposes. Unknown versions fall back to the server's own+-- 'protocolVersion'. spec :: Spec spec = describe "Protocol Version Negotiation" $ do   let testServerInfo = McpServerInfo@@ -36,79 +31,79 @@         , serverInstructions = "Test server for version negotiation"         } -  it "Server should respond with supported version when client requests unsupported version" $ do-    -- Create an initialize request with a newer protocol version-    -- that the library doesn't support-    let params = object-          [ "protocolVersion" .= String "2025-11-25"  -- Newer than library supports-          , "capabilities" .= object []-          , "clientInfo" .= object-              [ "name" .= String "test-client"-              , "version" .= String "1.0.0"+  -- A server that only provides tools: capabilities in the initialize+  -- response should reflect exactly this.+  let testHandlers = McpServerHandlers+        { prompts = Nothing+        , resources = Nothing+        , tools = Just ( \_ctx -> pure []+                       , \_ctx name _args -> pure (Left (UnknownTool name))+                       )+        }++  let initialize :: Text -> IO JsonRpcResponse+      initialize clientVersion = do+        let params = object+              [ "protocolVersion" .= String clientVersion+              , "capabilities" .= object []+              , "clientInfo" .= object+                  [ "name" .= String "test-client"+                  , "version" .= String "1.0.0"+                  ]               ]-          ]-        request = JsonRpcRequest-          { requestJsonrpc = "2.0"-          , requestId = RequestIdNumber 0-          , requestMethod = "initialize"-          , requestParams = Just params-          }+            request = JsonRpcRequest+              { requestJsonrpc = "2.0"+              , requestId = RequestIdNumber 0+              , requestMethod = "initialize"+              , requestParams = Just params+              }+        handleInitialize testServerInfo testHandlers request -    -- Call handleInitialize directly (it runs in IO monad)-    response <- handleInitialize testServerInfo request+  -- Issue an initialize request proposing the given protocol version and+  -- return the negotiated version from the server's (non-error) response.+  let negotiate :: Text -> IO Text+      negotiate clientVersion = do+        response <- initialize clientVersion+        case responseError response of+          Just err ->+            error $ "Server returned error instead of negotiating version. "+                 ++ "Per MCP spec, server MUST respond with a supported version, "+                 ++ "not an error. Error was: " ++ show (errorMessage err)+          Nothing -> case responseResult response of+            Nothing -> error "Response has no result"+            Just (Object result) -> case KM.lookup "protocolVersion" result of+              Just (String version) -> pure version+              Just other -> error $ "protocolVersion is not a string: " ++ show other+              Nothing -> error "Response missing protocolVersion"+            Just other -> error $ "Result is not an object: " ++ show other -    -- Check if it's an error response-    case responseError response of-      Just err -> do-        -- This is the bug! Server returned an error instead of negotiating-        expectationFailure $-          "Server returned error instead of negotiating version. " ++-          "Per MCP spec, server MUST respond with a supported version, " ++-          "not an error. Error was: " ++ show (errorMessage err)-      Nothing -> do-        -- Good! Now verify the result has protocolVersion-        case responseResult response of-          Nothing -> expectationFailure "Response has no result"-          Just (Object result) -> do-            case KM.lookup "protocolVersion" result of-              Just (String version) -> do-                -- The server should have responded with its supported version-                -- We expect "2025-06-18" based on the library-                version `shouldBe` "2025-06-18"-              Just other -> expectationFailure $ "protocolVersion is not a string: " ++ show other-              Nothing -> expectationFailure "Response missing protocolVersion"-          Just other -> expectationFailure $ "Result is not an object: " ++ show other+  it "echoes back the newest revision (2025-11-25) when the client proposes it" $+    negotiate "2025-11-25" `shouldReturn` "2025-11-25" -  it "Server should respond with same version when client requests supported version" $ do-    -- This test verifies the happy path: client requests "2025-06-18"-    -- and server responds with "2025-06-18"-    let params = object-          [ "protocolVersion" .= String "2025-06-18"  -- Library's supported version-          , "capabilities" .= object []-          , "clientInfo" .= object-              [ "name" .= String "test-client"-              , "version" .= String "1.0.0"-              ]-          ]-        request = JsonRpcRequest-          { requestJsonrpc = "2.0"-          , requestId = RequestIdNumber 0-          , requestMethod = "initialize"-          , requestParams = Just params-          }+  it "echoes back 2025-06-18 when the client proposes it" $+    negotiate "2025-06-18" `shouldReturn` "2025-06-18" -    response <- handleInitialize testServerInfo request+  it "echoes back 2025-03-26 when the client proposes it" $+    negotiate "2025-03-26" `shouldReturn` "2025-03-26" -    -- Check it's not an error-    case responseError response of-      Just err -> expectationFailure $ "Unexpected error: " ++ show (errorMessage err)-      Nothing -> do-        -- Verify protocolVersion matches-        case responseResult response of-          Nothing -> expectationFailure "Response has no result"-          Just (Object result) -> do-            case KM.lookup "protocolVersion" result of-              Just (String version) -> version `shouldBe` "2025-06-18"-              Just other -> expectationFailure $ "protocolVersion is not a string: " ++ show other-              Nothing -> expectationFailure "Response missing protocolVersion"-          Just other -> expectationFailure $ "Result is not an object: " ++ show other+  -- Regression: Claude Code proposes 2024-11-05 and disconnects if it does not+  -- receive that exact version back, so tools never appear.+  it "echoes back the oldest compatible revision (2024-11-05) when the client proposes it" $+    negotiate "2024-11-05" `shouldReturn` "2024-11-05"++  it "falls back to the server's own version for an unknown/unsupported version" $+    negotiate "1999-01-01" `shouldReturn` protocolVersion++  -- Strict clients drop a server that advertises a capability and then answers+  -- the corresponding list request with an error, so only capabilities with an+  -- actual handler may be advertised.+  it "advertises only the capabilities that have handlers" $ do+    response <- initialize protocolVersion+    caps <- case responseResult response of+      Just (Object result) -> case KM.lookup "capabilities" result of+        Just (Object capsObj) -> pure capsObj+        other -> error $ "capabilities is not an object: " ++ show other+      other -> error $ "Result is not an object: " ++ show other+    KM.member "tools" caps `shouldBe` True+    KM.member "prompts" caps `shouldBe` False+    KM.member "resources" caps `shouldBe` False

@@ -67,7 +67,7 @@      forM_ schemaTestCases $ \testCase -> do       it (T.unpack $ schemaTestDescription testCase) $ do-        toolDefs <- listHandler+        toolDefs <- listHandler anonCtx          assertToolExists (schemaToolName testCase) toolDefs         let toolDef = findTool (schemaToolName testCase) toolDefs@@ -82,7 +82,7 @@   describe "Custom Descriptions" $ do     it "applies correct tool descriptions" $ do       let (listHandler, _) = testToolHandlersWithDescriptions-      toolDefs <- listHandler+      toolDefs <- listHandler anonCtx        assertToolExists "echo" toolDefs       let echoDef = findTool "echo" toolDefs@@ -94,7 +94,7 @@      it "applies correct field descriptions for Calculate tool" $ do       let (listHandler, _) = testToolHandlersWithDescriptions-      toolDefs <- listHandler+      toolDefs <- listHandler anonCtx        assertToolExists "calculate" toolDefs       let calculateDef = findTool "calculate" toolDefs

@@ -14,7 +14,7 @@ allTypesHandlers = $(deriveToolHandler ''AllTypesTool 'handleAllTypesTool)  callTool :: Text -> [(Text, Text)] -> IO (Either Error Content)-callTool = snd allTypesHandlers+callTool = snd allTypesHandlers anonCtx  shouldBeRight :: IO (Either Error Content) -> Text -> IO () shouldBeRight action expected = do

@@ -215,24 +215,26 @@               Nothing -> return $ Left $ MissingRequiredParams "expression"             _ -> return $ Left $ UnknownTool name +      -- Handlers above ignore the per-request client context+      let ctx = ClientContext Nothing Nothing       let handlers = McpServerHandlers-            { prompts = Just (promptListHandler, promptGetHandler)-            , resources = Just (resourceListHandler, resourceReadHandler)-            , tools = Just (toolListHandler, toolCallHandler)+            { prompts = Just (const promptListHandler, const promptGetHandler)+            , resources = Just (const resourceListHandler, const resourceReadHandler)+            , tools = Just (const toolListHandler, const toolCallHandler)             }        -- Test that all handlers work with Unicode-      promptList <- fst $ case prompts handlers of Just h -> h; Nothing -> error "No prompts"+      promptList <- ($ ctx) $ fst $ case prompts handlers of Just h -> h; Nothing -> error "No prompts"       promptList `shouldSatisfy` (not . null) -      resourceList <- fst $ case resources handlers of Just h -> h; Nothing -> error "No resources"+      resourceList <- ($ ctx) $ fst $ case resources handlers of Just h -> h; Nothing -> error "No resources"       resourceList `shouldSatisfy` (not . null) -      toolList <- fst $ case tools handlers of Just h -> h; Nothing -> error "No tools"+      toolList <- ($ ctx) $ fst $ case tools handlers of Just h -> h; Nothing -> error "No tools"       toolList `shouldSatisfy` (not . null)        -- Test actual Unicode handling-      promptResult <- snd (case prompts handlers of Just h -> h; Nothing -> error "No prompts") "math_formula" [("formula", "√(x²+y²)")]+      promptResult <- snd (case prompts handlers of Just h -> h; Nothing -> error "No prompts") ctx "math_formula" [("formula", "√(x²+y²)")]       case promptResult of         Right (ContentText txt) -> txt `shouldSatisfy` T.isInfixOf "√"         _ -> expectationFailure "Expected successful prompt result"@@ -240,12 +242,12 @@       uri <- case parseURI "resource://unicode_symbols" of         Just u  -> return u         Nothing -> fail "Invalid URI"-      resourceResult <- snd (case resources handlers of Just h -> h; Nothing -> error "No resources") uri+      resourceResult <- snd (case resources handlers of Just h -> h; Nothing -> error "No resources") ctx uri       case resourceResult of         Right (ResourceText _ _ txt) -> txt `shouldSatisfy` T.isInfixOf "∀∃∈∉"         _ -> expectationFailure "Expected successful resource result" -      toolResult <- snd (case tools handlers of Just h -> h; Nothing -> error "No tools") "calculate" [("expression", "∫₀^∞ e^(-x²) dx = √π/2")]+      toolResult <- snd (case tools handlers of Just h -> h; Nothing -> error "No tools") ctx "calculate" [("expression", "∫₀^∞ e^(-x²) dx = √π/2")]       case toolResult of         Right (ContentText txt) -> do           txt `shouldSatisfy` T.isInfixOf "√"

@@ -4,9 +4,13 @@  import           Data.Text  (Text) import qualified Data.Text  as T-import           MCP.Server (Content(..), ResourceContent(..))+import           MCP.Server (ClientContext(..), Content(..), ResourceContent(..)) import           Network.URI (URI) +-- Context passed to handlers in tests (no transport-level identity)+anonCtx :: ClientContext+anonCtx = ClientContext Nothing Nothing+ -- Test data types for end-to-end testing data TestPrompt     = SimplePrompt { message :: Text }@@ -47,49 +51,49 @@     deriving (Show, Eq)  -- Handler functions-handleTestPrompt :: TestPrompt -> IO Content-handleTestPrompt (SimplePrompt msg) =+handleTestPrompt :: ClientContext -> TestPrompt -> IO Content+handleTestPrompt _ (SimplePrompt msg) =     pure $ ContentText $ "Simple prompt: " <> msg-handleTestPrompt (ComplexPrompt title prio urgent) =+handleTestPrompt _ (ComplexPrompt title prio urgent) =     pure $ ContentText $ "Complex prompt: " <> title <> " (priority=" <> T.pack (show prio) <> ", urgent=" <> T.pack (show urgent) <> ")"-handleTestPrompt (OptionalPrompt req opt) =+handleTestPrompt _ (OptionalPrompt req opt) =     pure $ ContentText $ "Optional prompt: " <> req <> maybe "" ((" optional=" <>) . T.pack . show) opt -handleTestResource :: URI -> TestResource -> IO ResourceContent-handleTestResource uri ConfigFile =+handleTestResource :: ClientContext -> URI -> TestResource -> IO ResourceContent+handleTestResource _ uri ConfigFile =     pure $ ResourceText uri "text/plain" "Config file contents: debug=true, timeout=30"-handleTestResource uri DatabaseConnection =+handleTestResource _ uri DatabaseConnection =     pure $ ResourceText uri "text/plain" "Database at localhost:5432"-handleTestResource uri UserProfile =+handleTestResource _ uri UserProfile =     pure $ ResourceText uri "text/plain" "User profile for ID 123" -handleTestTool :: TestTool -> IO Content-handleTestTool (Echo text) =+handleTestTool :: ClientContext -> TestTool -> IO Content+handleTestTool _ (Echo text) =     pure $ ContentText $ "Echo: " <> text-handleTestTool (Calculate op x y) =+handleTestTool _ (Calculate op x y) =     let result = case op of             "add" -> x + y             "multiply" -> x * y             "subtract" -> x - y             _ -> 0     in pure $ ContentText $ T.pack (show result)-handleTestTool (Toggle flag) =+handleTestTool _ (Toggle flag) =     pure $ ContentText $ "Flag is now: " <> T.pack (show (not flag))-handleTestTool (Search query limit caseSens) =+handleTestTool _ (Search query limit caseSens) =     pure $ ContentText $ "Search results for '" <> query <> "'" <>         maybe "" ((" (limit=" <>) . (<> ")") . T.pack . show) limit <>         maybe "" ((" (case-sensitive=" <>) . (<> ")") . T.pack . show) caseSens  -- Handler for separate params tool-handleSeparateParamsTool :: SeparateParamsTool -> IO Content-handleSeparateParamsTool (GetValue (GetValueParams key)) =+handleSeparateParamsTool :: ClientContext -> SeparateParamsTool -> IO Content+handleSeparateParamsTool _ (GetValue (GetValueParams key)) =     pure $ ContentText $ "Getting value for key: " <> key-handleSeparateParamsTool (SetValue (SetValueParams key value)) =+handleSeparateParamsTool _ (SetValue (SetValueParams key value)) =     pure $ ContentText $ "Setting " <> key <> " = " <> value  -- Handler for recursive tool-handleRecursiveTool :: RecursiveTool -> IO Content-handleRecursiveTool (ProcessData (MiddleParams (InnerParams name age))) =+handleRecursiveTool :: ClientContext -> RecursiveTool -> IO Content+handleRecursiveTool _ (ProcessData (MiddleParams (InnerParams name age))) =     pure $ ContentText $ "Processing data for " <> name <> " (age " <> T.pack (show age) <> ")"  -- Type covering all parseable field types for exhaustive parsing tests@@ -112,8 +116,8 @@         }     deriving (Show, Eq) -handleAllTypesTool :: AllTypesTool -> IO Content-handleAllTypesTool (RequiredFields t i ig d f b) =+handleAllTypesTool :: ClientContext -> AllTypesTool -> IO Content+handleAllTypesTool _ (RequiredFields t i ig d f b) =     pure $ ContentText $ T.intercalate ", "         [ "text=" <> t         , "int=" <> T.pack (show i)@@ -122,7 +126,7 @@         , "float=" <> T.pack (show f)         , "bool=" <> T.pack (show b)         ]-handleAllTypesTool (OptionalFields t i ig d f b) =+handleAllTypesTool _ (OptionalFields t i ig d f b) =     pure $ ContentText $ T.intercalate ", "         [ "text=" <> maybe "Nothing" id t         , "int=" <> maybe "Nothing" (T.pack . show) i