mcp-server 0.1.0.14 → 0.1.0.15

raw patch · 8 files changed

+98/−61 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +5/−5
• mcp-server.cabal +3/−3
• src/MCP/Server/Derive.hs +7/−0
• src/MCP/Server/Handlers.hs +4/−4
• src/MCP/Server/Protocol.hs +7/−3
• src/MCP/Server/Transport/Http.hs +54/−38
• src/MCP/Server/Types.hs +12/−8
• test/Spec/UnicodeHandling.hs +6/−0

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

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

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

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

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

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

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

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