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-03-26 specification (with backward compatibility for 2024-11-05) +- **Complete MCP Implementation**: Supports MCP 2025-06-18 specification - **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-03-26 Streamable HTTP) +- **Multiple Transports**: STDIO and HTTP Streaming transport (MCP 2025-06-18 Streamable HTTP) ## Supported MCP Features @@ -180,7 +180,7 @@ ## HTTP Transport (NEW!) -The library now supports MCP 2025-03-26 Streamable HTTP transport: +The library now supports MCP 2025-06-18 Streamable HTTP transport: ```haskell import MCP.Server.Transport.Http @@ -203,7 +203,7 @@ - CORS enabled for web clients - GET `/mcp` for server discovery - POST `/mcp` for JSON-RPC messages -- Full MCP 2025-03-26 compliance +- Full MCP 2025-06-18 compliance ## Examples @@ -245,7 +245,7 @@ ## Documentation -- [MCP Specification](https://modelcontextprotocol.io/specification/2024-11-05/) +- [MCP Specification](https://modelcontextprotocol.io/specification/2025-06-18/) - [API Documentation](https://hackage.haskell.org/package/mcp-server) - [Examples](examples/) 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.14 +version: 0.1.0.15 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package. @@ -66,9 +66,9 @@ MCP.Server.Handlers MCP.Server.JsonRpc MCP.Server.Protocol - MCP.Server.Types - MCP.Server.Transport.Stdio MCP.Server.Transport.Http + MCP.Server.Transport.Stdio + MCP.Server.Types -- Modules included in this library but not exported. -- other-modules: 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 @@ -77,6 +77,7 @@ { promptDefinitionName = $(litE $ stringL $ T.unpack promptName) , promptDefinitionDescription = $(litE $ stringL description) , promptDefinitionArguments = [] + , promptDefinitionTitle = Nothing -- 2025-06-18: New title field } |] RecC name fields -> do let promptName = T.pack . toSnakeCase . nameBase $ name @@ -89,6 +90,7 @@ { promptDefinitionName = $(litE $ stringL $ T.unpack promptName) , promptDefinitionDescription = $(litE $ stringL description) , promptDefinitionArguments = $(return $ ListE args) + , promptDefinitionTitle = Nothing -- 2025-06-18: New title field } |] NormalC name [(_bang, paramType)] -> do -- Handle separate parameter types approach @@ -102,6 +104,7 @@ { promptDefinitionName = $(litE $ stringL $ T.unpack promptName) , promptDefinitionDescription = $(litE $ stringL description) , promptDefinitionArguments = $(return $ ListE args) + , promptDefinitionTitle = Nothing -- 2025-06-18: New title field } |] _ -> fail "Unsupported constructor type" @@ -369,6 +372,7 @@ Just desc -> [| Just $(litE $ stringL desc) |] Nothing -> [| Nothing |]) , resourceDefinitionMimeType = Just "text/plain" + , resourceDefinitionTitle = Nothing -- 2025-06-18: New title field } |] mkResourceDefWithDescription _ _ = fail "Unsupported constructor type for resources" @@ -428,6 +432,7 @@ { properties = [] , required = [] } + , toolDefinitionTitle = Nothing -- 2025-06-18: New title field } |] RecC name fields -> do let toolName = T.pack . toSnakeCase . nameBase $ name @@ -450,6 +455,7 @@ { properties = $(return $ ListE props) , required = $(return $ ListE $ map (LitE . StringL) required) } + , toolDefinitionTitle = Nothing -- 2025-06-18: New title field } |] NormalC name [(_bang, paramType)] -> do -- Handle separate parameter types approach for tools @@ -474,6 +480,7 @@ { properties = $(return $ ListE props) , required = $(return $ ListE $ map (LitE . StringL) required) } + , toolDefinitionTitle = Nothing -- 2025-06-18: New title field } |] _ -> fail "Unsupported constructor type for tools" 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 @@ -61,10 +61,8 @@ -- | Validate protocol version and return negotiated version validateProtocolVersion :: Text -> Either Text Text validateProtocolVersion clientVersion - | clientVersion == protocolVersion = Right protocolVersion -- Exact match (2025-03-26) - | clientVersion == "2025-03-26" = Right "2025-03-26" -- Accept latest version - | clientVersion == "2024-11-05" = Right "2024-11-05" -- Accept legacy version - | otherwise = Left $ "Unsupported protocol version: " <> clientVersion <> ". Server supports: 2025-03-26, 2024-11-05" + | clientVersion == protocolVersion = Right protocolVersion -- Exact match (2025-06-18) + | otherwise = Left $ "Unsupported protocol version: " <> clientVersion <> ". Server only supports: 2025-06-18" -- | Handle an MCP message and return a response if needed handleMcpMessage :: (MonadIO m) @@ -198,6 +196,7 @@ let response = PromptsGetResponse { promptsGetDescription = Nothing , promptsGetMessages = [PromptMessage RoleUser content] + , promptsGetMeta = Nothing -- Can be extended for additional metadata } return $ makeSuccessResponse (requestId req) (toJSON response) @@ -306,6 +305,7 @@ let response = ToolsCallResponse { toolsCallContent = [content] , toolsCallIsError = Nothing + , toolsCallMeta = Nothing -- Can be extended for structured output } return $ makeSuccessResponse (requestId req) (toJSON response) 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 @@ -43,7 +43,7 @@ import MCP.Server.Types protocolVersion :: Text -protocolVersion = "2025-03-26" +protocolVersion = "2025-06-18" -- | Initialize request @@ -146,16 +146,18 @@ <$> o .: "name" <*> o .:? "arguments" --- | Prompts get response +-- | Prompts get response (2025-06-18 enhanced) data PromptsGetResponse = PromptsGetResponse { promptsGetDescription :: Maybe Text , promptsGetMessages :: [PromptMessage] + , promptsGetMeta :: Maybe Value -- New _meta field for additional metadata } deriving (Show, Eq, Generic) instance ToJSON PromptsGetResponse where toJSON resp = object $ [ "messages" .= promptsGetMessages resp ] ++ maybe [] (\d -> ["description" .= d]) (promptsGetDescription resp) + ++ maybe [] (\m -> ["_meta" .= m]) (promptsGetMeta resp) -- | Resources list request data ResourcesListRequest = ResourcesListRequest @@ -224,16 +226,18 @@ <$> o .: "name" <*> o .:? "arguments" --- | Tools call response +-- | Tools call response (2025-06-18 enhanced) data ToolsCallResponse = ToolsCallResponse { toolsCallContent :: [Content] , toolsCallIsError :: Maybe Bool + , toolsCallMeta :: Maybe Value -- New _meta field for structured output } deriving (Show, Eq, Generic) instance ToJSON ToolsCallResponse where toJSON resp = object $ [ "content" .= toolsCallContent resp ] ++ maybe [] (\e -> ["isError" .= e]) (toolsCallIsError resp) + ++ maybe [] (\m -> ["_meta" .= m]) (toolsCallMeta resp) -- | List changed notification data ListChangedNotification = ListChangedNotification 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 @@ -24,7 +24,7 @@ import MCP.Server.JsonRpc import MCP.Server.Types --- | HTTP transport configuration following MCP 2025-03-26 Streamable HTTP specification +-- | HTTP transport configuration following MCP 2025-06-18 Streamable HTTP specification data HttpConfig = HttpConfig { httpPort :: Int -- ^ Port to listen on , httpHost :: String -- ^ Host to bind to (default "localhost") @@ -70,47 +70,63 @@ -- | 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 - case Wai.requestMethod req of - -- GET requests for endpoint discovery - "GET" -> do - let discoveryResponse = object - [ "name" .= serverName serverInfo - , "version" .= serverVersion serverInfo - , "description" .= serverInstructions serverInfo - , "protocolVersion" .= ("2025-03-26" :: Text) - , "capabilities" .= object - [ "tools" .= object [] - , "prompts" .= object [] - , "resources" .= object [] - ] - ] - logVerbose config $ "Sending server discovery response: " ++ show discoveryResponse + -- 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" respond $ Wai.responseLBS - status200 - [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] - (encode discoveryResponse) + 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 + case Wai.requestMethod req of + -- GET requests for endpoint discovery + "GET" -> do + let discoveryResponse = object + [ "name" .= serverName serverInfo + , "version" .= serverVersion serverInfo + , "description" .= serverInstructions serverInfo + , "protocolVersion" .= ("2025-06-18" :: Text) + , "capabilities" .= object + [ "tools" .= object [] + , "prompts" .= object [] + , "resources" .= object [] + ] + ] + logVerbose config $ "Sending server discovery response: " ++ show discoveryResponse + respond $ Wai.responseLBS + status200 + [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] + (encode discoveryResponse) - -- 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 + -- 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 - -- 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") - ] - "" + -- 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") + ] + "" - -- Unsupported methods - _ -> respond $ Wai.responseLBS - status405 - [("Content-Type", "text/plain"), ("Allow", "GET, POST, OPTIONS")] - "Method Not Allowed" + -- Unsupported methods + _ -> respond $ Wai.responseLBS + status405 + [("Content-Type", "text/plain"), ("Allow", "GET, POST, OPTIONS")] + "Method Not Allowed" -- | Handle JSON-RPC request from HTTP body handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived 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 @@ -191,26 +191,28 @@ errorMessage (MethodNotFound msg) = "Method not found: " <> msg errorMessage (InvalidParams msg) = "Invalid parameters: " <> msg --- | Prompt definition +-- | Prompt definition (2025-06-18 enhanced) data PromptDefinition = PromptDefinition { promptDefinitionName :: Text , promptDefinitionDescription :: Text , promptDefinitionArguments :: [ArgumentDefinition] + , promptDefinitionTitle :: Maybe Text -- New title field for human-friendly display } deriving (Show, Eq, Generic) instance ToJSON PromptDefinition where - toJSON def = object + toJSON def = object $ [ "name" .= promptDefinitionName def , "description" .= promptDefinitionDescription def , "arguments" .= promptDefinitionArguments def - ] + ] ++ maybe [] (\t -> ["title" .= t]) (promptDefinitionTitle def) --- | Resource definition +-- | Resource definition (2025-06-18 enhanced) data ResourceDefinition = ResourceDefinition { resourceDefinitionURI :: Text , resourceDefinitionName :: Text , resourceDefinitionDescription :: Maybe Text , resourceDefinitionMimeType :: Maybe Text + , resourceDefinitionTitle :: Maybe Text -- New title field for human-friendly display } deriving (Show, Eq, Generic) instance ToJSON ResourceDefinition where @@ -219,21 +221,23 @@ , "name" .= resourceDefinitionName def ] ++ maybe [] (\d -> ["description" .= d]) (resourceDefinitionDescription def) ++ - maybe [] (\m -> ["mimeType" .= m]) (resourceDefinitionMimeType def) + maybe [] (\m -> ["mimeType" .= m]) (resourceDefinitionMimeType def) ++ + maybe [] (\t -> ["title" .= t]) (resourceDefinitionTitle def) --- | Tool definition +-- | Tool definition (2025-06-18 enhanced) data ToolDefinition = ToolDefinition { toolDefinitionName :: Text , toolDefinitionDescription :: Text , toolDefinitionInputSchema :: InputSchemaDefinition + , toolDefinitionTitle :: Maybe Text -- New title field for human-friendly display } deriving (Show, Eq, Generic) instance ToJSON ToolDefinition where - toJSON def = object + toJSON def = object $ [ "name" .= toolDefinitionName def , "description" .= toolDefinitionDescription def , "inputSchema" .= toolDefinitionInputSchema def - ] + ] ++ maybe [] (\t -> ["title" .= t]) (toolDefinitionTitle def) -- | Argument definition for prompts data ArgumentDefinition = ArgumentDefinition diff --git a/test/Spec/UnicodeHandling.hs b/test/Spec/UnicodeHandling.hs --- a/test/Spec/UnicodeHandling.hs +++ b/test/Spec/UnicodeHandling.hs @@ -61,6 +61,7 @@ let response = ToolsCallResponse { toolsCallContent = [ContentText "Result: √16 = 4, π ≈ 3.14159"] , toolsCallIsError = Nothing + , toolsCallMeta = Nothing -- 2025-06-18: New _meta field } let encoded = encode response -- Just verify the JSON can be encoded and contains Unicode @@ -86,6 +87,7 @@ let response = ToolsCallResponse { toolsCallContent = [ContentText "Mathematical result: √(π²+e²) ≈ 4.53"] , toolsCallIsError = Nothing + , toolsCallMeta = Nothing -- 2025-06-18: New _meta field } let json = toJSON response -- Verify the JSON can be encoded and contains Unicode @@ -97,6 +99,7 @@ let response = PromptsGetResponse { promptsGetDescription = Just "Mathematical formulas with symbols: ∀∃" , promptsGetMessages = [message] + , promptsGetMeta = Nothing -- 2025-06-18: New _meta field } let json = toJSON response let encoded = encode json @@ -169,6 +172,7 @@ { promptDefinitionName = "math_formula" , promptDefinitionDescription = "Generate mathematical formulas with Unicode: ∀∃∈√" , promptDefinitionArguments = [ArgumentDefinition "formula" "Mathematical expression" True] + , promptDefinitionTitle = Nothing -- 2025-06-18: New title field } ] @@ -184,6 +188,7 @@ , resourceDefinitionName = "unicode_symbols" , resourceDefinitionDescription = Just "Unicode mathematical symbols: ∀∃∈∉√∑" , resourceDefinitionMimeType = Just "text/plain" + , resourceDefinitionTitle = Nothing -- 2025-06-18: New title field } ] @@ -200,6 +205,7 @@ { properties = [("expression", InputSchemaDefinitionProperty "string" "Mathematical expression")] , required = ["expression"] } + , toolDefinitionTitle = Nothing -- 2025-06-18: New title field } ]