diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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/) diff --git a/examples/Complete/Main.hs b/examples/Complete/Main.hs --- a/examples/Complete/Main.hs +++ b/examples/Complete/Main.hs @@ -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 diff --git a/examples/HttpSimple/Main.hs b/examples/HttpSimple/Main.hs --- a/examples/HttpSimple/Main.hs +++ b/examples/HttpSimple/Main.hs @@ -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 diff --git a/examples/Simple/Main.hs b/examples/Simple/Main.hs --- a/examples/Simple/Main.hs +++ b/examples/Simple/Main.hs @@ -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 diff --git a/mcp-server.cabal b/mcp-server.cabal --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -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 diff --git a/src/MCP/Server/Derive.hs b/src/MCP/Server/Derive.hs --- a/src/MCP/Server/Derive.hs +++ b/src/MCP/Server/Derive.hs @@ -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]) diff --git a/src/MCP/Server/Handlers.hs b/src/MCP/Server/Handlers.hs --- a/src/MCP/Server/Handlers.hs +++ b/src/MCP/Server/Handlers.hs @@ -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 diff --git a/src/MCP/Server/Protocol.hs b/src/MCP/Server/Protocol.hs --- a/src/MCP/Server/Protocol.hs +++ b/src/MCP/Server/Protocol.hs @@ -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 diff --git a/src/MCP/Server/Transport/Http.hs b/src/MCP/Server/Transport/Http.hs --- a/src/MCP/Server/Transport/Http.hs +++ b/src/MCP/Server/Transport/Http.hs @@ -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 diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs --- a/src/MCP/Server/Transport/Stdio.hs +++ b/src/MCP/Server/Transport/Stdio.hs @@ -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)) diff --git a/src/MCP/Server/Types.hs b/src/MCP/Server/Types.hs --- a/src/MCP/Server/Types.hs +++ b/src/MCP/Server/Types.hs @@ -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 diff --git a/test/Spec/AdvancedDerivation.hs b/test/Spec/AdvancedDerivation.hs --- a/test/Spec/AdvancedDerivation.hs +++ b/test/Spec/AdvancedDerivation.hs @@ -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 diff --git a/test/Spec/BasicDerivation.hs b/test/Spec/BasicDerivation.hs --- a/test/Spec/BasicDerivation.hs +++ b/test/Spec/BasicDerivation.hs @@ -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 diff --git a/test/Spec/ProtocolVersionNegotiation.hs b/test/Spec/ProtocolVersionNegotiation.hs --- a/test/Spec/ProtocolVersionNegotiation.hs +++ b/test/Spec/ProtocolVersionNegotiation.hs @@ -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 diff --git a/test/Spec/SchemaValidation.hs b/test/Spec/SchemaValidation.hs --- a/test/Spec/SchemaValidation.hs +++ b/test/Spec/SchemaValidation.hs @@ -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 diff --git a/test/Spec/ToolCallParsing.hs b/test/Spec/ToolCallParsing.hs --- a/test/Spec/ToolCallParsing.hs +++ b/test/Spec/ToolCallParsing.hs @@ -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 diff --git a/test/Spec/UnicodeHandling.hs b/test/Spec/UnicodeHandling.hs --- a/test/Spec/UnicodeHandling.hs +++ b/test/Spec/UnicodeHandling.hs @@ -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 "√" diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -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