diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,49 +1,16 @@ -# Revision history for mcp - -## 0.2.0.0 -- 2025-01-18 +# Changelog -* Add HTTP transport support following MCP specification -* Implement full OAuth 2.0 authorization flow with mandatory PKCE - - OAuth metadata discovery at /.well-known/oauth-authorization-server - - Dynamic client registration at /register endpoint - - /authorize endpoint for authorization requests with PKCE validation - - /token endpoint for authorization code and refresh token grants - - In-memory storage for authorization codes, tokens, and registered clients - - Automatic user approval for demo mode - - Support for public clients (no client secret required) -* Add OAuth 2.1 authentication module (MCP.Server.Auth) - - JWT token validation and introspection - - PKCE code verifier/challenge generation and validation (S256 method) - - OAuth metadata discovery with ToJSON/FromJSON instances - - Support for multiple OAuth providers (Google, GitHub, custom) - - Token expiration and not-before time validation -* OAuth implementation features: - - Returns empty string for client_secret (public clients) - - Validates redirect URIs and client IDs - - 10-minute authorization code expiry - - 1-hour access token validity - - Refresh token support with rotation - - Proper JWT token generation using servant-auth-server - - Fixed authentication loop issue by replacing UUID tokens with JWT -* Add example OAuth resources: - - OAuth demo client script (examples/oauth-client-demo.sh) - - OAuth metadata test script (test-oauth-metadata.sh) - - Updated HTTP server example with --oauth flag -* Fix all compiler warnings with -Wall enabled -* Clean up unused imports and parameters -* Add uuid dependency for token generation -* **BREAKING CHANGE**: Refactor HTTP server to be production-ready: - - Extract hardcoded demo values into configurable parameters - - Add `httpBaseUrl` and `httpProtocolVersion` to HTTPServerConfig - - Expand OAuthConfig with timing, OAuth parameters, and demo settings - - Move demo-specific configuration to examples/http-server.hs - - Add `defaultDemoOAuthConfig` helper for testing - - Make server library more robust and configurable for production use -* Package metadata cleanup and code formatting improvements -* Remove unused MyLib module -* Add MCP configuration and examples -* Published to Hackage +## 0.3.0.1 -## 0.1.0.0 -- YYYY-mm-dd +### Added +- Protocol types extracted into `mcp-types`; server remains as `mcp`. +- `MCP.Server.Common`: transport-agnostic types, state, request routing, and tool helpers. +- `MCP.Server.HTTP`: Servant-based HTTP transport with JWT authentication and SSE responses. +- `MCP.Server.Stdio`: stdio transport reading/writing JSON-RPC messages line-by-line. +- `MCP.Server`: re-exports all three submodules for backwards compatibility. +- Re-exports `MCP.Protocol` and `MCP.Types` from `mcp-types` for convenience. +- Integration test suite covering both HTTP and stdio transports. -* First version. Released on an unsuspecting world. +### Migration +- Change `import MCP` to `import MCP.Server`. +- If you only need types, depend on `mcp-types` instead of `mcp`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,20 +1,373 @@ -Copyright (c) 2025 Matthias Pall Gissurarson +Mozilla Public License Version 2.0 +================================== -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: +1. Definitions +-------------- -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,91 @@ +# mcp — MCP server for Haskell + +[![mcp on Hackage](https://img.shields.io/hackage/v/mcp.svg)](https://hackage.haskell.org/package/mcp) + +A complete server implementation of the +[Model Context Protocol (MCP)](https://modelcontextprotocol.io/) for Haskell, +built on Servant with JWT authentication via `servant-auth-server`. + +Implements MCP protocol version **2025-06-18**. Re-exports the core protocol types from +[`mcp-types`](https://hackage.haskell.org/package/mcp-types) for convenience. + +## Modules + +- **`MCP.Server`** — Re-exports everything below for convenience. +- **`MCP.Server.Common`** — Transport-agnostic core: types, state management, + request routing, `ProcessHandlers`, `ToolHandler` framework. +- **`MCP.Server.HTTP`** — Servant-based HTTP transport with JWT authentication + and streaming SSE responses at the `/mcp` endpoint. +- **`MCP.Server.Stdio`** — Stdio transport reading/writing JSON-RPC messages + line-by-line, suitable for subprocess-based integrations. + +## Install + +```cabal +build-depends: + base + , servant + , servant-server + , servant-auth-server + , aeson + , mcp +``` + +If you only need the protocol types (e.g. for a client), depend on +[`mcp-types`](https://hackage.haskell.org/package/mcp-types) instead. + +## Quick Start + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +import Control.Concurrent.MVar (newMVar) +import MCP.Server + +-- Define your handler state and user types +type instance MCPHandlerState = () +type instance MCPHandlerUser = MyUser + +-- Create server state with capabilities +mkServerState :: IO (MVar MCPServerState) +mkServerState = do + let impl = Implementation "my-server" "1.0.0" Nothing + caps = ServerCapabilities + { logging = Nothing + , prompts = Nothing + , resources = Nothing + , tools = Just (ToolsCapability { listChanged = Just True }) + , completions = Nothing + , experimental = Nothing + } + handlers = withToolHandlers myTools defaultProcessHandlers + newMVar $ initMCPServerState () Nothing Nothing caps impl Nothing handlers + +-- Define tools using the ToolHandler framework +myTools :: [ToolHandler] +myTools = + [ toolHandler "greet" (Just "Say hello") greetSchema $ \_args -> + return $ ProcessSuccess $ toolTextResult ["Hello!"] + ] +``` + +A fully documented example server lives in +[`mcp-server/example/`](https://github.com/DPella/mcp/tree/main/mcp-server/example). + +## Features + +- **Two transports**: HTTP (Servant + SSE) and stdio +- **JWT authentication** via `servant-auth-server` (HTTP transport) +- **Extensible handler framework**: `ProcessHandlers` record with optional + handlers for each MCP method +- **Tool helpers**: `ToolHandler`, `toolHandler`, `withToolHandlers`, + `toolTextResult`, `toolTextError` +- **Server-to-client requests**: `ProcessClientInput` for sampling, + elicitation, and other client callbacks on both transports +- **MCP 2025-06-18**: Full protocol version support + +## License + +MPL-2.0 diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Main where - -import Control.Monad.IO.Class (liftIO) -import Data.Text qualified as T -import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) -import System.IO (stdin, stdout) - -import MCP.Protocol -import MCP.Server -import MCP.Server.StdIO -import MCP.Types - --- | Minimal MCP Server implementation -instance MCPServer MCPServerM where - handleListResources _params = do - return $ ListResourcesResult{resources = [], nextCursor = Nothing, _meta = Nothing} - - handleReadResource _params = do - let textContent = TextResourceContents{uri = "example://hello", text = "Hello from MCP Haskell server!", mimeType = Just "text/plain"} - let content = TextResource textContent - return $ ReadResourceResult{contents = [content], _meta = Nothing} - - handleListResourceTemplates _params = do - return $ ListResourceTemplatesResult{resourceTemplates = [], nextCursor = Nothing, _meta = Nothing} - - handleListPrompts _params = do - return $ ListPromptsResult{prompts = [], nextCursor = Nothing, _meta = Nothing} - - handleGetPrompt _params = do - let textContent = TextContent{text = "Hello prompt!", textType = "text", annotations = Nothing} - let content = TextContentType textContent - let message = PromptMessage{role = User, content = content} - return $ GetPromptResult{messages = [message], description = Nothing, _meta = Nothing} - - handleListTools _params = do - let getCurrentDateTool = - Tool - { name = "getCurrentDate" - , description = Just "Get the current date and time" - , inputSchema = InputSchema "object" Nothing Nothing - , annotations = Nothing - } - return $ ListToolsResult{tools = [getCurrentDateTool], nextCursor = Nothing, _meta = Nothing} - - handleCallTool CallToolParams{name = toolName} = do - case toolName of - "getCurrentDate" -> do - currentTime <- liftIO getCurrentTime - let dateStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" currentTime - let textContent = TextContent{text = T.pack dateStr, textType = "text", annotations = Nothing} - let content = TextContentType textContent - return $ CallToolResult{content = [content], isError = Nothing, _meta = Nothing} - _ -> do - let textContent = TextContent{text = "Tool not found", textType = "text", annotations = Nothing} - let content = TextContentType textContent - return $ CallToolResult{content = [content], isError = Just True, _meta = Nothing} - - handleComplete _params = do - let completionResult = CompletionResult{values = [], total = Nothing, hasMore = Just True} - return $ CompleteResult{completion = completionResult, _meta = Nothing} - - handleSetLevel _params = do - liftIO $ putStrLn "Log level set" - -main :: IO () -main = do - putStrLn "Starting MCP Haskell Server..." - - let serverInfo = - Implementation - { name = "mcp-haskell-example" - , version = "0.1.0" - } - - let resourcesCap = - ResourcesCapability - { subscribe = Just False - , listChanged = Just False - } - let promptsCap = - PromptsCapability - { listChanged = Just False - } - let toolsCap = - ToolsCapability - { listChanged = Just False - } - - let capabilities = - ServerCapabilities - { resources = Just resourcesCap - , prompts = Just promptsCap - , tools = Just toolsCap - , completions = Nothing - , logging = Nothing - , experimental = Nothing - } - - let config = - MCP.Server.StdIO.ServerConfig - { configInput = stdin - , configOutput = stdout - , configServerInfo = serverInfo - , configCapabilities = capabilities - } - - putStrLn "Server configured, starting message loop..." - MCP.Server.StdIO.runServer config diff --git a/examples/README.md b/examples/README.md deleted file mode 100644 --- a/examples/README.md +++ /dev/null @@ -1,253 +0,0 @@ -# MCP Configuration Examples and Usage - -This directory contains example configuration files for connecting MCP clients to the Haskell MCP server, as well as example implementations demonstrating different transport methods. - -## Claude Desktop Configuration - -Claude Desktop reads its MCP server configuration from a JSON file. The location depends on your operating system: - -### Configuration File Locations - -- **macOS**: `~/Library/Application Support/Claude/claude_desktop_config.json` -- **Windows**: `%APPDATA%\Claude\claude_desktop_config.json` -- **Linux**: `~/.config/claude/claude_desktop_config.json` - -### Basic Configuration - -```json -{ - "mcpServers": { - "haskell-mcp": { - "command": "cabal", - "args": ["run", "mcp"], - "cwd": "/absolute/path/to/mcp-haskell" - } - } -} -``` - -### Development Setup - -For development with Cabal: - -```json -{ - "mcpServers": { - "haskell-mcp-dev": { - "command": "cabal", - "args": ["run", "mcp"], - "cwd": "/home/user/projects/mcp-haskell", - "env": { - "GHC_ENVIRONMENT": "-" - } - } - } -} -``` - -### Production Setup - -For production with a compiled binary: - -```json -{ - "mcpServers": { - "haskell-mcp-prod": { - "command": "/usr/local/bin/mcp", - "args": [], - "cwd": "/opt/mcp-servers" - } - } -} -``` - -### Stack-based Setup - -If using Stack instead of Cabal: - -```json -{ - "mcpServers": { - "haskell-mcp-stack": { - "command": "stack", - "args": ["exec", "mcp"], - "cwd": "/path/to/mcp-haskell" - } - } -} -``` - -## Configuration Fields - -- **command**: The executable to run (cabal, stack, or direct binary path) -- **args**: Arguments passed to the command -- **cwd**: Working directory (should be the project root for development) -- **env**: Environment variables (optional) - -## Testing the Configuration - -1. Save the configuration to the appropriate location for your OS -2. Restart Claude Desktop -3. Start a new conversation -4. The Haskell MCP server should appear in the available tools/context - -## Troubleshooting - -### Common Issues - -1. **Path Problems**: Ensure `cwd` points to the correct project directory -2. **Permission Issues**: Make sure the command is executable -3. **Build Issues**: Run `cabal build` first to ensure the project compiles -4. **Port Conflicts**: Each server needs a unique name in the configuration - -### Debugging - -To test the server manually: - -```bash -cd /path/to/mcp-haskell -cabal run mcp -``` - -The server should start and wait for JSON-RPC messages on stdin. - -### Logs - -Claude Desktop logs can help debug connection issues: - -- **macOS**: `~/Library/Logs/Claude/` -- **Windows**: `%LOCALAPPDATA%\Claude\logs\` -- **Linux**: `~/.local/share/claude/logs/` - -## Example Usage - -Once configured, you can: - -1. **List Resources**: Ask Claude to show available resources -2. **Read Content**: Request specific resource content -3. **Use Tools**: Execute tools provided by the server -4. **Get Prompts**: Use pre-defined prompt templates - -The Haskell MCP server provides basic examples of each capability that you can extend for your specific use case. - ---- - -## HTTP Server Example - -**File:** `http-server.hs` - -Demonstrates how to run an MCP server using HTTP transport instead of StdIO. - -### Building and Running - -**Using Cabal (recommended):** -```bash -# From the project root -cabal build mcp-http -cabal run mcp-http -``` - -**Manual compilation:** -```bash -# From the project root -ghc -package-env=. -o examples/http-server examples/http-server.hs -cd examples -./http-server -``` - -**Using cabal exec:** -```bash -cabal exec ghc -- -package-env=. -o examples/http-server examples/http-server.hs -cd examples -./http-server -``` - -### Testing the HTTP Server - -Once running, the server exposes the MCP API at `POST http://localhost:8080/mcp`. - -**Test with curl:** - -```bash -# Ping test -curl -X POST http://localhost:8080/mcp \ - -H "Content-Type: application/json" \ - -d '{"jsonrpc":"2.0","id":1,"method":"ping"}' - -# Initialize the server -curl -X POST http://localhost:8080/mcp \ - -H "Content-Type: application/json" \ - -d '{ - "jsonrpc":"2.0", - "id":1, - "method":"initialize", - "params":{ - "protocolVersion":"2024-11-05", - "capabilities":{}, - "clientInfo":{"name":"test-client","version":"1.0.0"} - } - }' - -# List available tools -curl -X POST http://localhost:8080/mcp \ - -H "Content-Type: application/json" \ - -d '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' - -# Call the getCurrentDate tool -curl -X POST http://localhost:8080/mcp \ - -H "Content-Type: application/json" \ - -d '{ - "jsonrpc":"2.0", - "id":3, - "method":"tools/call", - "params":{"name":"getCurrentDate"} - }' -``` - -**Test with HTTPie:** - -```bash -# Ping test -http POST localhost:8080/mcp jsonrpc=2.0 id:=1 method=ping - -# Initialize -http POST localhost:8080/mcp \ - jsonrpc=2.0 id:=1 method=initialize \ - params:='{"protocolVersion":"2024-11-05","capabilities":{},"clientInfo":{"name":"test-client","version":"1.0.0"}}' - -# List tools -http POST localhost:8080/mcp jsonrpc=2.0 id:=2 method=tools/list - -# Call tool -http POST localhost:8080/mcp \ - jsonrpc=2.0 id:=3 method=tools/call \ - params:='{"name":"getCurrentDate"}' -``` - -## Key Differences: StdIO vs HTTP - -| Aspect | StdIO Transport | HTTP Transport | -|--------|----------------|----------------| -| **Client Integration** | Process-based (stdin/stdout) | HTTP clients, web apps | -| **Message Format** | Line-delimited JSON-RPC | HTTP POST with JSON body | -| **Server Lifecycle** | Managed by client process | Independent HTTP service | -| **Debugging** | Log to stderr | HTTP access logs | -| **Scalability** | One client per process | Multiple concurrent clients | -| **Network** | Local only | Network accessible | - -## Implementation Notes - -- Both transports use the same `MCPServer` typeclass implementation -- Server logic is identical between StdIO and HTTP modes -- HTTP transport follows the MCP specification for streamable HTTP -- Future versions will support Server-Sent Events (SSE) for bidirectional communication - -## Error Handling - -The HTTP server returns appropriate HTTP status codes: - -- **200 OK**: Successful JSON-RPC response -- **400 Bad Request**: Invalid JSON or malformed JSON-RPC -- **500 Internal Server Error**: Server-side processing errors - -JSON-RPC errors are returned within the 200 response body following the JSON-RPC 2.0 specification. diff --git a/examples/claude-desktop-config.json b/examples/claude-desktop-config.json deleted file mode 100644 --- a/examples/claude-desktop-config.json +++ /dev/null @@ -1,24 +0,0 @@ -{ - "mcpServers": { - "haskell-mcp-development": { - "command": "cabal", - "args": ["run", "mcp"], - "cwd": "/absolute/path/to/mcp-haskell", - "env": { - "GHC_ENVIRONMENT": "-" - } - }, - "haskell-mcp-production": { - "command": "/usr/local/bin/mcp-haskell", - "args": [], - "cwd": "/opt/mcp-servers", - "env": {} - }, - "haskell-mcp-stack": { - "command": "stack", - "args": ["exec", "mcp"], - "cwd": "/path/to/mcp-haskell", - "env": {} - } - } -} diff --git a/examples/full-config-example.json b/examples/full-config-example.json deleted file mode 100644 --- a/examples/full-config-example.json +++ /dev/null @@ -1,34 +0,0 @@ -{ - "$schema": "https://schemas.claudeai.com/claude_desktop_config.json", - "mcpServers": { - "haskell-mcp-example": { - "command": "cabal", - "args": ["run", "mcp"], - "cwd": "/Users/username/projects/mcp-haskell", - "env": { - "GHC_ENVIRONMENT": "-", - "CABAL_CONFIG": "" - } - }, - "haskell-mcp-with-logging": { - "command": "cabal", - "args": ["run", "mcp", "--", "--verbose"], - "cwd": "/Users/username/projects/mcp-haskell", - "env": { - "MCP_LOG_LEVEL": "debug" - } - }, - "haskell-mcp-custom-tools": { - "command": "/usr/local/bin/mcp-haskell-tools", - "args": ["--config", "/etc/mcp/tools.conf"], - "cwd": "/var/lib/mcp", - "env": { - "MCP_TOOLS_PATH": "/usr/local/share/mcp-tools", - "MCP_RESOURCES_PATH": "/var/lib/mcp/resources" - } - } - }, - "globalShortcuts": { - "mcp": "Cmd+Shift+M" - } -} diff --git a/examples/http-server.hs b/examples/http-server.hs deleted file mode 100644 --- a/examples/http-server.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- | -Example HTTP MCP Server - -This example demonstrates how to run the MCP server over HTTP transport. -The server will expose the MCP API at POST /mcp - -To test: -1. Compile: cabal build mcp-http -2. Run: cabal run mcp-http -3. Send JSON-RPC requests to: http://localhost:/mcp - -Example request: -curl -X POST http://localhost:8080/mcp \ - -H "Content-Type: application/json" \ - -d '{"jsonrpc":"2.0","id":1,"method":"ping"}' - -Command line options: -cabal run mcp-http -- --port 8080 --log --} -module Main where - -import Control.Monad (when) -import Control.Monad.IO.Class (liftIO) -import Data.Text qualified as T -import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) -import Options.Applicative - -import MCP.Protocol hiding (CompletionResult) -import MCP.Protocol qualified as Protocol -import MCP.Server -import MCP.Server.Auth -import MCP.Server.HTTP -import MCP.Types - --- | Command line options -data Options = Options - { optPort :: Int - , optEnableLogging :: Bool - , optEnableOAuth :: Bool - } - deriving (Show) - --- | Parser for command line options -optionsParser :: Parser Options -optionsParser = - Options - <$> option - auto - ( long "port" - <> short 'p' - <> metavar "PORT" - <> Options.Applicative.value 8080 - <> help "Port to run the HTTP server on (default: 8080)" - ) - <*> switch - ( long "log" - <> short 'l' - <> help "Enable request/response logging" - ) - <*> switch - ( long "oauth" - <> short 'o' - <> help "Enable OAuth authentication (demo mode)" - ) - --- | Full parser with help -opts :: ParserInfo Options -opts = - info - (optionsParser <**> helper) - ( fullDesc - <> progDesc "Run an MCP server over HTTP transport" - <> header "mcp-http - HTTP MCP Server Example" - ) - --- | Example MCP Server implementation (copied from Main.hs) -instance MCPServer MCPServerM where - handleListResources _params = do - return $ ListResourcesResult{resources = [], nextCursor = Nothing, _meta = Nothing} - - handleReadResource _params = do - let textContent = TextResourceContents{uri = "example://hello", text = "Hello from MCP Haskell HTTP server!", mimeType = Just "text/plain"} - let content = TextResource textContent - return $ ReadResourceResult{contents = [content], _meta = Nothing} - - handleListResourceTemplates _params = do - return $ ListResourceTemplatesResult{resourceTemplates = [], nextCursor = Nothing, _meta = Nothing} - - handleListPrompts _params = do - return $ ListPromptsResult{prompts = [], nextCursor = Nothing, _meta = Nothing} - - handleGetPrompt _params = do - let textContent = TextContent{text = "Hello HTTP prompt!", textType = "text", annotations = Nothing} - let content = TextContentType textContent - let message = PromptMessage{role = User, content = content} - return $ GetPromptResult{messages = [message], description = Nothing, _meta = Nothing} - - handleListTools _params = do - let getCurrentDateTool = - Tool - { name = "getCurrentDate" - , description = Just "Get the current date and time via HTTP" - , inputSchema = InputSchema "object" Nothing Nothing - , annotations = Nothing - } - return $ ListToolsResult{tools = [getCurrentDateTool], nextCursor = Nothing, _meta = Nothing} - - handleCallTool CallToolParams{name = toolName} = do - case toolName of - "getCurrentDate" -> do - currentTime <- liftIO getCurrentTime - let dateStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC (via HTTP)" currentTime - let textContent = TextContent{text = T.pack dateStr, textType = "text", annotations = Nothing} - let content = TextContentType textContent - return $ CallToolResult{content = [content], isError = Nothing, _meta = Nothing} - _ -> do - let textContent = TextContent{text = "Tool not found", textType = "text", annotations = Nothing} - let content = TextContentType textContent - return $ CallToolResult{content = [content], isError = Just True, _meta = Nothing} - - handleComplete _params = do - let completionResult = Protocol.CompletionResult{values = [], total = Nothing, hasMore = Just True} - return $ CompleteResult{completion = completionResult, _meta = Nothing} - - handleSetLevel _params = do - liftIO $ putStrLn "Log level set via HTTP" - -main :: IO () -main = do - Options{..} <- execParser opts - - putStrLn "Starting MCP Haskell HTTP Server..." - putStrLn $ "Port: " ++ show optPort - when optEnableLogging $ putStrLn "Request/Response logging: enabled" - - let serverInfo = - Implementation - { name = "mcp-haskell-http-example" - , version = "0.1.0" - } - - let resourcesCap = - ResourcesCapability - { subscribe = Just False - , listChanged = Just False - } - let promptsCap = - PromptsCapability - { listChanged = Just False - } - let toolsCap = - ToolsCapability - { listChanged = Just False - } - - let capabilities = - ServerCapabilities - { resources = Just resourcesCap - , prompts = Just promptsCap - , tools = Just toolsCap - , completions = Nothing - , logging = Nothing - , experimental = Nothing - } - - let baseUrl = T.pack $ "http://localhost:" ++ show optPort - oauthConfig = - if optEnableOAuth - then - Just $ - defaultDemoOAuthConfig - { oauthProviders = - [ OAuthProvider - { providerName = "demo" - , clientId = "demo-client" - , clientSecret = Just "demo-secret" - , authorizationEndpoint = baseUrl <> "/authorize" - , tokenEndpoint = baseUrl <> "/token" - , userInfoEndpoint = Nothing - , scopes = ["mcp:read", "mcp:write"] - , grantTypes = [AuthorizationCode] - , requiresPKCE = True -- MCP requires PKCE - , metadataEndpoint = Nothing - } - ] - , -- Override demo defaults for example - authCodeExpirySeconds = 600 -- 10 minutes - , accessTokenExpirySeconds = 3600 -- 1 hour - , demoUserIdTemplate = Just "demo-user-{clientId}" - , demoEmailDomain = "demo.example.com" - , demoUserName = "Demo User" - , authorizationSuccessTemplate = - Just $ - "Demo Authorization Successful!\n\n" - <> "Redirect to: {redirectUri}?code={code}{state}\n\n" - <> "This is a demo server. In production, this would redirect automatically." - } - else Nothing - - let config = - HTTPServerConfig - { httpPort = optPort - , httpBaseUrl = baseUrl -- Configurable base URL - , httpServerInfo = serverInfo - , httpCapabilities = capabilities - , httpEnableLogging = optEnableLogging - , httpOAuthConfig = oauthConfig - , httpJWK = Nothing -- Will be auto-generated - , httpProtocolVersion = "2024-11-05" -- Configurable protocol version - } - - putStrLn $ "HTTP server configured, starting on port " ++ show optPort ++ "..." - putStrLn $ "MCP endpoint available at: POST " ++ T.unpack baseUrl ++ "/mcp" - - if optEnableOAuth - then do - putStrLn "" - putStrLn "OAuth Demo Flow:" - putStrLn "1. Generate PKCE code verifier and challenge" - putStrLn "2. Open authorization URL in browser:" - putStrLn $ " " ++ T.unpack baseUrl ++ "/authorize?response_type=code&client_id=demo-client&redirect_uri=http://localhost:3000/callback&code_challenge=YOUR_CHALLENGE&code_challenge_method=S256&scope=mcp:read%20mcp:write" - putStrLn "3. Exchange authorization code for token:" - putStrLn $ " curl -X POST " ++ T.unpack baseUrl ++ "/token \\" - putStrLn " -H \"Content-Type: application/x-www-form-urlencoded\" \\" - putStrLn " -d \"grant_type=authorization_code&code=AUTH_CODE&code_verifier=YOUR_VERIFIER\"" - putStrLn "4. Use access token for MCP requests:" - putStrLn $ " curl -X POST " ++ T.unpack baseUrl ++ "/mcp \\" - putStrLn " -H \"Authorization: Bearer ACCESS_TOKEN\" \\" - putStrLn " -H \"Content-Type: application/json\" \\" - putStrLn " -d '{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"ping\"}'" - else do - putStrLn "" - putStrLn "Example test command:" - putStrLn $ "curl -X POST " ++ T.unpack baseUrl ++ "/mcp \\" - putStrLn " -H \"Content-Type: application/json\" \\" - putStrLn " -d '{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"ping\"}'" - - putStrLn "" - - runServerHTTP config diff --git a/mcp.cabal b/mcp.cabal --- a/mcp.cabal +++ b/mcp.cabal @@ -1,220 +1,131 @@ -cabal-version: 3.4 --- The cabal-version field refers to the version of the .cabal specification, --- and can be different from the cabal-install (the tool) version and the --- Cabal (the library) version you are using. As such, the Cabal (the library) --- version used must be equal or greater than the version stated in this field. --- Starting from the specification version 2.2, the cabal-version field must be --- the first thing in the cabal file. - --- Initial package description 'mcp' generated by --- 'cabal init'. For further documentation, see: --- http://haskell.org/cabal/users-guide/ --- --- The name of the package. -name: mcp - --- The package version. --- See the Haskell package versioning policy (PVP) for standards --- guiding when and how versions should be incremented. --- https://pvp.haskell.org --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.2.0.1 - --- A short (one-line) description of the package. -synopsis: A Haskell implementation of the Model Context Protocol (MCP) - --- A longer description of the package. -description: - This library provides a complete implementation of the Model Context Protocol (MCP) - for Haskell. MCP is a protocol that enables seamless communication between AI models - and external tools, resources, and services. This implementation includes support for - resources, tools, prompts, and all standard MCP message types. It provides both a - server framework and type definitions for building MCP-compliant applications. - . - Features dual transport support: - . - * StdIO transport for process-based clients (e.g., Claude Desktop) - * HTTP transport following the official MCP specification for web-based integration, - and supports OAuth authentication. - . - Both transports use the same MCPServer typeclass, allowing seamless switching between - communication methods while maintaining identical server logic. - Supports version 2025-03-26 of the MCP protocol. - --- The license under which the package is released. -license: MIT - --- The file containing the license text. -license-file: LICENSE - --- The package author(s). -author: Matthias Pall Gissurarson - --- An email address to which users can send suggestions, bug reports, and patches. -maintainer: mpg@mpg.is - --- A copyright notice. --- copyright: -category: Network -build-type: Simple +cabal-version: 2.2 +name: mcp +version: 0.3.0.1 +license: MPL-2.0 +license-file: LICENSE +copyright: (c) 2025 DPella AB +author: DPella AB +tested-with: ghc ==9.12.2 +extra-doc-files: + CHANGELOG.md + README.md --- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. -extra-doc-files: CHANGELOG.md +maintainer: + matti@dpella.io, + lobo@dpella.io --- Extra source files to be distributed with the package, such as examples, or a tutorial module. -extra-source-files: - examples/README.md - examples/http-server.hs - examples/claude-desktop-config.json - examples/full-config-example.json +synopsis: A Servant-based Model Context Protocol (MCP) server for Haskell +description: + This library provides a complete server implementation of the Model Context + Protocol (MCP) for Haskell, built on Servant with JWT authentication via + @servant-auth-server@. It re-exports the core protocol types from + @mcp-types@ for convenience. + . + MCP is a protocol that enables seamless communication between AI models and + external tools, resources, and services. This implementation supports MCP + protocol version 2025-06-18 with full compatibility for resources, tools, + prompts, completions, elicitation, and all standard MCP message types. + . + The server uses HTTP transport with streaming SSE responses at the @/mcp@ + endpoint. An extensible handler framework (@ProcessHandlers@, @ToolHandler@) + allows implementing custom MCP servers with minimal boilerplate. -homepage: https://github.com/Tritlo/mcp +homepage: https://github.com/DPella/mcp +bug-reports: https://github.com/DPella/mcp/issues +category: Web, AI source-repository head - type: git - location: https://github.com/Tritlo/mcp.git - -common warnings - ghc-options: -Wall + type: git + location: https://github.com/DPella/mcp.git library - -- Import common warning flags. - import: warnings - - -- Modules exported by the library. - exposed-modules: - MCP.Types - MCP.Protocol - MCP.Server - MCP.Server.StdIO - MCP.Server.HTTP - MCP.Server.Auth - - -- Modules included in this library but not exported. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: - base ^>=4.18.2.1, - aeson >= 2.1 && < 2.3, - text >= 2.0 && < 2.1, - containers >= 0.6 && < 0.7, - bytestring >= 0.11 && < 0.12, - unordered-containers >= 0.2 && < 0.3, - stm >= 2.5 && < 2.6, - async >= 2.2 && < 2.3, - mtl >= 2.3 && < 2.4, - transformers >= 0.6 && < 0.7, - warp >= 3.3 && < 3.4, - wai >= 3.2 && < 3.3, - wai-extra >= 3.1 && < 3.2, - servant-server >= 0.19 && < 0.21, - servant >= 0.19 && < 0.21, - http-types >= 0.12 && < 0.13, - servant-auth >= 0.4 && < 0.5, - servant-auth-server >= 0.4 && < 0.5, - jose >= 0.10 && < 0.12, - cryptonite >= 0.30 && < 0.31, - memory >= 0.18 && < 0.19, - base64-bytestring >= 1.2 && < 1.3, - http-conduit >= 2.3 && < 2.4, - random >= 1.2 && < 1.3, - time >= 1.12 && < 1.13, - uuid >= 1.3 && < 1.4 - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: GHC2021 - -executable mcp - -- Import common warning flags. - import: warnings - - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: - base ^>=4.18.2.1, - mcp, - aeson >= 2.1 && < 2.3, - text >= 2.0 && < 2.1, - containers >= 0.6 && < 0.7, - scientific >= 0.3 && < 0.4, - time >= 1.12 && < 1.13 - - -- Directories containing source files. - hs-source-dirs: app - - -- Base language which the package is written in. - default-language: GHC2021 - -executable mcp-http - -- Import common warning flags. - import: warnings - - -- .hs or .lhs file containing the Main module. - main-is: http-server.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: - base ^>=4.18.2.1, - mcp, - aeson >= 2.1 && < 2.3, - text >= 2.0 && < 2.1, - containers >= 0.6 && < 0.7, - scientific >= 0.3 && < 0.4, - time >= 1.12 && < 1.13, - optparse-applicative >= 0.17 && < 0.19 + default-language: + Haskell2010 - -- Directories containing source files. - hs-source-dirs: examples + default-extensions: + DataKinds + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + OverloadedStrings + PolyKinds + RankNTypes + TypeApplications + TypeFamilies - -- Base language which the package is written in. - default-language: GHC2021 + hs-source-dirs: + src -test-suite mcp-test - -- Import common warning flags. - import: warnings + exposed-modules: + MCP.Server + MCP.Server.Common + MCP.Server.HTTP + MCP.Server.Stdio - -- Base language which the package is written in. - default-language: GHC2021 + build-depends: + aeson >=2.1 && <2.3, + base >=4.18 && <4.22, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.8, + http-media >=0.8 && <0.9, + mcp-types >=0.1.0 && <0.2, + mtl >=2.2 && <2.4, + servant >=0.19 && <0.21, + servant-auth-server >=0.4 && <0.5, + servant-server >=0.19 && <0.21, + text >=2.0 && <2.2, + time >=1.12 && <1.15, - -- Modules included in this executable, other than Main. - -- other-modules: +test-suite test-mcp + type: exitcode-stdio-1.0 + default-language: + Haskell2010 - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: + default-extensions: + DataKinds + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + OverloadedStrings + PolyKinds + RankNTypes + TypeApplications - -- The interface type and version of the test suite. - type: exitcode-stdio-1.0 + hs-source-dirs: + test - -- Directories containing source files. - hs-source-dirs: test + main-is: + Main.hs - -- The entrypoint to the test suite. - main-is: Main.hs + other-modules: + MCP.Integration + MCP.StdioIntegration + MCP.TestServer + MCP.TestUtils - -- Test dependencies. - build-depends: - base ^>=4.18.2.1, - mcp + build-depends: + aeson >=2.1 && <2.3, + attoparsec >=0.14 && <0.15, + base >=4.18 && <4.22, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.8, + hspec >=2.10 && <2.12, + hspec-wai >=0.11 && <0.12, + http-types >=0.12 && <0.13, + jose >=0.10 && <0.12, + mcp, + mcp-types >=0.1.0 && <0.2, + mtl >=2.2 && <2.4, + process >=1.6 && <1.8, + servant >=0.19 && <0.21, + servant-auth-server >=0.4 && <0.5, + servant-server >=0.19 && <0.21, + text >=2.0 && <2.2, + time >=1.12 && <1.15, + wai >=3.2 && <3.3, + wai-extra >=3.1 && <3.2, + wai-test >=3.0 && <3.1, diff --git a/src/MCP/Protocol.hs b/src/MCP/Protocol.hs deleted file mode 100644 --- a/src/MCP/Protocol.hs +++ /dev/null @@ -1,1132 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use newtype instead of data" #-} - -{- | -Module : MCP.Protocol -Description : JSON-RPC protocol implementation for MCP -Copyright : (C) 2025 Matthias Pall Gissurarson -License : MIT -Maintainer : mpg@mpg.is -Stability : experimental -Portability : GHC - -This module implements the JSON-RPC 2.0 protocol layer for MCP, -including request/response handling, message parsing and encoding, -and protocol-level error handling. --} -module MCP.Protocol ( - -- * JSON-RPC Types - JSONRPCRequest (..), - JSONRPCResponse (..), - JSONRPCError (..), - JSONRPCNotification (..), - JSONRPCMessage (..), - JSONRPCErrorInfo (..), - - -- * Client Request Types - InitializeRequest (..), - InitializeParams (..), - PingRequest (..), - PingParams (..), - ListResourcesRequest (..), - ListResourcesParams (..), - ListResourceTemplatesRequest (..), - ListResourceTemplatesParams (..), - ReadResourceRequest (..), - ReadResourceParams (..), - SubscribeRequest (..), - SubscribeParams (..), - UnsubscribeRequest (..), - UnsubscribeParams (..), - ListPromptsRequest (..), - ListPromptsParams (..), - GetPromptRequest (..), - GetPromptParams (..), - ListToolsRequest (..), - ListToolsParams (..), - CallToolRequest (..), - CallToolParams (..), - SetLevelRequest (..), - SetLevelParams (..), - CompleteRequest (..), - CompleteParams (..), - CompletionArgument (..), - Reference (..), - - -- * Server Request Types - CreateMessageRequest (..), - CreateMessageParams (..), - ListRootsRequest (..), - ListRootsParams (..), - - -- * Response Types - InitializeResult (..), - ListResourcesResult (..), - ListResourceTemplatesResult (..), - ReadResourceResult (..), - ListPromptsResult (..), - GetPromptResult (..), - ListToolsResult (..), - CallToolResult (..), - CompleteResult (..), - CompletionResult (..), - CreateMessageResult (..), - ListRootsResult (..), - - -- * Notification Types - CancelledNotification (..), - CancelledParams (..), - InitializedNotification (..), - InitializedParams (..), - ProgressNotification (..), - ProgressParams (..), - ResourceListChangedNotification (..), - ResourceUpdatedNotification (..), - ResourceUpdatedParams (..), - PromptListChangedNotification (..), - ToolListChangedNotification (..), - LoggingMessageNotification (..), - LoggingMessageParams (..), - RootsListChangedNotification (..), - - -- * Union Types - ClientRequest (..), - ServerRequest (..), - ClientNotification (..), - ServerNotification (..), -) where - -import Control.Applicative ((<|>)) -import Data.Aeson -import Data.Aeson.TH -import Data.Map (Map) -import Data.Text (Text) -import GHC.Generics - -import MCP.Types - --- * JSON-RPC Types - --- | JSON-RPC error information -data JSONRPCErrorInfo = JSONRPCErrorInfo - { code :: Int - , message :: Text - , errorData :: Maybe Value - } - deriving stock (Show, Eq, Generic) - -instance ToJSON JSONRPCErrorInfo where - toJSON (JSONRPCErrorInfo c m d) = - object $ - [ "code" .= c - , "message" .= m - ] - ++ maybe [] (\ed -> ["data" .= ed]) d - -instance FromJSON JSONRPCErrorInfo where - parseJSON = withObject "JSONRPCErrorInfo" $ \o -> - JSONRPCErrorInfo <$> o .: "code" <*> o .: "message" <*> o .:? "data" - --- | A JSON-RPC request that expects a response -data JSONRPCRequest = JSONRPCRequest - { jsonrpc :: Text -- Always "2.0" - , id :: RequestId - , method :: Text - , params :: Maybe Value - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''JSONRPCRequest) - --- | A successful JSON-RPC response -data JSONRPCResponse = JSONRPCResponse - { jsonrpc :: Text -- Always "2.0" - , id :: RequestId - , result :: Value - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''JSONRPCResponse) - --- | A JSON-RPC error response -data JSONRPCError = JSONRPCError - { jsonrpc :: Text -- Always "2.0" - , id :: RequestId - , error :: JSONRPCErrorInfo - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''JSONRPCError) - --- | A JSON-RPC notification (no response expected) -data JSONRPCNotification = JSONRPCNotification - { jsonrpc :: Text -- Always "2.0" - , method :: Text - , params :: Maybe Value - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''JSONRPCNotification) - --- | Any JSON-RPC message -data JSONRPCMessage - = RequestMessage JSONRPCRequest - | ResponseMessage JSONRPCResponse - | ErrorMessage JSONRPCError - | NotificationMessage JSONRPCNotification - deriving stock (Show, Eq, Generic) - -instance ToJSON JSONRPCMessage where - toJSON (RequestMessage r) = toJSON r - toJSON (ResponseMessage r) = toJSON r - toJSON (ErrorMessage e) = toJSON e - toJSON (NotificationMessage n) = toJSON n - -instance FromJSON JSONRPCMessage where - parseJSON v = - (RequestMessage <$> parseJSON v) - <|> (ResponseMessage <$> parseJSON v) - <|> (ErrorMessage <$> parseJSON v) - <|> (NotificationMessage <$> parseJSON v) - --- * Client Request Types - --- | Initialize request parameters -data InitializeParams = InitializeParams - { protocolVersion :: Text - , capabilities :: ClientCapabilities - , clientInfo :: Implementation - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''InitializeParams) - --- | Initialize request -data InitializeRequest = InitializeRequest - { method :: Text -- Always "initialize" - , params :: InitializeParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON InitializeRequest where - toJSON (InitializeRequest _ p) = - object - [ "method" .= ("initialize" :: Text) - , "params" .= p - ] - -instance FromJSON InitializeRequest where - parseJSON = withObject "InitializeRequest" $ \o -> do - m <- o .: "method" - if m == ("initialize" :: Text) - then InitializeRequest m <$> o .: "params" - else fail "Expected method 'initialize'" - --- | Ping request parameters -data PingParams where - PingParams :: {_meta :: Maybe Metadata} -> PingParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''PingParams) - --- | Ping request -data PingRequest = PingRequest - { method :: Text -- Always "ping" - , params :: Maybe PingParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON PingRequest where - toJSON (PingRequest _ p) = - object $ - ("method" .= ("ping" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON PingRequest where - parseJSON = withObject "PingRequest" $ \o -> do - m <- o .: "method" - if m == ("ping" :: Text) - then PingRequest m <$> o .:? "params" - else fail "Expected method 'ping'" - --- | List resources request parameters -data ListResourcesParams where - ListResourcesParams :: - {cursor :: Maybe Cursor} -> - ListResourcesParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ListResourcesParams) - --- | List resources request -data ListResourcesRequest = ListResourcesRequest - { method :: Text -- Always "resources/list" - , params :: Maybe ListResourcesParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ListResourcesRequest where - toJSON (ListResourcesRequest _ p) = - object $ - ("method" .= ("resources/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON ListResourcesRequest where - parseJSON = withObject "ListResourcesRequest" $ \o -> do - m <- o .: "method" - if m == ("resources/list" :: Text) - then ListResourcesRequest m <$> o .:? "params" - else fail "Expected method 'resources/list'" - --- | List resource templates request parameters -data ListResourceTemplatesParams where - ListResourceTemplatesParams :: - {cursor :: Maybe Cursor} -> - ListResourceTemplatesParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ListResourceTemplatesParams) - --- | List resource templates request -data ListResourceTemplatesRequest = ListResourceTemplatesRequest - { method :: Text -- Always "resources/templates/list" - , params :: Maybe ListResourceTemplatesParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ListResourceTemplatesRequest where - toJSON (ListResourceTemplatesRequest _ p) = - object $ - ("method" .= ("resources/templates/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON ListResourceTemplatesRequest where - parseJSON = withObject "ListResourceTemplatesRequest" $ \o -> do - m <- o .: "method" - if m == ("resources/templates/list" :: Text) - then ListResourceTemplatesRequest m <$> o .:? "params" - else fail "Expected method 'resources/templates/list'" - --- | Read resource request parameters -data ReadResourceParams where - ReadResourceParams :: {uri :: Text} -> ReadResourceParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''ReadResourceParams) - --- | Read resource request -data ReadResourceRequest = ReadResourceRequest - { method :: Text -- Always "resources/read" - , params :: ReadResourceParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ReadResourceRequest where - toJSON (ReadResourceRequest _ p) = - object - [ "method" .= ("resources/read" :: Text) - , "params" .= p - ] - -instance FromJSON ReadResourceRequest where - parseJSON = withObject "ReadResourceRequest" $ \o -> do - m <- o .: "method" - if m == ("resources/read" :: Text) - then ReadResourceRequest m <$> o .: "params" - else fail "Expected method 'resources/read'" - --- | Subscribe request parameters -data SubscribeParams where - SubscribeParams :: {uri :: Text} -> SubscribeParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''SubscribeParams) - --- | Subscribe request -data SubscribeRequest = SubscribeRequest - { method :: Text -- Always "resources/subscribe" - , params :: SubscribeParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON SubscribeRequest where - toJSON (SubscribeRequest _ p) = - object - [ "method" .= ("resources/subscribe" :: Text) - , "params" .= p - ] - -instance FromJSON SubscribeRequest where - parseJSON = withObject "SubscribeRequest" $ \o -> do - m <- o .: "method" - if m == ("resources/subscribe" :: Text) - then SubscribeRequest m <$> o .: "params" - else fail "Expected method 'resources/subscribe'" - --- | Unsubscribe request parameters -data UnsubscribeParams where - UnsubscribeParams :: {uri :: Text} -> UnsubscribeParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''UnsubscribeParams) - --- | Unsubscribe request -data UnsubscribeRequest = UnsubscribeRequest - { method :: Text -- Always "resources/unsubscribe" - , params :: UnsubscribeParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON UnsubscribeRequest where - toJSON (UnsubscribeRequest _ p) = - object - [ "method" .= ("resources/unsubscribe" :: Text) - , "params" .= p - ] - -instance FromJSON UnsubscribeRequest where - parseJSON = withObject "UnsubscribeRequest" $ \o -> do - m <- o .: "method" - if m == ("resources/unsubscribe" :: Text) - then UnsubscribeRequest m <$> o .: "params" - else fail "Expected method 'resources/unsubscribe'" - --- | List prompts request parameters -data ListPromptsParams where - ListPromptsParams :: {cursor :: Maybe Cursor} -> ListPromptsParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ListPromptsParams) - --- | List prompts request -data ListPromptsRequest = ListPromptsRequest - { method :: Text -- Always "prompts/list" - , params :: Maybe ListPromptsParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ListPromptsRequest where - toJSON (ListPromptsRequest _ p) = - object $ - ("method" .= ("prompts/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON ListPromptsRequest where - parseJSON = withObject "ListPromptsRequest" $ \o -> do - m <- o .: "method" - if m == ("prompts/list" :: Text) - then ListPromptsRequest m <$> o .:? "params" - else fail "Expected method 'prompts/list'" - --- | Get prompt request parameters -data GetPromptParams = GetPromptParams - { name :: Text - , arguments :: Maybe (Map Text Text) - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''GetPromptParams) - --- | Get prompt request -data GetPromptRequest = GetPromptRequest - { method :: Text -- Always "prompts/get" - , params :: GetPromptParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON GetPromptRequest where - toJSON (GetPromptRequest _ p) = - object - [ "method" .= ("prompts/get" :: Text) - , "params" .= p - ] - -instance FromJSON GetPromptRequest where - parseJSON = withObject "GetPromptRequest" $ \o -> do - m <- o .: "method" - if m == ("prompts/get" :: Text) - then GetPromptRequest m <$> o .: "params" - else fail "Expected method 'prompts/get'" - --- | List tools request parameters -data ListToolsParams where - ListToolsParams :: {cursor :: Maybe Cursor} -> ListToolsParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ListToolsParams) - --- | List tools request -data ListToolsRequest = ListToolsRequest - { method :: Text -- Always "tools/list" - , params :: Maybe ListToolsParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ListToolsRequest where - toJSON (ListToolsRequest _ p) = - object $ - ("method" .= ("tools/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON ListToolsRequest where - parseJSON = withObject "ListToolsRequest" $ \o -> do - m <- o .: "method" - if m == ("tools/list" :: Text) - then ListToolsRequest m <$> o .:? "params" - else fail "Expected method 'tools/list'" - --- | Call tool request parameters -data CallToolParams = CallToolParams - { name :: Text - , arguments :: Maybe (Map Text Value) - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''CallToolParams) - --- | Call tool request -data CallToolRequest = CallToolRequest - { method :: Text -- Always "tools/call" - , params :: CallToolParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON CallToolRequest where - toJSON (CallToolRequest _ p) = - object - [ "method" .= ("tools/call" :: Text) - , "params" .= p - ] - -instance FromJSON CallToolRequest where - parseJSON = withObject "CallToolRequest" $ \o -> do - m <- o .: "method" - if m == ("tools/call" :: Text) - then CallToolRequest m <$> o .: "params" - else fail "Expected method 'tools/call'" - --- | Set level request parameters -data SetLevelParams where - SetLevelParams :: {level :: LoggingLevel} -> SetLevelParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''SetLevelParams) - --- | Set level request -data SetLevelRequest = SetLevelRequest - { method :: Text -- Always "logging/setLevel" - , params :: SetLevelParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON SetLevelRequest where - toJSON (SetLevelRequest _ p) = - object - [ "method" .= ("logging/setLevel" :: Text) - , "params" .= p - ] - -instance FromJSON SetLevelRequest where - parseJSON = withObject "SetLevelRequest" $ \o -> do - m <- o .: "method" - if m == ("logging/setLevel" :: Text) - then SetLevelRequest m <$> o .: "params" - else fail "Expected method 'logging/setLevel'" - --- | Completion argument -data CompletionArgument = CompletionArgument - { name :: Text - , value :: Text - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''CompletionArgument) - --- | Reference (prompt or resource) -data Reference - = PromptRef PromptReference - | ResourceRef ResourceReference - deriving stock (Show, Eq, Generic) - -instance ToJSON Reference where - toJSON (PromptRef p) = toJSON p - toJSON (ResourceRef r) = toJSON r - -instance FromJSON Reference where - parseJSON v = - (PromptRef <$> parseJSON v) - <|> (ResourceRef <$> parseJSON v) - --- | Complete request parameters -data CompleteParams = CompleteParams - { ref :: Reference - , argument :: CompletionArgument - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''CompleteParams) - --- | Complete request -data CompleteRequest = CompleteRequest - { method :: Text -- Always "completion/complete" - , params :: CompleteParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON CompleteRequest where - toJSON (CompleteRequest _ p) = - object - [ "method" .= ("completion/complete" :: Text) - , "params" .= p - ] - -instance FromJSON CompleteRequest where - parseJSON = withObject "CompleteRequest" $ \o -> do - m <- o .: "method" - if m == ("completion/complete" :: Text) - then CompleteRequest m <$> o .: "params" - else fail "Expected method 'completion/complete'" - --- * Server Request Types - --- | Create message request parameters -data CreateMessageParams = CreateMessageParams - { maxTokens :: Int - , messages :: [SamplingMessage] - , modelPreferences :: Maybe ModelPreferences - , systemPrompt :: Maybe Text - , includeContext :: Maybe IncludeContext - , temperature :: Maybe Double - , stopSequences :: Maybe [Text] - , metadata :: Maybe (Map Text Value) - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''CreateMessageParams) - --- | Create message request -data CreateMessageRequest = CreateMessageRequest - { method :: Text -- Always "sampling/createMessage" - , params :: CreateMessageParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON CreateMessageRequest where - toJSON (CreateMessageRequest _ p) = - object - [ "method" .= ("sampling/createMessage" :: Text) - , "params" .= p - ] - -instance FromJSON CreateMessageRequest where - parseJSON = withObject "CreateMessageRequest" $ \o -> do - m <- o .: "method" - if m == ("sampling/createMessage" :: Text) - then CreateMessageRequest m <$> o .: "params" - else fail "Expected method 'sampling/createMessage'" - --- | List roots request parameters -data ListRootsParams where - ListRootsParams :: {_meta :: Maybe Metadata} -> ListRootsParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListRootsParams) - --- | List roots request -data ListRootsRequest = ListRootsRequest - { method :: Text -- Always "roots/list" - , params :: Maybe ListRootsParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ListRootsRequest where - toJSON (ListRootsRequest _ p) = - object $ - ("method" .= ("roots/list" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON ListRootsRequest where - parseJSON = withObject "ListRootsRequest" $ \o -> do - m <- o .: "method" - if m == ("roots/list" :: Text) - then ListRootsRequest m <$> o .:? "params" - else fail "Expected method 'roots/list'" - --- * Response Types - --- | Initialize result -data InitializeResult = InitializeResult - { protocolVersion :: Text - , capabilities :: ServerCapabilities - , serverInfo :: Implementation - , instructions :: Maybe Text - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''InitializeResult) - --- | List resources result -data ListResourcesResult = ListResourcesResult - { resources :: [Resource] - , nextCursor :: Maybe Cursor - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListResourcesResult) - --- | List resource templates result -data ListResourceTemplatesResult = ListResourceTemplatesResult - { resourceTemplates :: [ResourceTemplate] - , nextCursor :: Maybe Cursor - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListResourceTemplatesResult) - --- | Read resource result -data ReadResourceResult = ReadResourceResult - { contents :: [ResourceContents] - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ReadResourceResult) - --- | List prompts result -data ListPromptsResult = ListPromptsResult - { prompts :: [Prompt] - , nextCursor :: Maybe Cursor - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListPromptsResult) - --- | Get prompt result -data GetPromptResult = GetPromptResult - { description :: Maybe Text - , messages :: [PromptMessage] - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''GetPromptResult) - --- | List tools result -data ListToolsResult = ListToolsResult - { tools :: [Tool] - , nextCursor :: Maybe Cursor - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListToolsResult) - --- | Call tool result -data CallToolResult = CallToolResult - { content :: [Content] - , isError :: Maybe Bool - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''CallToolResult) - --- | Completion result inner type -data CompletionResult = CompletionResult - { values :: [Text] - , total :: Maybe Int - , hasMore :: Maybe Bool - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''CompletionResult) - --- | Complete result -data CompleteResult = CompleteResult - { completion :: CompletionResult - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''CompleteResult) - --- | Create message result -data CreateMessageResult = CreateMessageResult - { role :: Role - , content :: Content - , model :: Text - , stopReason :: Maybe Text - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''CreateMessageResult) - --- | List roots result -data ListRootsResult = ListRootsResult - { roots :: [Root] - , _meta :: Maybe Metadata - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListRootsResult) - --- * Notification Types - --- | Cancelled notification parameters -data CancelledParams = CancelledParams - { requestId :: RequestId - , reason :: Maybe Text - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''CancelledParams) - --- | Cancelled notification -data CancelledNotification = CancelledNotification - { method :: Text -- Always "notifications/cancelled" - , params :: CancelledParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON CancelledNotification where - toJSON (CancelledNotification _ p) = - object - [ "method" .= ("notifications/cancelled" :: Text) - , "params" .= p - ] - -instance FromJSON CancelledNotification where - parseJSON = withObject "CancelledNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/cancelled" :: Text) - then CancelledNotification m <$> o .: "params" - else fail "Expected method 'notifications/cancelled'" - --- | Initialized notification parameters -data InitializedParams where - InitializedParams :: {_meta :: Maybe Metadata} -> InitializedParams - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''InitializedParams) - --- | Initialized notification -data InitializedNotification = InitializedNotification - { method :: Text -- Always "notifications/initialized" - , params :: Maybe InitializedParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON InitializedNotification where - toJSON (InitializedNotification _ p) = - object $ - ("method" .= ("notifications/initialized" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON InitializedNotification where - parseJSON = withObject "InitializedNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/initialized" :: Text) - then InitializedNotification m <$> o .:? "params" - else fail "Expected method 'notifications/initialized'" - --- | Progress notification parameters -data ProgressParams = ProgressParams - { progressToken :: ProgressToken - , progress :: Double - , total :: Maybe Double - , message :: Maybe Text - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ProgressParams) - --- | Progress notification -data ProgressNotification = ProgressNotification - { method :: Text -- Always "notifications/progress" - , params :: ProgressParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ProgressNotification where - toJSON (ProgressNotification _ p) = - object - [ "method" .= ("notifications/progress" :: Text) - , "params" .= p - ] - -instance FromJSON ProgressNotification where - parseJSON = withObject "ProgressNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/progress" :: Text) - then ProgressNotification m <$> o .: "params" - else fail "Expected method 'notifications/progress'" - --- | Resource list changed notification -data ResourceListChangedNotification = ResourceListChangedNotification - { method :: Text -- Always "notifications/resources/list_changed" - , params :: Maybe InitializedParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ResourceListChangedNotification where - toJSON (ResourceListChangedNotification _ p) = - object $ - ("method" .= ("notifications/resources/list_changed" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON ResourceListChangedNotification where - parseJSON = withObject "ResourceListChangedNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/resources/list_changed" :: Text) - then ResourceListChangedNotification m <$> o .:? "params" - else fail "Expected method 'notifications/resources/list_changed'" - --- | Resource updated notification parameters -data ResourceUpdatedParams = ResourceUpdatedParams - { uri :: Text - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''ResourceUpdatedParams) - --- | Resource updated notification -data ResourceUpdatedNotification = ResourceUpdatedNotification - { method :: Text -- Always "notifications/resources/updated" - , params :: ResourceUpdatedParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ResourceUpdatedNotification where - toJSON (ResourceUpdatedNotification _ p) = - object - [ "method" .= ("notifications/resources/updated" :: Text) - , "params" .= p - ] - -instance FromJSON ResourceUpdatedNotification where - parseJSON = withObject "ResourceUpdatedNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/resources/updated" :: Text) - then ResourceUpdatedNotification m <$> o .: "params" - else fail "Expected method 'notifications/resources/updated'" - --- | Prompt list changed notification -data PromptListChangedNotification = PromptListChangedNotification - { method :: Text -- Always "notifications/prompts/list_changed" - , params :: Maybe InitializedParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON PromptListChangedNotification where - toJSON (PromptListChangedNotification _ p) = - object $ - ("method" .= ("notifications/prompts/list_changed" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON PromptListChangedNotification where - parseJSON = withObject "PromptListChangedNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/prompts/list_changed" :: Text) - then PromptListChangedNotification m <$> o .:? "params" - else fail "Expected method 'notifications/prompts/list_changed'" - --- | Tool list changed notification -data ToolListChangedNotification = ToolListChangedNotification - { method :: Text -- Always "notifications/tools/list_changed" - , params :: Maybe InitializedParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ToolListChangedNotification where - toJSON (ToolListChangedNotification _ p) = - object $ - ("method" .= ("notifications/tools/list_changed" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON ToolListChangedNotification where - parseJSON = withObject "ToolListChangedNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/tools/list_changed" :: Text) - then ToolListChangedNotification m <$> o .:? "params" - else fail "Expected method 'notifications/tools/list_changed'" - --- | Logging message notification parameters -data LoggingMessageParams = LoggingMessageParams - { level :: LoggingLevel - , data' :: Value -- Can be any JSON value - , logger :: Maybe Text - } - deriving stock (Show, Eq, Generic) - -instance ToJSON LoggingMessageParams where - toJSON (LoggingMessageParams lvl d lgr) = - object $ - [ "level" .= lvl - , "data" .= d - ] - ++ maybe [] (\l -> ["logger" .= l]) lgr - -instance FromJSON LoggingMessageParams where - parseJSON = withObject "LoggingMessageParams" $ \o -> - LoggingMessageParams <$> o .: "level" <*> o .: "data" <*> o .:? "logger" - --- | Logging message notification -data LoggingMessageNotification = LoggingMessageNotification - { method :: Text -- Always "notifications/message" - , params :: LoggingMessageParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON LoggingMessageNotification where - toJSON (LoggingMessageNotification _ p) = - object - [ "method" .= ("notifications/message" :: Text) - , "params" .= p - ] - -instance FromJSON LoggingMessageNotification where - parseJSON = withObject "LoggingMessageNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/message" :: Text) - then LoggingMessageNotification m <$> o .: "params" - else fail "Expected method 'notifications/message'" - --- | Roots list changed notification -data RootsListChangedNotification = RootsListChangedNotification - { method :: Text -- Always "notifications/roots/list_changed" - , params :: Maybe InitializedParams - } - deriving stock (Show, Eq, Generic) - -instance ToJSON RootsListChangedNotification where - toJSON (RootsListChangedNotification _ p) = - object $ - ("method" .= ("notifications/roots/list_changed" :: Text)) : maybe [] (\pr -> ["params" .= pr]) p - -instance FromJSON RootsListChangedNotification where - parseJSON = withObject "RootsListChangedNotification" $ \o -> do - m <- o .: "method" - if m == ("notifications/roots/list_changed" :: Text) - then RootsListChangedNotification m <$> o .:? "params" - else fail "Expected method 'notifications/roots/list_changed'" - --- * Union Types - --- | Any client request -data ClientRequest - = InitializeReq InitializeRequest - | PingReq PingRequest - | ListResourcesReq ListResourcesRequest - | ListResourceTemplatesReq ListResourceTemplatesRequest - | ReadResourceReq ReadResourceRequest - | SubscribeReq SubscribeRequest - | UnsubscribeReq UnsubscribeRequest - | ListPromptsReq ListPromptsRequest - | GetPromptReq GetPromptRequest - | ListToolsReq ListToolsRequest - | CallToolReq CallToolRequest - | SetLevelReq SetLevelRequest - | CompleteReq CompleteRequest - deriving stock (Show, Eq, Generic) - -instance ToJSON ClientRequest where - toJSON (InitializeReq r) = toJSON r - toJSON (PingReq r) = toJSON r - toJSON (ListResourcesReq r) = toJSON r - toJSON (ListResourceTemplatesReq r) = toJSON r - toJSON (ReadResourceReq r) = toJSON r - toJSON (SubscribeReq r) = toJSON r - toJSON (UnsubscribeReq r) = toJSON r - toJSON (ListPromptsReq r) = toJSON r - toJSON (GetPromptReq r) = toJSON r - toJSON (ListToolsReq r) = toJSON r - toJSON (CallToolReq r) = toJSON r - toJSON (SetLevelReq r) = toJSON r - toJSON (CompleteReq r) = toJSON r - -instance FromJSON ClientRequest where - parseJSON v = - (InitializeReq <$> parseJSON v) - <|> (PingReq <$> parseJSON v) - <|> (ListResourcesReq <$> parseJSON v) - <|> (ListResourceTemplatesReq <$> parseJSON v) - <|> (ReadResourceReq <$> parseJSON v) - <|> (SubscribeReq <$> parseJSON v) - <|> (UnsubscribeReq <$> parseJSON v) - <|> (ListPromptsReq <$> parseJSON v) - <|> (GetPromptReq <$> parseJSON v) - <|> (ListToolsReq <$> parseJSON v) - <|> (CallToolReq <$> parseJSON v) - <|> (SetLevelReq <$> parseJSON v) - <|> (CompleteReq <$> parseJSON v) - --- | Any server request -data ServerRequest - = PingServerReq PingRequest - | CreateMessageReq CreateMessageRequest - | ListRootsReq ListRootsRequest - deriving stock (Show, Eq, Generic) - -instance ToJSON ServerRequest where - toJSON (PingServerReq r) = toJSON r - toJSON (CreateMessageReq r) = toJSON r - toJSON (ListRootsReq r) = toJSON r - -instance FromJSON ServerRequest where - parseJSON v = - (PingServerReq <$> parseJSON v) - <|> (CreateMessageReq <$> parseJSON v) - <|> (ListRootsReq <$> parseJSON v) - --- | Any client notification -data ClientNotification - = CancelledNotif CancelledNotification - | InitializedNotif InitializedNotification - | ProgressNotif ProgressNotification - | RootsListChangedNotif RootsListChangedNotification - deriving stock (Show, Eq, Generic) - -instance ToJSON ClientNotification where - toJSON (CancelledNotif n) = toJSON n - toJSON (InitializedNotif n) = toJSON n - toJSON (ProgressNotif n) = toJSON n - toJSON (RootsListChangedNotif n) = toJSON n - -instance FromJSON ClientNotification where - parseJSON v = - (CancelledNotif <$> parseJSON v) - <|> (InitializedNotif <$> parseJSON v) - <|> (ProgressNotif <$> parseJSON v) - <|> (RootsListChangedNotif <$> parseJSON v) - --- | Any server notification -data ServerNotification - = CancelledServerNotif CancelledNotification - | ProgressServerNotif ProgressNotification - | ResourceListChangedNotif ResourceListChangedNotification - | ResourceUpdatedNotif ResourceUpdatedNotification - | PromptListChangedNotif PromptListChangedNotification - | ToolListChangedNotif ToolListChangedNotification - | LoggingMessageNotif LoggingMessageNotification - deriving stock (Show, Eq, Generic) - -instance ToJSON ServerNotification where - toJSON (CancelledServerNotif n) = toJSON n - toJSON (ProgressServerNotif n) = toJSON n - toJSON (ResourceListChangedNotif n) = toJSON n - toJSON (ResourceUpdatedNotif n) = toJSON n - toJSON (PromptListChangedNotif n) = toJSON n - toJSON (ToolListChangedNotif n) = toJSON n - toJSON (LoggingMessageNotif n) = toJSON n - -instance FromJSON ServerNotification where - parseJSON v = - (CancelledServerNotif <$> parseJSON v) - <|> (ProgressServerNotif <$> parseJSON v) - <|> (ResourceListChangedNotif <$> parseJSON v) - <|> (ResourceUpdatedNotif <$> parseJSON v) - <|> (PromptListChangedNotif <$> parseJSON v) - <|> (ToolListChangedNotif <$> parseJSON v) - <|> (LoggingMessageNotif <$> parseJSON v) diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -1,118 +1,23 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - {- | -Module : MCP.Server -Description : MCP server core types and interface -Copyright : (C) 2025 Matthias Pall Gissurarson -License : MIT -Maintainer : mpg@mpg.is -Stability : experimental -Portability : GHC - -This module provides the core types and interface for MCP server implementations. --} -module MCP.Server ( - -- * Server Interface - MCPServer (..), - ServerState (..), - ServerConfig (..), - MCPServerM, - runMCPServer, - initialServerState, - - -- * Utilities - sendResponse, - sendNotification, - sendError, -) where - -import Control.Monad.Except (ExceptT, runExceptT) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.State.Strict (StateT, runStateT) -import Data.Aeson (ToJSON, encode, toJSON) -import Data.ByteString.Lazy.Char8 qualified as LBSC -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Text (Text) -import System.IO (Handle, hFlush) - -import MCP.Protocol -import MCP.Types - --- | Server state tracking initialization, capabilities, and subscriptions -data ServerState = ServerState - { serverInitialized :: Bool - , serverCapabilities :: ServerCapabilities - , clientCapabilities :: Maybe ClientCapabilities - , serverInfo :: Maybe Implementation - , subscriptions :: Map Text () - } - deriving (Show) - --- | Configuration for running an MCP server -data ServerConfig = ServerConfig - { configInput :: Handle - , configOutput :: Handle - , configServerInfo :: Implementation - , configCapabilities :: ServerCapabilities - } - deriving (Show) +Module: MCP.Server +License: MPL-2.0 +Maintainer: , --- | The monad stack for MCP server operations -type MCPServerM = ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) +Model Context Protocol (MCP) server implementation. --- | Run an MCPServerM computation with the given config and initial state -runMCPServer :: ServerConfig -> ServerState -> MCPServerM a -> IO (Either Text (a, ServerState)) -runMCPServer config state action = runExceptT $ runStateT (runReaderT action config) state +This module re-exports everything from the transport-specific modules +for backwards compatibility. For finer-grained imports use: -{- | Create the initial server state with the given capabilities -The server starts uninitialized and must receive an 'initialize' request -before it can handle other requests. +* "MCP.Server.Common" — types, state, request routing, tool helpers +* "MCP.Server.HTTP" — Servant-based HTTP transport with JWT auth +* "MCP.Server.Stdio" — stdio transport -} -initialServerState :: ServerCapabilities -> ServerState -initialServerState caps = - ServerState - { serverInitialized = False - , serverCapabilities = caps - , clientCapabilities = Nothing - , serverInfo = Nothing - , subscriptions = Map.empty - } - --- | Type class for implementing MCP server handlers -class (Monad m) => MCPServer m where - handleListResources :: ListResourcesParams -> m ListResourcesResult - handleReadResource :: ReadResourceParams -> m ReadResourceResult - handleListResourceTemplates :: ListResourceTemplatesParams -> m ListResourceTemplatesResult - handleListPrompts :: ListPromptsParams -> m ListPromptsResult - handleGetPrompt :: GetPromptParams -> m GetPromptResult - handleListTools :: ListToolsParams -> m ListToolsResult - handleCallTool :: CallToolParams -> m CallToolResult - handleComplete :: CompleteParams -> m CompleteResult - handleSetLevel :: SetLevelParams -> m () - --- | Send a JSON-RPC response -sendResponse :: (MonadIO m, ToJSON a) => Handle -> RequestId -> a -> m () -sendResponse handle reqId result = liftIO $ do - let response = JSONRPCResponse "2.0" reqId (toJSON result) - LBSC.hPutStrLn handle (encode response) - hFlush handle - --- | Send a JSON-RPC error response -sendError :: (MonadIO m) => Handle -> RequestId -> JSONRPCErrorInfo -> m () -sendError handle reqId errorInfo = liftIO $ do - let response = JSONRPCError "2.0" reqId errorInfo - LBSC.hPutStrLn handle (encode response) - hFlush handle +module MCP.Server ( + module MCP.Server.Common, + module MCP.Server.HTTP, + module MCP.Server.Stdio, +) where --- | Send a JSON-RPC notification -sendNotification :: (MonadIO m, ToJSON a) => Handle -> Text -> a -> m () -sendNotification handle method params = liftIO $ do - let notification = JSONRPCNotification "2.0" method (Just (toJSON params)) - LBSC.hPutStrLn handle (encode notification) - hFlush handle +import MCP.Server.Common +import MCP.Server.HTTP +import MCP.Server.Stdio diff --git a/src/MCP/Server/Auth.hs b/src/MCP/Server/Auth.hs deleted file mode 100644 --- a/src/MCP/Server/Auth.hs +++ /dev/null @@ -1,307 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{- | -Module : MCP.Server.Auth -Description : MCP-compliant OAuth 2.1 authentication -Copyright : (C) 2025 Matthias Pall Gissurarson -License : MIT -Maintainer : mpg@mpg.is -Stability : experimental -Portability : GHC - -This module provides MCP-compliant OAuth 2.1 authentication with PKCE support. --} -module MCP.Server.Auth ( - -- * OAuth Configuration - OAuthConfig (..), - OAuthProvider (..), - OAuthGrantType (..), - - -- * Token Validation - TokenInfo (..), - validateBearerToken, - extractBearerToken, - - -- * PKCE Support - PKCEChallenge (..), - generateCodeVerifier, - generateCodeChallenge, - validateCodeVerifier, - - -- * Metadata Discovery - OAuthMetadata (..), - discoverOAuthMetadata, -) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Crypto.Hash (hashWith) -import Crypto.Hash.Algorithms (SHA256 (..)) -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson qualified as Aeson -import Data.ByteArray (convert) -import Data.ByteString (ByteString) -import Data.ByteString.Base64.URL qualified as B64URL -import Data.ByteString.Lazy qualified as LBS -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as TE -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import GHC.Generics (Generic) -import Network.HTTP.Simple (addRequestHeader, getResponseBody, httpJSON, parseRequest, setRequestBodyJSON, setRequestMethod) -import System.Random (newStdGen, randomRs) - --- | OAuth grant types supported by MCP -data OAuthGrantType - = AuthorizationCode -- For user-based scenarios - | ClientCredentials -- For application-to-application - deriving (Show, Eq, Generic) - --- | OAuth provider configuration (MCP-compliant) -data OAuthProvider = OAuthProvider - { providerName :: Text - , clientId :: Text - , clientSecret :: Maybe Text -- Optional for public clients - , authorizationEndpoint :: Text - , tokenEndpoint :: Text - , userInfoEndpoint :: Maybe Text - , scopes :: [Text] - , grantTypes :: [OAuthGrantType] - , requiresPKCE :: Bool -- MCP requires PKCE for all clients - , metadataEndpoint :: Maybe Text -- For OAuth metadata discovery - } - deriving (Show, Generic) - --- | OAuth configuration for the MCP server -data OAuthConfig = OAuthConfig - { oauthEnabled :: Bool - , oauthProviders :: [OAuthProvider] - , tokenValidationEndpoint :: Maybe Text -- For validating tokens - , requireHTTPS :: Bool -- MCP requires HTTPS for OAuth - -- Configurable timing parameters - , authCodeExpirySeconds :: Int - , accessTokenExpirySeconds :: Int - , -- Configurable OAuth parameters - supportedScopes :: [Text] - , supportedResponseTypes :: [Text] - , supportedGrantTypes :: [Text] - , supportedAuthMethods :: [Text] - , supportedCodeChallengeMethods :: [Text] - , -- Demo mode settings - autoApproveAuth :: Bool - , demoUserIdTemplate :: Maybe Text -- Nothing means no demo mode - , demoEmailDomain :: Text - , demoUserName :: Text - , publicClientSecret :: Maybe Text - , -- Token prefixes - authCodePrefix :: Text - , refreshTokenPrefix :: Text - , clientIdPrefix :: Text - , -- Response templates - authorizationSuccessTemplate :: Maybe Text - } - deriving (Show, Generic) - --- | PKCE challenge data -data PKCEChallenge = PKCEChallenge - { codeVerifier :: Text - , codeChallenge :: Text - , challengeMethod :: Text -- Always "S256" for MCP - } - deriving (Show, Generic) - --- | OAuth metadata (from discovery endpoint) -data OAuthMetadata = OAuthMetadata - { issuer :: Text - , authorizationEndpoint :: Text - , tokenEndpoint :: Text - , registrationEndpoint :: Maybe Text - , userInfoEndpoint :: Maybe Text - , jwksUri :: Maybe Text - , scopesSupported :: Maybe [Text] - , responseTypesSupported :: [Text] - , grantTypesSupported :: Maybe [Text] - , tokenEndpointAuthMethodsSupported :: Maybe [Text] - , codeChallengeMethodsSupported :: Maybe [Text] - } - deriving (Show, Generic) - -instance FromJSON OAuthMetadata where - parseJSON = Aeson.withObject "OAuthMetadata" $ \v -> - OAuthMetadata - <$> v Aeson..: "issuer" - <*> v Aeson..: "authorization_endpoint" - <*> v Aeson..: "token_endpoint" - <*> v Aeson..:? "registration_endpoint" - <*> v Aeson..:? "userinfo_endpoint" - <*> v Aeson..:? "jwks_uri" - <*> v Aeson..:? "scopes_supported" - <*> v Aeson..: "response_types_supported" - <*> v Aeson..:? "grant_types_supported" - <*> v Aeson..:? "token_endpoint_auth_methods_supported" - <*> v Aeson..:? "code_challenge_methods_supported" - -instance ToJSON OAuthMetadata where - toJSON OAuthMetadata{..} = - Aeson.object $ - [ "issuer" Aeson..= issuer - , "authorization_endpoint" Aeson..= authorizationEndpoint - , "token_endpoint" Aeson..= tokenEndpoint - , "response_types_supported" Aeson..= responseTypesSupported - ] - ++ maybe [] (\x -> ["registration_endpoint" Aeson..= x]) registrationEndpoint - ++ maybe [] (\x -> ["userinfo_endpoint" Aeson..= x]) userInfoEndpoint - ++ maybe [] (\x -> ["jwks_uri" Aeson..= x]) jwksUri - ++ maybe [] (\x -> ["scopes_supported" Aeson..= x]) scopesSupported - ++ maybe [] (\x -> ["grant_types_supported" Aeson..= x]) grantTypesSupported - ++ maybe [] (\x -> ["token_endpoint_auth_methods_supported" Aeson..= x]) tokenEndpointAuthMethodsSupported - ++ maybe [] (\x -> ["code_challenge_methods_supported" Aeson..= x]) codeChallengeMethodsSupported - --- | Token introspection response -data TokenInfo = TokenInfo - { active :: Bool - , scope :: Maybe Text - , clientId :: Maybe Text - , username :: Maybe Text - , tokenType :: Maybe Text - , exp :: Maybe Integer -- Expiration time (Unix timestamp) - , iat :: Maybe Integer -- Issued at time (Unix timestamp) - , nbf :: Maybe Integer -- Not before time (Unix timestamp) - , sub :: Maybe Text -- Subject - , aud :: Maybe [Text] -- Audience - , iss :: Maybe Text -- Issuer - } - deriving (Show, Generic) - -instance FromJSON TokenInfo where - parseJSON = Aeson.withObject "TokenInfo" $ \v -> - TokenInfo - <$> v Aeson..: "active" - <*> v Aeson..:? "scope" - <*> v Aeson..:? "client_id" - <*> v Aeson..:? "username" - <*> v Aeson..:? "token_type" - <*> v Aeson..:? "exp" - <*> v Aeson..:? "iat" - <*> v Aeson..:? "nbf" - <*> v Aeson..:? "sub" - <*> v Aeson..:? "aud" - <*> v Aeson..:? "iss" - --- | Extract Bearer token from Authorization header -extractBearerToken :: Text -> Maybe Text -extractBearerToken authHeader = - case T.words authHeader of - ["Bearer", token] -> Just token - _ -> Nothing - --- | Validate a bearer token -validateBearerToken :: (MonadIO m) => OAuthConfig -> Text -> m (Either Text TokenInfo) -validateBearerToken config token = do - -- Basic validation - if T.null token - then return $ Left "Empty token" - else case tokenValidationEndpoint config of - Just endpoint -> introspectToken endpoint token - Nothing -> do - -- Without an introspection endpoint, perform basic JWT validation - -- In production, this should: - -- 1. Verify JWT signature using JWK from jwks_uri - -- 2. Check expiration time - -- 3. Validate issuer and audience - -- 4. Check token type is "Bearer" - - -- For now, decode JWT payload (middle part) for basic validation - case T.splitOn "." token of - [_header, payload, _signature] -> do - currentTime <- liftIO getCurrentTime - case decodeJWTPayload payload of - Right tokenInfo -> - case validateTokenClaims tokenInfo currentTime of - Right _ -> return $ Right tokenInfo - Left err -> return $ Left err - Left err -> return $ Left $ "Invalid JWT format: " <> err - _ -> return $ Left "Invalid JWT structure" - --- | Introspect token using OAuth introspection endpoint -introspectToken :: (MonadIO m) => Text -> Text -> m (Either Text TokenInfo) -introspectToken endpoint token = liftIO $ do - let url = T.unpack endpoint - request <- parseRequest url - let requestWithBody = - setRequestMethod "POST" $ - setRequestBodyJSON (Aeson.object [("token", Aeson.String token)]) $ - addRequestHeader "Content-Type" "application/json" request - - response <- httpJSON requestWithBody - let tokenInfo = getResponseBody response - - if active tokenInfo - then return $ Right tokenInfo - else return $ Left "Token is not active" - --- | Decode JWT payload (base64url encoded JSON) -decodeJWTPayload :: Text -> Either Text TokenInfo -decodeJWTPayload payload = - case B64URL.decodeUnpadded (TE.encodeUtf8 payload) of - Right decodedBytes -> - case Aeson.decode' (LBS.fromStrict decodedBytes) of - Just info -> Right info{active = True} -- JWT is implicitly active - Nothing -> Left "Failed to parse JWT payload" - Left _ -> Left "Invalid base64url encoding" - --- | Validate token claims (expiration, not-before, etc.) -validateTokenClaims :: TokenInfo -> UTCTime -> Either Text () -validateTokenClaims tokenInfo currentTime = do - let currentTimestamp = floor (realToFrac (utcTimeToPOSIXSeconds currentTime) :: Double) :: Integer - - -- Check expiration - case MCP.Server.Auth.exp tokenInfo of - Just expTime -> - if currentTimestamp > expTime - then Left "Token has expired" - else Right () - Nothing -> Right () - - -- Check not-before - case MCP.Server.Auth.nbf tokenInfo of - Just nbfTime -> - if currentTimestamp < nbfTime - then Left "Token not yet valid" - else Right () - Nothing -> Right () - - return () - --- | Generate a cryptographically secure code verifier for PKCE -generateCodeVerifier :: IO Text -generateCodeVerifier = do - gen <- newStdGen - let chars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-._~" - let verifier = take 128 $ randomRs (0, length chars - 1) gen - return $ T.pack $ map (chars !!) verifier - --- | Generate code challenge from verifier using SHA256 (S256 method) -generateCodeChallenge :: Text -> Text -generateCodeChallenge verifier = - let verifierBytes = TE.encodeUtf8 verifier - challengeHash = hashWith SHA256 verifierBytes - challengeBytes = convert challengeHash :: ByteString - in TE.decodeUtf8 $ B64URL.encodeUnpadded challengeBytes - --- | Validate PKCE code verifier against challenge -validateCodeVerifier :: Text -> Text -> Bool -validateCodeVerifier verifier challenge = - generateCodeChallenge verifier == challenge - --- | Discover OAuth metadata from a well-known endpoint -discoverOAuthMetadata :: (MonadIO m) => Text -> m (Either String OAuthMetadata) -discoverOAuthMetadata issuerUrl = liftIO $ do - let wellKnownUrl = T.unpack issuerUrl <> "/.well-known/openid-configuration" - request <- parseRequest wellKnownUrl - response <- httpJSON request - return $ Right (getResponseBody response) diff --git a/src/MCP/Server/Common.hs b/src/MCP/Server/Common.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Common.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module: MCP.Server.Common +License: MPL-2.0 +Maintainer: , + +Transport-agnostic core of the MCP server. + +This module provides the shared types, state management, request routing, +and tool framework used by both the HTTP and stdio transports. +-} +module MCP.Server.Common ( + -- * Processing results + ProcessResult (..), + + -- * Server monad + MCPServerT, + + -- * Handlers + ProcessHandlers (..), + defaultProcessHandlers, + + -- * Tool helpers + ToolHandler (..), + toolHandler, + withToolHandlers, + toolTextResult, + toolTextError, + + -- * Server state + MCPServerState (..), + initMCPServerState, + + -- * Type families + MCPHandlerState, + MCPHandlerUser, + + -- * Core processing (transport-agnostic) + processMethod, + recurReplaceMeta, + isValidRequestId, + + -- * Re-exports + module MCP.Protocol, + module MCP.Types, +) where + +import Control.Concurrent.MVar (MVar) +import Control.Monad.Except +import Control.Monad.State.Lazy +import Data.Aeson (Value, fromJSON, object, toJSON) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.IntMap (IntMap) +import Data.IntMap qualified as IM +import Data.Map (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import MCP.Protocol +import MCP.Types + +{- | Result of processing an MCP request. + +Distinguishes between server errors, RPC protocol errors, +and successful responses. +-} +data ProcessResult a where + -- | Internal server error + ProcessServerError :: Text -> ProcessResult a + -- | JSON-RPC error with code and message + ProcessRPCError :: Int -> Text -> ProcessResult a + -- | Successful result + ProcessSuccess :: a -> ProcessResult a + {- | Request additional information from the client before completing. + + This allows a handler to send a JSON-RPC request back to the client + (e.g. @sampling\/createMessage@ or @elicitation\/create@) and resume + processing once the client responds. + + Supported on both transports: + + * __HTTP__: the request is yielded as an SSE event; the server blocks + (via 'MVar') until the client POSTs a matching response. + * __Stdio__: the request is written to stdout and the response is read + synchronously from stdin (blocks until the client responds). + -} + ProcessClientInput :: + -- | JSON-RPC method name for the client request + Text -> + -- | Parameters for the client request + Aeson.Value -> + -- | Continuation that receives the client's response + (Aeson.Value -> MCPServerT (ProcessResult a)) -> + ProcessResult a + +instance Functor ProcessResult where + fmap f (ProcessSuccess a) = ProcessSuccess (f a) + fmap _ (ProcessServerError err) = ProcessServerError err + fmap _ (ProcessRPCError code msg) = ProcessRPCError code msg + fmap f (ProcessClientInput mthd param cont) = + ProcessClientInput mthd param $ \res -> do + result <- cont res + return $ fmap f result + +{- | Monad transformer for MCP server operations. + +Provides access to the MCP server state and IO operations, +with the state available to the handlers. +-} +type MCPServerT a = ExceptT Text (StateT MCPServerState IO) a + +{- | Handlers for MCP protocol methods. + +Each handler is optional, allowing servers to implement only +the capabilities they need. Handlers run in the MCPServerT monad +with access to server state and IO. +-} +data ProcessHandlers + = ProcessHandlers + { listResourcesHandler :: Maybe (ListResourcesParams -> MCPServerT (ProcessResult ListResourcesResult)) + -- ^ List available resources + , readResourceHandler :: Maybe (ReadResourceParams -> MCPServerT (ProcessResult ReadResourceResult)) + -- ^ Read a specific resource + , listToolsHandler :: Maybe (ListToolsParams -> MCPServerT (ProcessResult ListToolsResult)) + -- ^ List available tools + , callToolHandler :: Maybe (CallToolParams -> MCPServerT (ProcessResult CallToolResult)) + -- ^ Execute a tool + , listPromptsHandler :: Maybe (ListPromptsParams -> MCPServerT (ProcessResult ListPromptsResult)) + -- ^ List prompt templates + , getPromptHandler :: Maybe (GetPromptParams -> MCPServerT (ProcessResult GetPromptResult)) + -- ^ Get a specific prompt + , listResourceTemplatesHandler :: + Maybe (ListResourceTemplatesParams -> MCPServerT (ProcessResult ListResourceTemplatesResult)) + -- ^ List resource templates + , completeHandler :: Maybe (CompleteParams -> MCPServerT (ProcessResult CompleteResult)) + -- ^ Provide completions + , subscribeHandler :: Maybe (SubscribeParams -> MCPServerT (ProcessResult Result)) + -- ^ Subscribe to resource updates + , unsubscribeHandler :: Maybe (UnsubscribeParams -> MCPServerT (ProcessResult Result)) + -- ^ Unsubscribe from resource updates + } + +-- | A ToolHandler, including the name, description, and input schema. +data ToolHandler = ToolHandler + { tool_name :: Text + , tool_description :: Maybe Text + , tool_title :: Maybe Text + , tool_input :: InputSchema + , tool_output :: Maybe InputSchema + , tool_annotations :: Maybe ToolAnnotations + , tool_meta :: Maybe Metadata + , tool_handler :: Maybe (Map Text Value) -> MCPServerT (ProcessResult CallToolResult) + } + +-- | Construct a tool handler with the required fields +toolHandler :: + Text -> + Maybe Text -> + InputSchema -> + (Maybe (Map Text Value) -> MCPServerT (ProcessResult CallToolResult)) -> + ToolHandler +toolHandler name desc input handler = + ToolHandler + { tool_name = name + , tool_description = desc + , tool_title = Nothing + , tool_input = input + , tool_output = Nothing + , tool_annotations = Nothing + , tool_meta = Nothing + , tool_handler = handler + } + +-- | Create the raw process handlers from a list of tool handlers. +withToolHandlers :: [ToolHandler] -> ProcessHandlers -> ProcessHandlers +withToolHandlers ths ph = + ph + { listToolsHandler = Just list_handler + , callToolHandler = Just call_handler + } + where + tool_handler_to_tool :: ToolHandler -> Tool + tool_handler_to_tool ToolHandler{..} = + Tool + { name = tool_name + , description = tool_description + , title = tool_title + , inputSchema = tool_input + , outputSchema = tool_output + , annotations = tool_annotations + , _meta = tool_meta + } + list_handler = const $ do + return $ + ProcessSuccess $ + ListToolsResult + { tools = fmap tool_handler_to_tool ths + , nextCursor = Nothing + , _meta = Nothing + } + tool_map :: Map Text ToolHandler + tool_map = Map.fromList $ fmap (\th -> (tool_name th, th)) ths + + missing_required :: Set Text -> MCPServerT (ProcessResult CallToolResult) + missing_required reqs = return $ ProcessRPCError iNVALID_PARAMS $ "Missing required arguments: " <> T.intercalate ", " (Set.toList reqs) + + call_handler :: CallToolParams -> MCPServerT (ProcessResult CallToolResult) + call_handler CallToolParams{name = t_name, arguments = args} = + case Map.lookup t_name tool_map of + Nothing -> return $ ProcessRPCError mETHOD_NOT_FOUND ("Tool not found: " <> t_name) + Just ToolHandler{tool_input = InputSchema{required = required}, tool_handler = handler} -> + -- Handle missing arguments + case (args, required) of + (_, Nothing) -> handler args + (Nothing, Just req) | not $ null req -> missing_required (Set.fromList req) + (Nothing, Just _) -> handler args + (Just provided, Just req) + | p_keys <- Map.keysSet provided + , missing <- Set.fromList req Set.\\ p_keys + , not (Set.null missing) -> + missing_required missing + (Just _provided, _) -> handler args + +-- | A tool result containing text content. +toolTextResult :: [Text] -> CallToolResult +toolTextResult res = + CallToolResult + { content = map toTContent res + , isError = Just False + , _meta = Nothing + , structuredContent = Nothing + } + where + toTContent :: Text -> ContentBlock + toTContent = + TextBlock . \t -> TextContent{textType = "text", text = t, annotations = Nothing, _meta = Nothing} + +-- | A tool result containing text content. +toolTextError :: Text -> CallToolResult +toolTextError err = + CallToolResult + { content = [TextBlock $ TextContent{textType = "text", text = err, annotations = Nothing, _meta = Nothing}] + , isError = Just True + , _meta = Nothing + , structuredContent = Nothing + } + +{- | Default process handlers with no implementations. + +Use this as a starting point and override specific handlers +as needed for your MCP server implementation. +-} +defaultProcessHandlers :: ProcessHandlers +defaultProcessHandlers = + ProcessHandlers + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +{- | Initialize MCP server state with given options and capabilities. + +Creates a new server state with: +* The initial handler state +* Server capabilities declaration +* Implementation metadata +* Optional instructions for clients +* Custom process handlers +-} +initMCPServerState :: + -- | Initial handler state + MCPHandlerState -> + -- | Initialize handler state when the client sends @initialize@ + Maybe (MCPHandlerUser -> MCPHandlerState -> IO MCPHandlerState) -> + -- | Finalize handler state after each request + Maybe (MCPHandlerState -> IO MCPHandlerState) -> + -- | Server capabilities to advertise to clients + ServerCapabilities -> + -- | Server name and version metadata + Implementation -> + -- | Optional instructions for clients + Maybe Text -> + -- | Handlers for MCP methods + ProcessHandlers -> + MCPServerState +initMCPServerState init_state handler_init handler_finalize = + MCPServerState False init_state handler_init handler_finalize Nothing (Just Warning) IM.empty 0 + +{- | Type family used to configure the handler state threaded through 'MCPServerT'. +Users must provide a type instance before using the MCP server, e.g. +@type instance MCPHandlerState = MyState@. +-} +type family MCPHandlerState + +{- | Type family used to configure the user type for JWT authentication. +Users must provide a type instance before using the MCP server, e.g. +@type instance MCPHandlerUser = MyUser@. +-} +type family MCPHandlerUser + +{- | MCP server state maintained across requests. + +Contains all information needed to process MCP requests including +initialization status, handler state, and capability declarations. +-} +data MCPServerState = MCPServerState + { mcp_server_initialized :: Bool + -- ^ Whether initialize has been called + , mcp_handler_state :: MCPHandlerState + -- ^ Current handler state for this session + , mcp_handler_init :: Maybe (MCPHandlerUser -> MCPHandlerState -> IO MCPHandlerState) + -- ^ Initialize the handler state on server initialization + , mcp_handler_finalize :: Maybe (MCPHandlerState -> IO MCPHandlerState) + -- ^ Finalize the handler state after each request + , mcp_client_capabilities :: Maybe ClientCapabilities + -- ^ Client's declared capabilities + , mcp_log_level :: Maybe LoggingLevel + -- ^ Log level + , mcp_pending_responses :: IntMap (MVar Aeson.Value) + -- ^ Pending responses from the client + , mcp_pending_responses_next :: Int + -- ^ Next pending response ID + , mcp_server_capabilities :: ServerCapabilities + -- ^ Server's declared capabilities + , mcp_implementation :: Implementation + -- ^ Server implementation metadata + , mcp_instructions :: Maybe Text + -- ^ Optional instructions for clients + , mcp_process_handlers :: ProcessHandlers + -- ^ Handlers for MCP methods + } + +{- | Normalize @_meta@ fields in JSON-RPC responses. +Promotes the contents of @_meta@ objects up one level and removes the @_meta@ key. +-} +recurReplaceMeta :: Aeson.Value -> Aeson.Value +recurReplaceMeta (Aeson.Array arr) = + Aeson.Array $ fmap recurReplaceMeta arr +recurReplaceMeta o@(Aeson.Object _) + | Aeson.Object obj' <- replaceMeta o = + Aeson.Object $ fmap recurReplaceMeta obj' +recurReplaceMeta v = v + +-- | Replace @_meta@ at the top level of an object +replaceMeta :: Aeson.Value -> Aeson.Value +replaceMeta (Aeson.Object obj) + | Just (Aeson.Object meta) <- KM.lookup "_meta" obj = + Aeson.Object $ KM.delete "_meta" obj `KM.union` meta +replaceMeta v = v + +-- | Check if a RequestId is valid according to JSON-RPC 2.0 spec. +isValidRequestId :: RequestId -> Bool +isValidRequestId (RequestId v) = + case v of + Aeson.Number _ -> True + Aeson.String _ -> True + Aeson.Null -> True + _ -> False + +-- | Methods that can be called without initialization +allowedWithoutInitialization :: Set Text +allowedWithoutInitialization = Set.fromList ["ping", "initialize"] + +-- | Methods that are allowed without parameters (null params -> empty object) +allowedWithoutParams :: Set Text +allowedWithoutParams = + Set.fromList + [ "resources/list" + , "resources/templates/list" + , "tools/list" + , "prompts/list" + ] + +{- | Route an incoming JSON-RPC method to the appropriate handler. + +This is the transport-agnostic core of the MCP server, used by both +the HTTP and stdio transports. It enforces initialization order +(only @\"ping\"@ and @\"initialize\"@ are accepted before the server +has been initialized) and parses method parameters before delegating +to the 'ProcessHandlers'. +-} +processMethod :: Bool -> Text -> Aeson.Value -> StateT MCPServerState IO (ProcessResult Aeson.Value) +processMethod False mthd _ | not $ mthd `Set.member` allowedWithoutInitialization = server_not_initialized +processMethod _ mthd Aeson.Null | mthd `Set.member` allowedWithoutParams = processMethod True mthd (object []) +processMethod _ "resources/list" mb_arg = runProcessHandler listResourcesHandler mb_arg +processMethod _ "resources/read" mb_arg = runProcessHandler readResourceHandler mb_arg +processMethod _ "resources/subscribe" mb_arg = runProcessHandler subscribeHandler mb_arg +processMethod _ "resources/unsubscribe" mb_arg = runProcessHandler unsubscribeHandler mb_arg +processMethod _ "tools/list" mb_arg = runProcessHandler listToolsHandler mb_arg +processMethod _ "tools/call" mb_arg = runProcessHandler callToolHandler mb_arg +processMethod _ "prompts/list" mb_arg = runProcessHandler listPromptsHandler mb_arg +processMethod _ "prompts/get" mb_arg = runProcessHandler getPromptHandler mb_arg +processMethod _ "resources/templates/list" mb_arg = runProcessHandler listResourceTemplatesHandler mb_arg +processMethod _ "completion/complete" mb_arg = runProcessHandler completeHandler mb_arg +processMethod _ "ping" _ = return $ ProcessSuccess (toJSON $ object []) +processMethod _ "logging/setLevel" p + | Aeson.Error e <- fromJSON @SetLevelParams p = invalid_params e +processMethod _ "logging/setLevel" p + | Aeson.Success (SetLevelParams{level = level}) <- fromJSON @SetLevelParams p = do + modify $ \s -> s{mcp_log_level = Just level} + return $ ProcessSuccess Aeson.Null +processMethod _ "initialize" p + | Aeson.Error e <- fromJSON @InitializeParams p = invalid_params e +processMethod _ "initialize" p + | Aeson.Success (InitializeParams{capabilities = capabilities}) <- fromJSON @InitializeParams p = do + MCPServerState{..} <- get + modify $ \s -> + s + { mcp_server_initialized = True + , mcp_client_capabilities = Just capabilities + } + let result = + InitializeResult + { protocolVersion = pROTOCOL_VERSION + , capabilities = mcp_server_capabilities + , serverInfo = mcp_implementation + , instructions = mcp_instructions + , _meta = Nothing + } + return $ ProcessSuccess $ toJSON result +processMethod _ _ _ = method_not_found + +-- | Standard JSON-RPC error responses +missing_params :: StateT MCPServerState IO (ProcessResult Aeson.Value) +missing_params = return $ ProcessRPCError iNVALID_PARAMS "Missing params" + +invalid_params :: String -> StateT MCPServerState IO (ProcessResult Aeson.Value) +invalid_params = return . ProcessRPCError iNVALID_PARAMS . ("Invalid params: " <>) . T.pack + +server_not_initialized :: StateT MCPServerState IO (ProcessResult Aeson.Value) +server_not_initialized = return $ ProcessRPCError sERVER_NOT_INITIALIZED "Server not initialized" + +method_not_found :: StateT MCPServerState IO (ProcessResult Aeson.Value) +method_not_found = return $ ProcessRPCError mETHOD_NOT_FOUND "Method not found" + +-- | Helper to run a process handler with argument parsing +runProcessHandler :: + forall a b. + (Aeson.FromJSON a, Aeson.ToJSON b) => + (ProcessHandlers -> Maybe (a -> MCPServerT (ProcessResult b))) -> + Aeson.Value -> + StateT MCPServerState IO (ProcessResult Aeson.Value) +runProcessHandler _ Aeson.Null = missing_params +runProcessHandler handler arg_value = + case fromJSON @a arg_value of + Aeson.Error err -> invalid_params err + Aeson.Success arg -> do + handlerImpl <- gets (handler . mcp_process_handlers) + case handlerImpl of + Just impl -> do + impl_res <- runExceptT $ impl arg + case impl_res of + Left err -> return $ ProcessServerError err + Right res -> return $ fmap toJSON res + Nothing -> method_not_found diff --git a/src/MCP/Server/HTTP.hs b/src/MCP/Server/HTTP.hs --- a/src/MCP/Server/HTTP.hs +++ b/src/MCP/Server/HTTP.hs @@ -1,808 +1,273 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{- | -Module : MCP.Server.HTTP -Description : MCP server implementation for HTTP communication -Copyright : (C) 2025 Matthias Pall Gissurarson -License : MIT -Maintainer : mpg@mpg.is -Stability : experimental -Portability : GHC - -This module provides MCP server implementation for HTTP communication. --} -module MCP.Server.HTTP ( - -- * Server Runner - runServerHTTP, - HTTPServerConfig (..), - - -- * Demo Configuration Helpers - defaultDemoOAuthConfig, -) where - -import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, readTVarIO, writeTVar) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ask) -import Control.Monad.State.Strict (get, put) -import Crypto.JOSE (JWK) -import Data.Aeson (encode, fromJSON, object, toJSON, (.=)) -import Data.Aeson qualified as Aeson -import Data.ByteString.Lazy qualified as LBS -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as TE -import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) -import Data.UUID qualified as UUID -import Data.UUID.V4 qualified as UUID -import GHC.Generics (Generic) -import Network.Wai (Application) -import Network.Wai.Handler.Warp (Port, run) -import Network.Wai.Middleware.RequestLogger (logStdoutDev) -import Servant (Context (..), Handler, Proxy (..), Server, serve, serveWithContext, throwError) -import Servant.API (FormUrlEncoded, Get, JSON, PlainText, Post, QueryParam, QueryParam', ReqBody, Required, (:<|>) (..), (:>)) -import Servant.Auth.Server (Auth, AuthResult (..), FromJWT, JWT, JWTSettings, ToJWT, defaultCookieSettings, defaultJWTSettings, generateKey, makeJWT) -import Servant.Server (err400, err401, err500, errBody) - -import Control.Monad (unless, when) -import MCP.Protocol -import MCP.Server (MCPServer (..), MCPServerM, ServerConfig (..), ServerState (..), initialServerState, runMCPServer) -import MCP.Server.Auth (OAuthConfig (..), OAuthMetadata (..), OAuthProvider (..), validateCodeVerifier) -import MCP.Types - --- | Configuration for running an MCP HTTP server -data HTTPServerConfig = HTTPServerConfig - { httpPort :: Port - , httpBaseUrl :: Text -- Base URL for OAuth endpoints (e.g., "https://api.example.com") - , httpServerInfo :: Implementation - , httpCapabilities :: ServerCapabilities - , httpEnableLogging :: Bool - , httpOAuthConfig :: Maybe OAuthConfig - , httpJWK :: Maybe JWK -- JWT signing key - , httpProtocolVersion :: Text -- MCP protocol version - } - deriving (Show) - --- | User information from OAuth -data AuthUser = AuthUser - { userId :: Text - , userEmail :: Maybe Text - , userName :: Maybe Text - } - deriving (Show, Generic) - --- | Authorization code with PKCE -data AuthorizationCode = AuthorizationCode - { authCode :: Text - , authClientId :: Text - , authRedirectUri :: Text - , authCodeChallenge :: Text - , authCodeChallengeMethod :: Text - , authScopes :: [Text] - , authUserId :: Text - , authExpiry :: UTCTime - } - deriving (Show, Generic) - --- | OAuth server state -data OAuthState = OAuthState - { authCodes :: Map Text AuthorizationCode -- code -> AuthorizationCode - , accessTokens :: Map Text AuthUser -- token -> user - , refreshTokens :: Map Text (Text, AuthUser) -- refresh_token -> (access_token, user) - , registeredClients :: Map Text ClientInfo -- client_id -> ClientInfo - } - deriving (Show, Generic) - --- | Client registration request -data ClientRegistrationRequest = ClientRegistrationRequest - { client_name :: Text - , redirect_uris :: [Text] - , grant_types :: [Text] - , response_types :: [Text] - , token_endpoint_auth_method :: Text - } - deriving (Show, Generic) - -instance Aeson.FromJSON ClientRegistrationRequest where - parseJSON = Aeson.genericParseJSON Aeson.defaultOptions - --- | Client registration response -data ClientRegistrationResponse = ClientRegistrationResponse - { client_id :: Text - , client_secret :: Text -- Empty string for public clients - , client_name :: Text - , redirect_uris :: [Text] - , grant_types :: [Text] - , response_types :: [Text] - , token_endpoint_auth_method :: Text - } - deriving (Show, Generic) - -instance Aeson.ToJSON ClientRegistrationResponse where - toJSON = Aeson.genericToJSON Aeson.defaultOptions - --- | Client info stored in server -data ClientInfo = ClientInfo - { clientName :: Text - , clientRedirectUris :: [Text] - , clientGrantTypes :: [Text] - , clientResponseTypes :: [Text] - , clientAuthMethod :: Text - } - deriving (Show, Generic) - --- | Token response -data TokenResponse = TokenResponse - { access_token :: Text - , token_type :: Text - , expires_in :: Maybe Int - , refresh_token :: Maybe Text - , scope :: Maybe Text - } - deriving (Show, Generic) - -instance Aeson.ToJSON TokenResponse where - toJSON TokenResponse{..} = - object $ - [ "access_token" .= access_token - , "token_type" .= token_type - ] - ++ maybe [] (\e -> ["expires_in" .= e]) expires_in - ++ maybe [] (\r -> ["refresh_token" .= r]) refresh_token - ++ maybe [] (\s -> ["scope" .= s]) scope - -instance Aeson.FromJSON AuthUser where - parseJSON = Aeson.withObject "AuthUser" $ \v -> - AuthUser - <$> v Aeson..: "sub" - <*> v Aeson..:? "email" - <*> v Aeson..:? "name" - -instance Aeson.ToJSON AuthUser where - toJSON AuthUser{..} = - object - [ "sub" .= userId - , "email" .= userEmail - , "name" .= userName - ] - --- Instances for JWT -instance ToJWT AuthUser -instance FromJWT AuthUser - --- | MCP API definition for HTTP server (following the MCP transport spec) -type MCPAPI auths = Auth auths AuthUser :> "mcp" :> ReqBody '[JSON] Aeson.Value :> Post '[JSON] Aeson.Value - --- | Unprotected MCP API (for backward compatibility) -type UnprotectedMCPAPI = "mcp" :> ReqBody '[JSON] Aeson.Value :> Post '[JSON] Aeson.Value - --- | OAuth endpoints -type OAuthAPI = - ".well-known" :> "oauth-authorization-server" :> Get '[JSON] OAuthMetadata - :<|> "register" - :> ReqBody '[JSON] ClientRegistrationRequest - :> Post '[JSON] ClientRegistrationResponse - :<|> "authorize" - :> QueryParam' '[Required] "response_type" Text - :> QueryParam' '[Required] "client_id" Text - :> QueryParam' '[Required] "redirect_uri" Text - :> QueryParam' '[Required] "code_challenge" Text - :> QueryParam' '[Required] "code_challenge_method" Text - :> QueryParam "scope" Text - :> QueryParam "state" Text - :> Get '[PlainText] Text - :<|> "token" - :> ReqBody '[FormUrlEncoded] [(Text, Text)] - :> Post '[JSON] TokenResponse - --- | Complete API with OAuth -type CompleteAPI auths = OAuthAPI :<|> MCPAPI auths - --- | Create a WAI Application for the MCP HTTP server -mcpApp :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> TVar OAuthState -> JWTSettings -> Application -mcpApp config stateVar oauthStateVar jwtSettings = - let cookieSettings = defaultCookieSettings - authContext = cookieSettings :. jwtSettings :. EmptyContext - baseApp = case httpOAuthConfig config of - Just oauthCfg - | oauthEnabled oauthCfg -> - serveWithContext - (Proxy :: Proxy (CompleteAPI '[JWT])) - authContext - (oauthServer config oauthStateVar :<|> mcpServerAuth config stateVar) - _ -> - serve (Proxy :: Proxy UnprotectedMCPAPI) (mcpServerNoAuth config stateVar) - in if httpEnableLogging config - then logStdoutDev baseApp - else baseApp - where - oauthServer :: HTTPServerConfig -> TVar OAuthState -> Server OAuthAPI - oauthServer cfg oauthState = - handleMetadata cfg - :<|> handleRegister cfg oauthState - :<|> handleAuthorize cfg oauthState - :<|> handleToken jwtSettings cfg oauthState - - mcpServerAuth :: HTTPServerConfig -> TVar ServerState -> AuthResult AuthUser -> Aeson.Value -> Handler Aeson.Value - mcpServerAuth httpConfig stateTVar authResult requestValue = - case authResult of - Authenticated user -> handleHTTPRequest httpConfig stateTVar (Just user) requestValue - NoSuchUser -> throwError err401{errBody = encode $ object ["error" .= ("Invalid token" :: Text)]} - BadPassword -> throwError err401{errBody = encode $ object ["error" .= ("Invalid token" :: Text)]} - Indefinite -> throwError err401{errBody = encode $ object ["error" .= ("Authentication required" :: Text)]} - - mcpServerNoAuth :: HTTPServerConfig -> TVar ServerState -> Aeson.Value -> Handler Aeson.Value - mcpServerNoAuth httpConfig stateTVar = handleHTTPRequest httpConfig stateTVar Nothing - --- | Handle HTTP MCP requests following the MCP transport protocol -handleHTTPRequest :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> Maybe AuthUser -> Aeson.Value -> Handler Aeson.Value -handleHTTPRequest httpConfig stateVar _mAuthUser requestValue = do - -- Parse the incoming JSON-RPC message - case fromJSON requestValue of - Aeson.Success (msg :: JSONRPCMessage) -> do - case msg of - RequestMessage req -> do - -- Process the JSON-RPC request - result <- liftIO $ processHTTPRequest httpConfig stateVar req - case result of - Left err -> throwError err500{errBody = encode $ object ["error" .= err]} - Right response -> return response - NotificationMessage notif -> do - -- Process notifications (no response expected) - _ <- liftIO $ processHTTPNotification httpConfig stateVar notif - return $ object [] -- Empty response for notifications - _ -> throwError err400{errBody = encode $ object ["error" .= ("Invalid JSON-RPC message type" :: Text)]} - Aeson.Error e -> throwError err400{errBody = encode $ object ["error" .= ("Invalid JSON-RPC message" :: Text), "error_description" .= T.pack e]} - --- | Process an HTTP MCP notification -processHTTPNotification :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> JSONRPCNotification -> IO () -processHTTPNotification _ _ _ = do - -- For now, just ignore notifications since they don't need responses - -- In a more complete implementation, this would handle logging/setLevel notifications - return () - --- | Process an HTTP MCP request -processHTTPRequest :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> JSONRPCRequest -> IO (Either Text Aeson.Value) -processHTTPRequest httpConfig stateVar req = do - -- Read the current state - currentState <- readTVarIO stateVar - let dummyConfig = - ServerConfig - { configInput = undefined -- Not used in HTTP mode - , configOutput = undefined -- Not used in HTTP mode - , configServerInfo = httpServerInfo httpConfig - , configCapabilities = httpCapabilities httpConfig - } - - result <- runMCPServer dummyConfig currentState (handleHTTPRequestInner (httpProtocolVersion httpConfig) req) - case result of - Left err -> return $ Left err - Right (response, newState) -> do - -- Update the state atomically - atomically $ writeTVar stateVar newState - return $ Right response - --- | Handle HTTP request within the MCP monad, returning proper JSON-RPC responses -handleHTTPRequestInner :: (MCPServer MCPServerM) => Text -> JSONRPCRequest -> MCPServerM Aeson.Value -handleHTTPRequestInner protocolVersion (JSONRPCRequest _ reqId method params) = do - config <- ask - state <- get - - case method of - "initialize" -> case params of - Just p -> case fromJSON p of - Aeson.Success initParams -> do - handleInitializeHTTP reqId initParams - let result = - InitializeResult - { protocolVersion = protocolVersion - , capabilities = configCapabilities config - , serverInfo = configServerInfo config - , instructions = Nothing - , _meta = Nothing - } - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "ping" -> return $ toJSON $ JSONRPCResponse "2.0" reqId (object []) - "resources/list" -> do - if not (serverInitialized state) - then - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListResources listParams - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListResources (ListResourcesParams Nothing) - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - "resources/read" -> do - if not (serverInitialized state) - then - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success readParams -> do - result <- handleReadResource readParams - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "tools/list" -> do - if not (serverInitialized state) - then - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListTools listParams - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListTools (ListToolsParams Nothing) - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - "tools/call" -> do - if not (serverInitialized state) - then - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success callParams -> do - result <- handleCallTool callParams - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "prompts/list" -> do - if not (serverInitialized state) - then - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListPrompts listParams - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListPrompts (ListPromptsParams Nothing) - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - "prompts/get" -> do - if not (serverInitialized state) - then - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success getParams -> do - result <- handleGetPrompt getParams - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "completion/complete" -> do - if not (serverInitialized state) - then - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success completeParams -> do - result <- handleComplete completeParams - return $ toJSON $ JSONRPCResponse "2.0" reqId (toJSON result) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "logging/setLevel" -> case params of - Just p -> case fromJSON p of - Aeson.Success setLevelParams -> do - _ <- handleSetLevel setLevelParams - return $ toJSON $ JSONRPCResponse "2.0" reqId (object []) - Aeson.Error e -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - _ -> - return $ - toJSON $ - JSONRPCError "2.0" reqId $ - JSONRPCErrorInfo (-32601) "Method not found" Nothing - --- | Handle HTTP initialize request -handleInitializeHTTP :: RequestId -> InitializeParams -> MCPServerM () -handleInitializeHTTP _ params = do - config <- ask - state <- get - - let InitializeParams{capabilities = clientCaps} = params - - put - state - { serverInitialized = True - , clientCapabilities = Just clientCaps - , serverInfo = Just (configServerInfo config) - } - --- | Handle OAuth metadata discovery endpoint -handleMetadata :: HTTPServerConfig -> Handler OAuthMetadata -handleMetadata config = do - let baseUrl = httpBaseUrl config - oauthCfg = httpOAuthConfig config - return - OAuthMetadata - { issuer = baseUrl - , authorizationEndpoint = baseUrl <> "/authorize" - , tokenEndpoint = baseUrl <> "/token" - , registrationEndpoint = Just (baseUrl <> "/register") - , userInfoEndpoint = Nothing - , jwksUri = Nothing - , scopesSupported = fmap supportedScopes oauthCfg - , responseTypesSupported = maybe ["code"] supportedResponseTypes oauthCfg - , grantTypesSupported = fmap supportedGrantTypes oauthCfg - , tokenEndpointAuthMethodsSupported = fmap supportedAuthMethods oauthCfg - , codeChallengeMethodsSupported = fmap supportedCodeChallengeMethods oauthCfg - } - --- | Handle dynamic client registration -handleRegister :: HTTPServerConfig -> TVar OAuthState -> ClientRegistrationRequest -> Handler ClientRegistrationResponse -handleRegister config oauthStateVar (ClientRegistrationRequest reqName reqRedirects reqGrants reqResponses reqAuth) = do - -- Generate client ID - let prefix = maybe "client_" clientIdPrefix (httpOAuthConfig config) - clientId <- liftIO $ (prefix <>) <$> generateAuthCode - - -- Store client info - let clientInfo = - ClientInfo - { clientName = reqName - , clientRedirectUris = reqRedirects - , clientGrantTypes = reqGrants - , clientResponseTypes = reqResponses - , clientAuthMethod = reqAuth - } - - liftIO $ atomically $ modifyTVar' oauthStateVar $ \s -> - s{registeredClients = Map.insert clientId clientInfo (registeredClients s)} - - return - ClientRegistrationResponse - { client_id = clientId - , client_secret = "" -- Empty string for public clients - , client_name = reqName - , redirect_uris = reqRedirects - , grant_types = reqGrants - , response_types = reqResponses - , token_endpoint_auth_method = reqAuth - } - --- | Handle OAuth authorize endpoint -handleAuthorize :: HTTPServerConfig -> TVar OAuthState -> Text -> Text -> Text -> Text -> Text -> Maybe Text -> Maybe Text -> Handler Text -handleAuthorize config oauthStateVar responseType clientId redirectUri codeChallenge codeChallengeMethod mScope mState = do - -- Validate parameters according to MCP spec - when (responseType /= "code") $ - throwError err400{errBody = encode $ object ["error" .= ("unsupported_response_type" :: Text), "error_description" .= ("Only 'code' response type is supported" :: Text)]} - - when (codeChallengeMethod /= "S256") $ - throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text), "error_description" .= ("Only 'S256' code challenge method is supported" :: Text)]} - - -- Generate authorization code - code <- liftIO $ generateAuthCodeWithConfig config - currentTime <- liftIO getCurrentTime - let expirySeconds = maybe 600 (fromIntegral . authCodeExpirySeconds) (httpOAuthConfig config) - expiry = addUTCTime expirySeconds currentTime - - -- Generate user ID based on configuration - let oauthCfg = httpOAuthConfig config - userId = case demoUserIdTemplate =<< oauthCfg of - Just template -> T.replace "{clientId}" clientId template - Nothing -> "user-" <> clientId -- Fallback if no demo mode - authCode = - AuthorizationCode - { authCode = code - , authClientId = clientId - , authRedirectUri = redirectUri - , authCodeChallenge = codeChallenge - , authCodeChallengeMethod = codeChallengeMethod - , authScopes = maybe [] (T.splitOn " ") mScope - , authUserId = userId - , authExpiry = expiry - } - - -- Store authorization code - liftIO $ atomically $ modifyTVar' oauthStateVar $ \s -> - s{authCodes = Map.insert code authCode (authCodes s)} - - -- Return the callback URL with auth code - let stateParam = maybe "" ("&state=" <>) mState - defaultTemplate = - "Authorization successful!\n\n" - <> "Redirect to: " - <> redirectUri - <> "?code=" - <> code - <> stateParam - <> "\n\n" - <> "Use this authorization code to exchange for an access token." - template = - maybe - defaultTemplate - ( T.replace "{redirectUri}" redirectUri . T.replace "{code}" code . T.replace "{state}" stateParam - ) - (authorizationSuccessTemplate =<< httpOAuthConfig config) - return template - --- | Handle OAuth token endpoint -handleToken :: JWTSettings -> HTTPServerConfig -> TVar OAuthState -> [(Text, Text)] -> Handler TokenResponse -handleToken jwtSettings config oauthStateVar params = do - let paramMap = Map.fromList params - case Map.lookup "grant_type" paramMap of - Just "authorization_code" -> handleAuthCodeGrant jwtSettings config oauthStateVar paramMap - Just "refresh_token" -> handleRefreshTokenGrant jwtSettings config oauthStateVar paramMap - Just _other -> throwError err400{errBody = encode $ object ["error" .= ("unsupported_grant_type" :: Text)]} - Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text), "error_description" .= ("Missing grant_type" :: Text)]} - --- | Handle authorization code grant -handleAuthCodeGrant :: JWTSettings -> HTTPServerConfig -> TVar OAuthState -> Map Text Text -> Handler TokenResponse -handleAuthCodeGrant jwtSettings config oauthStateVar params = do - code <- case Map.lookup "code" params of - Just c -> return c - Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]} - - codeVerifier <- case Map.lookup "code_verifier" params of - Just v -> return v - Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]} - - -- Look up authorization code - oauthState <- liftIO $ readTVarIO oauthStateVar - authCode <- case Map.lookup code (authCodes oauthState) of - Just ac -> return ac - Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text)]} - - -- Verify code hasn't expired - currentTime <- liftIO getCurrentTime - when (currentTime > authExpiry authCode) $ - throwError err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text), "error_description" .= ("Authorization code expired" :: Text)]} - - -- Verify PKCE - unless (validateCodeVerifier codeVerifier (authCodeChallenge authCode)) $ - throwError err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text), "error_description" .= ("Invalid code verifier" :: Text)]} - - -- Create user for JWT - let oauthCfg = httpOAuthConfig config - emailDomain = maybe "example.com" demoEmailDomain oauthCfg - userName = maybe "User" demoUserName oauthCfg - user = - AuthUser - { userId = authUserId authCode - , userEmail = Just $ authUserId authCode <> "@" <> emailDomain - , userName = Just userName - } - - -- Generate tokens - accessTokenText <- generateJWTAccessToken user jwtSettings - refreshToken <- liftIO $ generateRefreshTokenWithConfig config - - -- Store tokens - liftIO $ atomically $ modifyTVar' oauthStateVar $ \s -> - s - { authCodes = Map.delete code (authCodes s) - , accessTokens = Map.insert accessTokenText user (accessTokens s) - , refreshTokens = Map.insert refreshToken (accessTokenText, user) (refreshTokens s) - } - - return - TokenResponse - { access_token = accessTokenText - , token_type = "Bearer" - , expires_in = Just $ maybe 3600 accessTokenExpirySeconds (httpOAuthConfig config) - , refresh_token = Just refreshToken - , scope = if null (authScopes authCode) then Nothing else Just (T.intercalate " " (authScopes authCode)) - } - --- | Handle refresh token grant -handleRefreshTokenGrant :: JWTSettings -> HTTPServerConfig -> TVar OAuthState -> Map Text Text -> Handler TokenResponse -handleRefreshTokenGrant jwtSettings config oauthStateVar params = do - refreshToken <- case Map.lookup "refresh_token" params of - Just t -> return t - Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_request" :: Text)]} - - -- Look up refresh token - oauthState <- liftIO $ readTVarIO oauthStateVar - (oldAccessToken, user) <- case Map.lookup refreshToken (refreshTokens oauthState) of - Just info -> return info - Nothing -> throwError err400{errBody = encode $ object ["error" .= ("invalid_grant" :: Text)]} - - -- Generate new JWT access token - newAccessTokenText <- generateJWTAccessToken user jwtSettings - - -- Update tokens - liftIO $ atomically $ modifyTVar' oauthStateVar $ \s -> - s - { accessTokens = Map.insert newAccessTokenText user $ Map.delete oldAccessToken (accessTokens s) - , refreshTokens = Map.insert refreshToken (newAccessTokenText, user) (refreshTokens s) - } - - return - TokenResponse - { access_token = newAccessTokenText - , token_type = "Bearer" - , expires_in = Just $ maybe 3600 accessTokenExpirySeconds (httpOAuthConfig config) - , refresh_token = Just refreshToken - , scope = Nothing - } - --- | Generate random authorization code -generateAuthCode :: IO Text -generateAuthCode = do - uuid <- UUID.nextRandom - return $ "code_" <> UUID.toText uuid - --- | Generate authorization code with configurable prefix -generateAuthCodeWithConfig :: HTTPServerConfig -> IO Text -generateAuthCodeWithConfig config = do - uuid <- UUID.nextRandom - let prefix = maybe "code_" authCodePrefix (httpOAuthConfig config) - return $ prefix <> UUID.toText uuid - --- | Generate JWT access token for user -generateJWTAccessToken :: AuthUser -> JWTSettings -> Handler Text -generateJWTAccessToken user jwtSettings = do - accessTokenResult <- liftIO $ makeJWT user jwtSettings Nothing - case accessTokenResult of - Left _err -> throwError err500{errBody = encode $ object ["error" .= ("Token generation failed" :: Text)]} - Right accessToken -> return $ TE.decodeUtf8 $ LBS.toStrict accessToken - --- | Generate refresh token with configurable prefix -generateRefreshTokenWithConfig :: HTTPServerConfig -> IO Text -generateRefreshTokenWithConfig config = do - uuid <- UUID.nextRandom - let prefix = maybe "rt_" refreshTokenPrefix (httpOAuthConfig config) - return $ prefix <> UUID.toText uuid - --- | Default demo OAuth configuration for testing purposes -defaultDemoOAuthConfig :: OAuthConfig -defaultDemoOAuthConfig = - OAuthConfig - { oauthEnabled = True - , oauthProviders = [] - , tokenValidationEndpoint = Nothing - , requireHTTPS = False -- For demo only - -- Default timing parameters - , authCodeExpirySeconds = 600 -- 10 minutes - , accessTokenExpirySeconds = 3600 -- 1 hour - -- Default OAuth parameters - , supportedScopes = ["mcp:read", "mcp:write"] - , supportedResponseTypes = ["code"] - , supportedGrantTypes = ["authorization_code", "refresh_token"] - , supportedAuthMethods = ["none"] - , supportedCodeChallengeMethods = ["S256"] - , -- Demo mode settings - autoApproveAuth = True - , demoUserIdTemplate = Just "test-user-{clientId}" - , demoEmailDomain = "example.com" - , demoUserName = "Test User" - , publicClientSecret = Just "" - , -- Default token prefixes - authCodePrefix = "code_" - , refreshTokenPrefix = "rt_" - , clientIdPrefix = "client_" - , -- Default response template - authorizationSuccessTemplate = Nothing - } - --- | Run the MCP server as an HTTP server -runServerHTTP :: (MCPServer MCPServerM) => HTTPServerConfig -> IO () -runServerHTTP config = do - -- Initialize JWT settings if OAuth is enabled - jwtSettings <- case httpJWK config of - Just jwk -> return $ defaultJWTSettings jwk - Nothing -> defaultJWTSettings <$> generateKey - - -- Initialize the server state - stateVar <- newTVarIO $ initialServerState (httpCapabilities config) - - -- Initialize OAuth state - oauthStateVar <- - newTVarIO $ - OAuthState - { authCodes = Map.empty - , accessTokens = Map.empty - , refreshTokens = Map.empty - , registeredClients = Map.empty - } - - putStrLn $ "Starting MCP HTTP Server on port " ++ show (httpPort config) ++ "..." - - when (maybe False oauthEnabled (httpOAuthConfig config)) $ do - putStrLn "OAuth authentication enabled" - putStrLn $ "Authorization endpoint: " ++ T.unpack (httpBaseUrl config) ++ "/authorize" - putStrLn $ "Token endpoint: " ++ T.unpack (httpBaseUrl config) ++ "/token" - case httpOAuthConfig config >>= \cfg -> if null (oauthProviders cfg) then Nothing else Just (oauthProviders cfg) of - Just providers -> do - putStrLn $ "OAuth providers: " ++ T.unpack (T.intercalate ", " (map providerName providers)) - when (any requiresPKCE providers) $ putStrLn "PKCE enabled (required by MCP spec)" - Nothing -> return () - - run (httpPort config) (mcpApp config stateVar oauthStateVar jwtSettings) +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module: MCP.Server.HTTP +License: MPL-2.0 +Maintainer: , + +Servant-based HTTP transport for the MCP server. + +This module provides a JWT-authenticated Servant API that accepts +JSON-RPC requests via POST and returns responses as SSE streams. +-} +module MCP.Server.HTTP ( + -- * Servant API + MCPAPI, + mcpAPI, + handleMCPRequest, + handleMCPEvents, +) where + +import Control.Concurrent.MVar +import Control.Monad (when) +import Control.Monad.Except +import Control.Monad.State.Lazy +import Data.Aeson (encode, object, toJSON, (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.IntMap qualified as IM +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding (encodeUtf8) +import Data.Tuple (swap) +import MCP.Server.Common +import Network.HTTP.Media ((//)) +import Servant +import Servant.Auth.Server (Auth, AuthResult (..), JWT) +import Servant.Auth.Server qualified as AuthServer +import Servant.Types.SourceT +import Servant.Types.SourceT qualified as Source + +-- | Frame for JSON-RPC messages. +data JSONRPCFrame + +instance FramingRender JSONRPCFrame where + framingRender _ f = fmap (\x -> f x <> "\n") + +-- | Event for JSON-RPC messages. +data JSONRPCEvent + +instance Accept JSONRPCEvent where + contentType _ = "text" // "event-stream" + +instance MimeRender JSONRPCEvent JSONRPCMessage where + mimeRender _ val = + ("event: message\n" <>) $ + ("data:" <> encode (toJSON val) <> "\n") + +{- | Servant API type for the MCP endpoint. + +Accepts JSON-RPC requests with JWT authentication via servant-auth. +All MCP methods are multiplexed through this single endpoint. +-} +type MCPAPI = + "mcp" + :> Auth '[JWT] MCPHandlerUser + -- \^ JWT authentication using servant-auth + :> ReqBody '[JSON] JSONRPCMessage + -- \^ JSON-RPC request + :> StreamPost JSONRPCFrame JSONRPCEvent (SourceIO JSONRPCMessage) + -- \^ Stream of JSON-RPC responses + :<|> "mcp" + :> Auth '[JWT] MCPHandlerUser + :> StreamGet JSONRPCFrame JSONRPCEvent (SourceIO JSONRPCMessage) + +-- | Type of the MCP API +mcpAPI :: MVar MCPServerState -> Server MCPAPI +mcpAPI state_var = + handleMCPRequest state_var + :<|> handleMCPEvents + +-- | This handles the Get /mcp requests. Does nothing for now except authenticate. +handleMCPEvents :: + AuthResult MCPHandlerUser -> + Handler (SourceIO JSONRPCMessage) +handleMCPEvents auth_result = do + case auth_result of + AuthServer.NoSuchUser -> throwError err401{errBody = "Invalid authentication credentials"} + AuthServer.BadPassword -> throwError err401{errBody = "Authentication failed"} + AuthServer.Indefinite -> throwError err401{errBody = "Authentication error"} + AuthServer.Authenticated _ -> return $ fromStepT $ Stop + +{- | Handle incoming MCP JSON-RPC requests. + +This is the main entry point for MCP requests. It: + +1. Validates authentication via servant-auth (automatically handled) +2. Parses the JSON-RPC request +3. Routes to the appropriate handler based on method name +4. Manages server state updates +5. Returns properly formatted JSON-RPC responses + +The server enforces initialization before accepting most methods. +Only "ping" and "initialize" can be called before initialization. +-} +handleMCPRequest :: + MVar MCPServerState -> + AuthResult MCPHandlerUser -> + JSONRPCMessage -> + Handler (SourceIO JSONRPCMessage) +handleMCPRequest state_var auth_result request_value = + fromStepT <$> do + case auth_result of + AuthServer.NoSuchUser -> mcpAuthError "Invalid authentication credentials" + AuthServer.BadPassword -> mcpAuthError "Authentication failed" + AuthServer.Indefinite -> mcpAuthError "Authentication error" + AuthServer.Authenticated auth_user -> do + MCPServerState + { mcp_server_initialized = server_initialized + , mcp_log_level = log_level + } <- + liftIO $ readMVar state_var + case log_level of + Nothing -> return () + Just level -> + when (level >= Debug) $ + liftIO $ + BSL.putStrLn $ + "[request] " <> encode request_value + + case request_value of + NotificationMessage _ -> + return $ + flip Yield Stop $ + NotificationMessage $ + JSONRPCNotification rPC_VERSION "ok" Aeson.Null + ErrorMessage err -> do + throwError err400{errBody = encode err} + -- Here we fill in the MVar for any pending responses from the client + ResponseMessage (JSONRPCResponse _ (RequestId req_id) result) -> do + cur_st <- liftIO $ readMVar state_var + case Aeson.fromJSON req_id of + Aeson.Error err -> return (Source.Error $ "Invalid request ID: " <> err) + Aeson.Success req_index -> + case IM.lookup req_index (mcp_pending_responses cur_st) of + Nothing -> + return $ Source.Error "Server received unexpected response" + Just mvar -> liftIO $ do + modifyMVar_ state_var $ \cur_st' -> + return cur_st'{mcp_pending_responses = IM.delete req_index (mcp_pending_responses cur_st')} + putMVar mvar result + return Stop + RequestMessage (JSONRPCRequest jsonrpc req_id method params) -> do + -- Validate JSON-RPC version + let bs_rpc_version = BSL.fromStrict (encodeUtf8 rPC_VERSION) + when (jsonrpc /= rPC_VERSION) $ + throwError err400{errBody = "Invalid jsonrpc version, must be '" <> bs_rpc_version <> "'"} + + -- Validate request ID + when (not $ isValidRequestId req_id) $ + throwError err400{errBody = "Invalid request ID, must be string, number, or null"} + + -- Initialize handler state on first initialize request + when (not server_initialized && method == "initialize") $ + liftIO $ + modifyMVar_ state_var $ + \cur_st@MCPServerState + { mcp_handler_state = handler_st + , mcp_handler_init = mb_handler_init + } -> case mb_handler_init of + Nothing -> return cur_st + Just handler_init -> do + h_st' <- handler_init auth_user handler_st + return cur_st{mcp_handler_state = h_st'} + + -- Process the request routing to the appropriate handler + res <- liftIO $ modifyMVar state_var $ fmap swap <$> runStateT (processMethod server_initialized method params) + + -- Log the response if debug level + cur_log_level <- liftIO $ mcp_log_level <$> readMVar state_var + case cur_log_level of + Just level | level >= Debug -> liftIO $ do + let prefix = "[response] " <> BSL.fromStrict (encodeUtf8 method) <> " -> " + let body = case res of + ProcessSuccess val -> encode val + ProcessRPCError code msg -> encode $ object ["error" .= msg, "code" .= code] + ProcessServerError err -> encode $ object ["serverError" .= err] + ProcessClientInput{} -> "client-input" + BSL.putStrLn $ prefix <> body + _ -> return () + + -- Get the final result to return + final_result <- liftIO $ handleProcessResult req_id res + + -- Finalize handler state after use + liftIO $ + modifyMVar_ state_var $ + \st@MCPServerState + { mcp_handler_state = handler_st + , mcp_handler_finalize = mb_finalizer + } -> do + case mb_finalizer of + Nothing -> return st + Just handler_finalize -> do + -- Call the finalizer to clean up the handler state + handler_st' <- handler_finalize handler_st + -- Update the state with the finalized handler state + let st' = st{mcp_handler_state = handler_st'} + -- Return the updated state + return st' + return final_result + where + -- Handle the result of processing a request + handleProcessResult :: + (Aeson.ToJSON a) => + RequestId -> + ProcessResult a -> + IO (StepT IO JSONRPCMessage) + handleProcessResult req_id = + \case + ProcessServerError err -> + return (Source.Error $ T.unpack err) + ProcessRPCError code msg -> + return $ + flip Yield Stop $ + ErrorMessage $ + JSONRPCError rPC_VERSION req_id $ + JSONRPCErrorInfo code msg Nothing + ProcessClientInput ci_mthd ci_params ci_cont -> do + mvar <- liftIO newEmptyMVar + r_id <- liftIO $ modifyMVar state_var $ \cur_st -> do + let pr = mcp_pending_responses cur_st + let pr_id = mcp_pending_responses_next cur_st + let pr' = IM.insert pr_id mvar pr + let pr_id' = pr_id + 1 + return + ( cur_st{mcp_pending_responses = pr', mcp_pending_responses_next = pr_id'} + , pr_id + ) + let msg = + RequestMessage $ + JSONRPCRequest rPC_VERSION (RequestId $ Aeson.Number $ fromIntegral r_id) ci_mthd ci_params + return $ + Yield msg $ + Effect $ do + -- Wait for the response + ci_resp <- liftIO $ takeMVar mvar + -- Make sure to use the current updated state + cur_st <- liftIO $ readMVar state_var + (result, cur_st') <- + liftIO $ + flip runStateT cur_st $ + runExceptT $ + ci_cont ci_resp + liftIO $ modifyMVar_ state_var $ \_ -> return cur_st' + case result of + Left err -> do + return $ Source.Error $ T.unpack err + Right response -> + handleProcessResult req_id response + ProcessSuccess response -> do + return $ + flip Yield Stop $ + ResponseMessage $ + JSONRPCResponse rPC_VERSION req_id (recurReplaceMeta $ toJSON response) + + -- Helper to throw unauthorized errors + mcpAuthError :: Text -> Handler (StepT IO JSONRPCMessage) + mcpAuthError err = throwError err401{errBody = encode $ object ["error" .= err]} diff --git a/src/MCP/Server/StdIO.hs b/src/MCP/Server/StdIO.hs deleted file mode 100644 --- a/src/MCP/Server/StdIO.hs +++ /dev/null @@ -1,280 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : MCP.Server.StdIO -Description : MCP server implementation for stdin/stdout communication -Copyright : (C) 2025 Matthias Pall Gissurarson -License : MIT -Maintainer : mpg@mpg.is -Stability : experimental -Portability : GHC - -This module provides MCP server implementation for stdin/stdout streams. --} -module MCP.Server.StdIO ( - -- * Server Runner - runServer, - ServerConfig (..), -) where - -import Control.Exception (catch, throwIO) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ask) -import Control.Monad.State.Strict (get, put) -import Data.Aeson (decode, fromJSON, object, toJSON) -import Data.Aeson qualified as Aeson -import Data.ByteString.Char8 qualified as BSC -import Data.ByteString.Lazy qualified as LBS -import Data.Text qualified as T -import System.IO.Error (isEOFError) - -import MCP.Protocol -import MCP.Server (MCPServer (..), MCPServerM, ServerConfig (..), ServerState (..), initialServerState, runMCPServer, sendError, sendResponse) -import MCP.Types - --- | Handle an incoming JSON-RPC message -handleMessage :: (MCPServer MCPServerM) => BSC.ByteString -> MCPServerM (Maybe ()) -handleMessage input = do - case decode (LBS.fromStrict input) :: Maybe JSONRPCMessage of - Nothing -> do - config <- ask - sendError (configOutput config) (RequestId (toJSON ("unknown" :: T.Text))) $ - JSONRPCErrorInfo (-32700) "Parse error" Nothing - return Nothing - Just msg -> case msg of - RequestMessage req -> do - handleRequest req - return (Just ()) - NotificationMessage notif -> do - handleNotification notif - return (Just ()) - _ -> do - config <- ask - sendError (configOutput config) (RequestId (toJSON ("unknown" :: T.Text))) $ - JSONRPCErrorInfo (-32600) "Invalid Request" Nothing - return Nothing - --- | Handle a JSON-RPC request -handleRequest :: (MCPServer MCPServerM) => JSONRPCRequest -> MCPServerM () -handleRequest (JSONRPCRequest _ reqId method params) = do - config <- ask - state <- get - - case method of - "initialize" -> case params of - Just p -> case fromJSON p of - Aeson.Success initParams -> handleInitialize reqId initParams - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "ping" -> handlePing reqId - "resources/list" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListResources listParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListResources (ListResourcesParams Nothing) - sendResponse (configOutput config) reqId result - "resources/read" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success readParams -> do - result <- handleReadResource readParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "resources/templates/list" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListResourceTemplates listParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListResourceTemplates (ListResourceTemplatesParams Nothing) - sendResponse (configOutput config) reqId result - "prompts/list" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListPrompts listParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListPrompts (ListPromptsParams Nothing) - sendResponse (configOutput config) reqId result - "prompts/get" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success getParams -> do - result <- handleGetPrompt getParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "tools/list" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListTools listParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListTools (ListToolsParams Nothing) - sendResponse (configOutput config) reqId result - "tools/call" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success callParams -> do - result <- handleCallTool callParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "completion/complete" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success completeParams -> do - result <- handleComplete completeParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "logging/setLevel" -> case params of - Just p -> case fromJSON p of - Aeson.Success setLevelParams -> do - _ <- handleSetLevel setLevelParams - -- SetLevel response is just an empty object - sendResponse (configOutput config) reqId (object []) - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - _ -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32601) "Method not found" Nothing - -handleInitialize :: RequestId -> InitializeParams -> MCPServerM () -handleInitialize reqId params = do - config <- ask - state <- get - - let InitializeParams{capabilities = clientCaps} = params - - put - state - { serverInitialized = True - , clientCapabilities = Just clientCaps - , serverInfo = Just (configServerInfo config) - } - - let result = - InitializeResult - { protocolVersion = "2024-11-05" - , capabilities = serverCapabilities state - , serverInfo = configServerInfo config - , instructions = Nothing - , _meta = Nothing - } - - sendResponse (configOutput config) reqId result - -handlePing :: RequestId -> MCPServerM () -handlePing reqId = do - config <- ask - -- Ping response is just an empty object in MCP - sendResponse (configOutput config) reqId (object []) - --- | Handle a JSON-RPC notification -handleNotification :: JSONRPCNotification -> MCPServerM () -handleNotification _ = do - return () - --- | Run the MCP server with the given configuration -runServer :: (MCPServer MCPServerM) => ServerConfig -> IO () -runServer config = do - let initialState = initialServerState (configCapabilities config) - - let loop = do - eofOrLine <- - liftIO $ - catch - (Right <$> BSC.hGetLine (configInput config)) - (\e -> if isEOFError e then return (Left ()) else throwIO e) - case eofOrLine of - Left () -> return () -- EOF reached, exit gracefully - Right line -> do - result <- handleMessage line - case result of - Just () -> loop - Nothing -> return () - - result <- runMCPServer config initialState loop - case result of - Left err -> putStrLn $ "Server error: " ++ T.unpack err - Right _ -> return () -- Don't print "Server terminated" for clean EOF diff --git a/src/MCP/Server/Stdio.hs b/src/MCP/Server/Stdio.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Stdio.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +{- | +Module: MCP.Server.Stdio +License: MPL-2.0 +Maintainer: , + +Stdio transport for the MCP server. + +Reads JSON-RPC messages line-by-line from an input handle and writes +responses to an output handle. This transport does not use JWT +authentication; it is assumed that the process boundary provides +authentication. +-} +module MCP.Server.Stdio ( + serveStdio, +) where + +import Control.Monad.Except +import Control.Monad.State.Lazy +import Data.Aeson (encode) +import Data.Aeson qualified as Aeson +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.IORef +import Data.Text qualified as T +import MCP.Server.Common +import System.IO (BufferMode (..), Handle, hFlush, hIsEOF, hSetBuffering) + +{- | Run the MCP server over stdio transport. + +Reads JSON-RPC messages line-by-line from the input handle, +processes them through the standard MCP message handler, and writes +JSON-RPC responses line-by-line to the output handle. + +Stdio transport does not use JWT authentication; it is assumed that +the process boundary provides authentication. + +The server runs until EOF is reached on the input handle. + +__Note:__ When a handler returns 'ProcessClientInput', the server writes a +request to the client and blocks on the input handle until a response +arrives. There is no timeout — if the client never responds, the server +will block indefinitely. +-} +serveStdio :: + -- | Input handle (typically stdin) + Handle -> + -- | Output handle (typically stdout) + Handle -> + -- | Initial server state + MCPServerState -> + IO () +serveStdio h_in h_out initial_state = do + hSetBuffering h_in LineBuffering + hSetBuffering h_out LineBuffering + state_ref <- newIORef initial_state + loop state_ref + where + loop :: IORef MCPServerState -> IO () + loop state_ref = do + eof <- hIsEOF h_in + if eof + then return () + else do + line <- BS.hGetLine h_in + case Aeson.eitherDecodeStrict' line of + Left err -> do + -- JSON parse error — write error response with null id + writeMsg $ + ErrorMessage $ + JSONRPCError rPC_VERSION (RequestId Aeson.Null) $ + JSONRPCErrorInfo pARSE_ERROR (T.pack err) Nothing + loop state_ref + Right msg -> do + processStdioMessage state_ref msg + loop state_ref + + processStdioMessage :: IORef MCPServerState -> JSONRPCMessage -> IO () + processStdioMessage state_ref = \case + NotificationMessage _ -> + -- Notifications don't produce a response + return () + ErrorMessage _ -> + -- Client sent an error — nothing to respond to + return () + ResponseMessage _ -> + -- Unexpected response from client outside of ProcessClientInput + return () + RequestMessage (JSONRPCRequest jsonrpc req_id method params) -> do + -- Validate JSON-RPC version + if jsonrpc /= rPC_VERSION + then + writeMsg $ + ErrorMessage $ + JSONRPCError rPC_VERSION req_id $ + JSONRPCErrorInfo iNVALID_REQUEST "Invalid jsonrpc version" Nothing + else do + -- Validate request ID + if not (isValidRequestId req_id) + then + writeMsg $ + ErrorMessage $ + JSONRPCError rPC_VERSION req_id $ + JSONRPCErrorInfo iNVALID_REQUEST "Invalid request ID" Nothing + else do + cur_st <- readIORef state_ref + let initialized = mcp_server_initialized cur_st + + -- Process the request + (res, new_st) <- runStateT (processMethod initialized method params) cur_st + writeIORef state_ref new_st + + -- Handle ProcessClientInput by synchronous read/write + final_res <- resolveClientInput state_ref res + + -- Convert result to response message + case final_res of + ProcessServerError err -> + writeMsg $ + ErrorMessage $ + JSONRPCError rPC_VERSION req_id $ + JSONRPCErrorInfo iNTERNAL_ERROR err Nothing + ProcessRPCError rpc_code rpc_msg -> + writeMsg $ + ErrorMessage $ + JSONRPCError rPC_VERSION req_id $ + JSONRPCErrorInfo rpc_code rpc_msg Nothing + ProcessSuccess response -> + writeMsg $ + ResponseMessage $ + JSONRPCResponse rPC_VERSION req_id (recurReplaceMeta response) + ProcessClientInput{} -> + -- Should not happen after resolveClientInput + writeMsg $ + ErrorMessage $ + JSONRPCError rPC_VERSION req_id $ + JSONRPCErrorInfo iNTERNAL_ERROR "Unresolved client input" Nothing + + -- Finalize handler state + st <- readIORef state_ref + case mcp_handler_finalize st of + Nothing -> return () + Just finalizer -> do + h_st' <- finalizer (mcp_handler_state st) + writeIORef state_ref st{mcp_handler_state = h_st'} + + -- \| Resolve ProcessClientInput by writing a request to the client and + -- reading the response synchronously from stdin. + resolveClientInput :: IORef MCPServerState -> ProcessResult Aeson.Value -> IO (ProcessResult Aeson.Value) + resolveClientInput state_ref = \case + ProcessClientInput ci_mthd ci_params ci_cont -> do + -- Assign a request ID + st <- readIORef state_ref + let r_id = mcp_pending_responses_next st + writeIORef state_ref st{mcp_pending_responses_next = r_id + 1} + + -- Write the server-to-client request + writeMsg $ + RequestMessage $ + JSONRPCRequest rPC_VERSION (RequestId $ Aeson.Number $ fromIntegral r_id) ci_mthd ci_params + + -- Read the client's response synchronously + resp_line <- BS.hGetLine h_in + case Aeson.eitherDecodeStrict' @JSONRPCMessage resp_line of + Right (ResponseMessage (JSONRPCResponse _ _ result)) -> do + -- Run the continuation with the client's response + cur_st <- readIORef state_ref + (cont_result, new_st) <- runStateT (runExceptT $ ci_cont result) cur_st + writeIORef state_ref new_st + case cont_result of + Left err -> return $ ProcessServerError err + Right next_res -> resolveClientInput state_ref next_res + Right (ErrorMessage (JSONRPCError _ _ (JSONRPCErrorInfo _ err_msg _))) -> + return $ ProcessServerError err_msg + _ -> + return $ ProcessServerError "Expected response to client input request" + other -> return other + + writeMsg :: JSONRPCMessage -> IO () + writeMsg msg = do + BSL.hPut h_out (encode msg) + BSL.hPut h_out "\n" + hFlush h_out diff --git a/src/MCP/Types.hs b/src/MCP/Types.hs deleted file mode 100644 --- a/src/MCP/Types.hs +++ /dev/null @@ -1,612 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -{- | -Module : MCP.Types -Description : Core types for the Model Context Protocol (MCP) -Copyright : (C) 2025 Matthias Pall Gissurarson -License : MIT -Maintainer : mpg@mpg.is -Stability : experimental -Portability : GHC - -This module defines the core types used in the Model Context Protocol (MCP), -including JSON-RPC message types, client/server capabilities, resources, -tools, prompts, and various request/response types. --} -module MCP.Types ( - -- * Basic Types - RequestId (..), - Role (..), - Cursor (..), - ProgressToken (..), - LoggingLevel (..), - - -- * Content Types - Annotations (..), - TextContent (..), - ImageContent (..), - AudioContent (..), - EmbeddedResource (..), - Content (..), - - -- * Resource Types - ResourceContents (..), - TextResourceContents (..), - BlobResourceContents (..), - Resource (..), - ResourceTemplate (..), - ResourceReference (..), - - -- * Tool Types - ToolAnnotations (..), - Tool (..), - InputSchema (..), - - -- * Prompt Types - PromptArgument (..), - Prompt (..), - PromptMessage (..), - PromptReference (..), - - -- * Model Types - ModelHint (..), - ModelPreferences (..), - IncludeContext (..), - SamplingMessage (..), - - -- * Capability Types - ClientCapabilities (..), - ServerCapabilities (..), - RootsCapability (..), - PromptsCapability (..), - ResourcesCapability (..), - ToolsCapability (..), - CompletionsCapability (..), - LoggingCapability (..), - SamplingCapability (..), - ExperimentalCapability (..), - - -- * Implementation Info - Implementation (..), - - -- * Roots - Root (..), - - -- * Result Types - Result (..), - Metadata (..), -) where - -import Control.Applicative (Alternative ((<|>))) -import Data.Aeson hiding (Error, Result) -import Data.Aeson.TH -import Data.Map (Map) -import Data.Text (Text) -import GHC.Generics - --- | A uniquely identifying ID for a request in JSON-RPC -newtype RequestId = RequestId Value - deriving stock (Show, Eq) - deriving newtype (ToJSON, FromJSON) - --- | The sender or recipient of messages and data in a conversation -data Role = User | Assistant - deriving stock (Show, Eq, Generic) - -instance ToJSON Role where - toJSON User = "user" - toJSON Assistant = "assistant" - -instance FromJSON Role where - parseJSON = withText "Role" $ \case - "user" -> pure User - "assistant" -> pure Assistant - other -> fail $ "Unknown role: " <> show other - --- | An opaque token used to represent a cursor for pagination -newtype Cursor = Cursor Text - deriving stock (Show, Eq) - deriving newtype (ToJSON, FromJSON) - --- | A progress token, used to associate progress notifications with the original request -newtype ProgressToken = ProgressToken Value - deriving stock (Show, Eq) - deriving newtype (ToJSON, FromJSON) - --- | The severity of a log message -data LoggingLevel = Alert | Critical | Debug | Emergency | Error | Info | Notice | Warning - deriving stock (Show, Eq, Generic) - -instance ToJSON LoggingLevel where - toJSON Alert = "alert" - toJSON Critical = "critical" - toJSON Debug = "debug" - toJSON Emergency = "emergency" - toJSON Error = "error" - toJSON Info = "info" - toJSON Notice = "notice" - toJSON Warning = "warning" - -instance FromJSON LoggingLevel where - parseJSON = withText "LoggingLevel" $ \case - "alert" -> pure Alert - "critical" -> pure Critical - "debug" -> pure Debug - "emergency" -> pure Emergency - "error" -> pure Error - "info" -> pure Info - "notice" -> pure Notice - "warning" -> pure Warning - other -> fail $ "Unknown logging level: " <> show other - --- | Optional annotations for the client -data Annotations = Annotations - { audience :: Maybe [Role] - , priority :: Maybe Double -- 0.0 to 1.0 - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''Annotations) - --- | Text provided to or from an LLM -data TextContent = TextContent - { textType :: Text -- Always "text" - , text :: Text - , annotations :: Maybe Annotations - } - deriving stock (Show, Eq, Generic) - -instance ToJSON TextContent where - toJSON (TextContent _ txt anns) = - object $ - [ "type" .= ("text" :: Text) - , "text" .= txt - ] - ++ maybe [] (\a -> ["annotations" .= a]) anns - -instance FromJSON TextContent where - parseJSON = withObject "TextContent" $ \o -> do - ty <- o .: "type" - if ty == ("text" :: Text) - then TextContent ty <$> o .: "text" <*> o .:? "annotations" - else fail "Expected type 'text'" - --- | An image provided to or from an LLM -data ImageContent = ImageContent - { imageType :: Text -- Always "image" - , data' :: Text -- base64-encoded image data - , mimeType :: Text - , annotations :: Maybe Annotations - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ImageContent where - toJSON (ImageContent _ dat mime anns) = - object $ - [ "type" .= ("image" :: Text) - , "data" .= dat - , "mimeType" .= mime - ] - ++ maybe [] (\a -> ["annotations" .= a]) anns - -instance FromJSON ImageContent where - parseJSON = withObject "ImageContent" $ \o -> do - ty <- o .: "type" - if ty == ("image" :: Text) - then ImageContent ty <$> o .: "data" <*> o .: "mimeType" <*> o .:? "annotations" - else fail "Expected type 'image'" - --- | Audio provided to or from an LLM -data AudioContent = AudioContent - { audioType :: Text -- Always "audio" - , data' :: Text -- base64-encoded audio data - , mimeType :: Text - , annotations :: Maybe Annotations - } - deriving stock (Show, Eq, Generic) - -instance ToJSON AudioContent where - toJSON (AudioContent _ dat mime anns) = - object $ - [ "type" .= ("audio" :: Text) - , "data" .= dat - , "mimeType" .= mime - ] - ++ maybe [] (\a -> ["annotations" .= a]) anns - -instance FromJSON AudioContent where - parseJSON = withObject "AudioContent" $ \o -> do - ty <- o .: "type" - if ty == ("audio" :: Text) - then AudioContent ty <$> o .: "data" <*> o .: "mimeType" <*> o .:? "annotations" - else fail "Expected type 'audio'" - --- | Text resource contents -data TextResourceContents = TextResourceContents - { uri :: Text - , text :: Text - , mimeType :: Maybe Text - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''TextResourceContents) - --- | Blob resource contents -data BlobResourceContents = BlobResourceContents - { uri :: Text - , blob :: Text -- base64-encoded - , mimeType :: Maybe Text - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''BlobResourceContents) - --- | Resource contents (text or blob) -data ResourceContents - = TextResource TextResourceContents - | BlobResource BlobResourceContents - deriving stock (Show, Eq, Generic) - -instance ToJSON ResourceContents where - toJSON (TextResource t) = toJSON t - toJSON (BlobResource b) = toJSON b - -instance FromJSON ResourceContents where - parseJSON v = - (TextResource <$> parseJSON v) - <|> (BlobResource <$> parseJSON v) - --- | The contents of a resource, embedded into a prompt or tool call result -data EmbeddedResource = EmbeddedResource - { resourceType :: Text -- Always "resource" - , resource :: ResourceContents - , annotations :: Maybe Annotations - } - deriving stock (Show, Eq, Generic) - -instance ToJSON EmbeddedResource where - toJSON (EmbeddedResource _ res anns) = - object $ - [ "type" .= ("resource" :: Text) - , "resource" .= res - ] - ++ maybe [] (\a -> ["annotations" .= a]) anns - -instance FromJSON EmbeddedResource where - parseJSON = withObject "EmbeddedResource" $ \o -> do - ty <- o .: "type" - if ty == ("resource" :: Text) - then EmbeddedResource ty <$> o .: "resource" <*> o .:? "annotations" - else fail "Expected type 'resource'" - --- | Content that can be text, image, audio, or embedded resource -data Content - = TextContentType TextContent - | ImageContentType ImageContent - | AudioContentType AudioContent - | EmbeddedResourceType EmbeddedResource - deriving stock (Show, Eq, Generic) - -instance ToJSON Content where - toJSON (TextContentType c) = toJSON c - toJSON (ImageContentType c) = toJSON c - toJSON (AudioContentType c) = toJSON c - toJSON (EmbeddedResourceType c) = toJSON c - -instance FromJSON Content where - parseJSON v = - (TextContentType <$> parseJSON v) - <|> (ImageContentType <$> parseJSON v) - <|> (AudioContentType <$> parseJSON v) - <|> (EmbeddedResourceType <$> parseJSON v) - --- | A known resource that the server is capable of reading -data Resource = Resource - { uri :: Text - , name :: Text - , description :: Maybe Text - , mimeType :: Maybe Text - , size :: Maybe Int - , annotations :: Maybe Annotations - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''Resource) - --- | A template description for resources available on the server -data ResourceTemplate = ResourceTemplate - { name :: Text - , uriTemplate :: Text - , description :: Maybe Text - , mimeType :: Maybe Text - , annotations :: Maybe Annotations - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ResourceTemplate) - --- | A reference to a resource or resource template definition -data ResourceReference = ResourceReference - { refType :: Text -- Always "ref/resource" - , uri :: Text - } - deriving stock (Show, Eq, Generic) - -instance ToJSON ResourceReference where - toJSON (ResourceReference _ u) = - object - [ "type" .= ("ref/resource" :: Text) - , "uri" .= u - ] - -instance FromJSON ResourceReference where - parseJSON = withObject "ResourceReference" $ \o -> do - ty <- o .: "type" - if ty == ("ref/resource" :: Text) - then ResourceReference ty <$> o .: "uri" - else fail "Expected type 'ref/resource'" - --- | Additional properties describing a Tool to clients -data ToolAnnotations = ToolAnnotations - { title :: Maybe Text - , readOnlyHint :: Maybe Bool - , destructiveHint :: Maybe Bool - , idempotentHint :: Maybe Bool - , openWorldHint :: Maybe Bool - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ToolAnnotations) - --- | Input schema for a tool -data InputSchema = InputSchema - { schemaType :: Text -- Always "object" - , properties :: Maybe (Map Text Value) - , required :: Maybe [Text] - } - deriving stock (Show, Eq, Generic) - -instance ToJSON InputSchema where - toJSON (InputSchema _ props req) = - object $ - [ "type" .= ("object" :: Text) - ] - ++ maybe [] (\p -> ["properties" .= p]) props - ++ maybe [] (\r -> ["required" .= r]) req - -instance FromJSON InputSchema where - parseJSON = withObject "InputSchema" $ \o -> do - ty <- o .: "type" - if ty == ("object" :: Text) - then InputSchema ty <$> o .:? "properties" <*> o .:? "required" - else fail "Expected type 'object'" - --- | Definition for a tool the client can call -data Tool = Tool - { name :: Text - , description :: Maybe Text - , inputSchema :: InputSchema - , annotations :: Maybe ToolAnnotations - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''Tool) - --- | Describes an argument that a prompt can accept -data PromptArgument = PromptArgument - { name :: Text - , description :: Maybe Text - , required :: Maybe Bool - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''PromptArgument) - --- | A prompt or prompt template that the server offers -data Prompt = Prompt - { name :: Text - , description :: Maybe Text - , arguments :: Maybe [PromptArgument] - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''Prompt) - --- | Describes a message returned as part of a prompt -data PromptMessage = PromptMessage - { role :: Role - , content :: Content - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''PromptMessage) - --- | Identifies a prompt -data PromptReference = PromptReference - { refType :: Text -- Always "ref/prompt" - , name :: Text - } - deriving stock (Show, Eq, Generic) - -instance ToJSON PromptReference where - toJSON (PromptReference _ n) = - object - [ "type" .= ("ref/prompt" :: Text) - , "name" .= n - ] - -instance FromJSON PromptReference where - parseJSON = withObject "PromptReference" $ \o -> do - ty <- o .: "type" - if ty == ("ref/prompt" :: Text) - then PromptReference ty <$> o .: "name" - else fail "Expected type 'ref/prompt'" - --- | Hints to use for model selection -data ModelHint where - ModelHint :: {name :: Maybe Text} -> ModelHint - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ModelHint) - --- | The server's preferences for model selection -data ModelPreferences = ModelPreferences - { hints :: Maybe [ModelHint] - , costPriority :: Maybe Double -- 0.0 to 1.0 - , speedPriority :: Maybe Double -- 0.0 to 1.0 - , intelligencePriority :: Maybe Double -- 0.0 to 1.0 - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ModelPreferences) - --- | Include context options for sampling -data IncludeContext = AllServers | None | ThisServer - deriving stock (Show, Eq, Generic) - -instance ToJSON IncludeContext where - toJSON AllServers = "allServers" - toJSON None = "none" - toJSON ThisServer = "thisServer" - -instance FromJSON IncludeContext where - parseJSON = withText "IncludeContext" $ \case - "allServers" -> pure AllServers - "none" -> pure None - "thisServer" -> pure ThisServer - other -> fail $ "Unknown include context: " <> show other - --- | Describes a message issued to or received from an LLM API -data SamplingMessage = SamplingMessage - { role :: Role - , content :: Content - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''SamplingMessage) - --- | Roots capability -data RootsCapability where - RootsCapability :: {listChanged :: Maybe Bool} -> RootsCapability - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''RootsCapability) - --- | Prompts capability -data PromptsCapability where - PromptsCapability :: - {listChanged :: Maybe Bool} -> - PromptsCapability - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''PromptsCapability) - --- | Resources capability -data ResourcesCapability = ResourcesCapability - { listChanged :: Maybe Bool - , subscribe :: Maybe Bool - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ResourcesCapability) - --- | Tools capability -data ToolsCapability where - ToolsCapability :: {listChanged :: Maybe Bool} -> ToolsCapability - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ToolsCapability) - --- | Completions capability -data CompletionsCapability = CompletionsCapability - deriving stock (Show, Eq, Generic) - -instance ToJSON CompletionsCapability where - toJSON _ = object [] - -instance FromJSON CompletionsCapability where - parseJSON = withObject "CompletionsCapability" $ \_ -> pure CompletionsCapability - --- | Logging capability -data LoggingCapability = LoggingCapability - deriving stock (Show, Eq, Generic) - -instance ToJSON LoggingCapability where - toJSON _ = object [] - -instance FromJSON LoggingCapability where - parseJSON = withObject "LoggingCapability" $ \_ -> pure LoggingCapability - --- | Sampling capability -data SamplingCapability = SamplingCapability - deriving stock (Show, Eq, Generic) - -instance ToJSON SamplingCapability where - toJSON _ = object [] - -instance FromJSON SamplingCapability where - parseJSON = withObject "SamplingCapability" $ \_ -> pure SamplingCapability - --- | Experimental capability -newtype ExperimentalCapability = ExperimentalCapability (Map Text Value) - deriving stock (Show, Eq, Generic) - deriving newtype (ToJSON, FromJSON) - --- | Capabilities a client may support -data ClientCapabilities = ClientCapabilities - { roots :: Maybe RootsCapability - , sampling :: Maybe SamplingCapability - , experimental :: Maybe ExperimentalCapability - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ClientCapabilities) - --- | Capabilities that a server may support -data ServerCapabilities = ServerCapabilities - { logging :: Maybe LoggingCapability - , prompts :: Maybe PromptsCapability - , resources :: Maybe ResourcesCapability - , tools :: Maybe ToolsCapability - , completions :: Maybe CompletionsCapability - , experimental :: Maybe ExperimentalCapability - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''ServerCapabilities) - --- | Describes the name and version of an MCP implementation -data Implementation = Implementation - { name :: Text - , version :: Text - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions ''Implementation) - --- | Represents a root directory or file that the server can operate on -data Root = Root - { uri :: Text - , name :: Maybe Text - } - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True} ''Root) - --- | Metadata for results -newtype Metadata = Metadata (Map Text Value) - deriving stock (Show, Eq, Generic) - deriving newtype (ToJSON, FromJSON) - --- | Base result type -data Result where - Result :: {_meta :: Maybe Metadata} -> Result - deriving stock (Show, Eq, Generic) - -$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''Result) diff --git a/test/MCP/Integration.hs b/test/MCP/Integration.hs new file mode 100644 --- /dev/null +++ b/test/MCP/Integration.hs @@ -0,0 +1,651 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module: MCP.Integration +License: MPL-2.0 +Maintainer: , + +Integration tests for Model Context Protocol (MCP) server implementation +following the Servant testing cookbook approach +-} +module MCP.Integration where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, object, toJSON, (.=)) +import Data.Aeson qualified as Aeson +import Data.Attoparsec.ByteString.Char8 as C +import Data.Attoparsec.ByteString.Lazy as P +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Map qualified as Map +import Data.Text (Text) +import MCP.Protocol +import MCP.TestServer ( + availablePrompts, + availableResourceTemplates, + availableResources, + availableTools, + completionValues, + createTestAppWithJWT, + csvTestData, + imageTestData, + jsonTestData, + ) +import MCP.TestUtils +import MCP.Types +import Network.HTTP.Types qualified as HTTP +import Network.Wai.Test (SResponse (..)) +import Servant +import Servant.Auth.Server qualified as AuthServer +import Test.Hspec +import Test.Hspec.Wai ( + WaiSession, + get, + post, + request, + shouldRespondWith, + withState, + ) + +-- * Integration Test Specifications + +-- | Complete integration test suite using hspec-wai +integrationSpec :: Spec +integrationSpec = describe "MCP Integration Tests" $ do + withState createTestAppWithJWT $ do + serverLifecycleSpec + authenticationSpec + protocolFlowSpec + endpointsSpec + errorHandlingSpec + preInitializationSpec + protocolMethodsSpec + toolErrorSpec + resourceErrorSpec + promptErrorSpec + resourceTemplateSpec + completionSpec + unimplementedHandlerSpec + nullParamsSpec + +-- | Test server startup and basic HTTP behavior +serverLifecycleSpec :: SpecWith (AuthServer.JWTSettings, Application) +serverLifecycleSpec = describe "Server Lifecycle" $ do + let ping_request = + toJSON $ + createJSONRPCRequest Nothing (1 :: Int) "ping" Aeson.Null + + it "responds with 401 for unauthenticated GET requests" $ + get "/mcp" `shouldRespondWith` 401 + + it "responds with 401 for unauthenticated POST requests" $ do + let headers = [("Content-Type", "application/json")] + mcpPostRequestExpects headers ping_request 401 + + it "initialization handshake works with proper JWT authentication" $ + withAuthenticatedRequest $ \headers -> do + -- the client sends the initialize request + let init_req = toJSON createInitializeRequest + resp_init <- mcpPostRequest headers init_req + withValidJSONRPCResponse resp_init 1 validateInitializationResponse + + -- after successful initialization, the client sends notification to + -- indicate readiness + let notify_request = toJSON createInitializedNotification + mcpPostRequestOk headers notify_request + +-- | Test JWT authentication scenarios +authenticationSpec :: SpecWith (AuthServer.JWTSettings, Application) +authenticationSpec = describe "Authentication" $ do + let ping_request = toJSON createPingRequest + it "rejects requests without JWT token" $ do + let headers = [("Content-Type", "application/json")] + mcpPostRequestExpects headers ping_request 401 + + it "rejects requests with invalid JWT token" $ do + let headers = + [ ("Content-Type", "application/json") + , ("Authorization", "Bearer invalid-token") + ] + mcpPostRequestExpects headers ping_request 401 + + it "rejects requests with malformed Authorization header" $ do + let headers = + [ ("Content-Type", "application/json") + , ("Authorization", "NotBearer token") + ] + mcpPostRequestExpects headers ping_request 401 + +-- | Test MCP protocol flows (with proper JWT authentication) +protocolFlowSpec :: SpecWith (AuthServer.JWTSettings, Application) +protocolFlowSpec = describe "Protocol Flow" $ do + it "rejects authenticated requests with missing jsonrpc field" $ do + withAuthenticatedRequest $ \headers -> do + let invalid_request = object ["id" .= (1 :: Int), "method" .= ("ping" :: Text)] + mcpPostRequestExpects headers invalid_request 400 + + it "rejects authenticated request with wrong jsonrpc version" $ do + withAuthenticatedRequest $ \headers -> do + let invalid_request = + toJSON $ + createJSONRPCRequest (Just "1.0") (1 :: Int) "ping" Aeson.Null + mcpPostRequestExpects headers invalid_request 400 + + it "rejects authenticated request with wrong id" $ do + withAuthenticatedRequest $ \headers -> do + let invalid_id = object ["unexpected" .= ("value" :: Text)] + let invalid_request = + toJSON $ + createJSONRPCRequest Nothing invalid_id "ping" Aeson.Null + mcpPostRequestExpects headers invalid_request 400 + +-- | Test various MCP endpoints to ensure they respond correctly +endpointsSpec :: SpecWith (AuthServer.JWTSettings, Application) +endpointsSpec = describe "Endpoint Health Check" $ do + it "handles list/tools request successfully" $ do + withInitializedServer $ \headers -> do + let req_id = 2 + let expected_tools = ["addition-tool", "constant-msg-tool"] + let list_tool_req = toJSON $ createListToolsRequest req_id + -- the client sends the list tools request + resp_list_tool <- mcpPostRequest headers list_tool_req + -- verify response's id and listed tools + withValidJSONRPCResponse resp_list_tool req_id $ + validateToolsListResponse expected_tools + + it "handles tool/call requests successfully" $ do + withInitializedServer $ \headers -> do + -- the client sends a tool/call request to the addition tool + let req_id1 = 3 + let call_req1 = + toJSON $ + createCallToolRequest req_id1 "addition-tool" [("arg1", toJSON (5 :: Int)), ("arg2", toJSON (7 :: Int))] + resp_call <- mcpPostRequest headers call_req1 + withValidJSONRPCResponse resp_call req_id1 $ + validateToolCallResponse (toJSON (12 :: Int)) + + -- the client sends a tool/call request to the constant message tool + let req_id2 = 4 + let call_req2 = + toJSON $ + createCallToolRequest req_id2 "constant-msg-tool" [] + resp_call2 <- mcpPostRequest headers call_req2 + withValidJSONRPCResponse resp_call2 req_id2 $ + validateToolCallResponse (toJSON ("Hello, World!" :: Text)) + + it "handles prompt/list requests successfully" $ do + withInitializedServer $ \headers -> do + let req_id = 5 + let expected_prompts = ["code-review"] + let list_prompt_req = toJSON $ createPromptListRequest req_id + -- the client sends the list prompts request + resp_list_prompt <- mcpPostRequest headers list_prompt_req + -- verify response's id and listed prompts + withValidJSONRPCResponse resp_list_prompt req_id $ + validatePromptListResponse expected_prompts + + it "handles get/prompt requests successfully" $ do + withInitializedServer $ \headers -> do + -- the client sends a get/prompt request for the "code-review" prompt + let req_id = 6 + let args = Map.fromList [("code", "def foo():\n return 42")] + let get_prompt_req = toJSON $ createGetPromptRequest req_id "code-review" (Just args) + resp_get_prompt <- mcpPostRequest headers get_prompt_req + -- verify response's id and retrieved prompt + withValidJSONRPCResponse resp_get_prompt req_id $ + validateGetPromptResponse "A prompt to request a code review from the LLM" [User, Assistant] + + it "handles list/resources requests successfully" $ do + withInitializedServer $ \headers -> do + let req_id = 7 + let list_resources_req = toJSON $ createListResourcesRequest req_id + -- the client sends the list resources request + resp_list_resources <- mcpPostRequest headers list_resources_req + -- verify response's id and listed resources + withValidJSONRPCResponse resp_list_resources req_id $ + validateListResourcesResponse + ["resource://example/document", "resource://example/data", "resource://example/image"] + + it "handles read/resource requests successfully" $ do + withInitializedServer $ \headers -> do + let requests = + [ (8, "resource://example/document", csvTestData) + , (9, "resource://example/data", jsonTestData) + , (10, "resource://example/image", imageTestData) + ] + + mapM_ + ( \(req_id, req_uri, expected_content) -> do + let read_resource = toJSON $ createReadResourceRequest req_id req_uri + -- the client sends the read resource request + resp_read_resource <- mcpPostRequest headers read_resource + -- verify response's id and read resource contents + withValidJSONRPCResponse resp_read_resource req_id $ + validateReadResourceResponse req_uri expected_content + ) + requests + +-- | Test error handling scenarios +errorHandlingSpec :: SpecWith (AuthServer.JWTSettings, Application) +errorHandlingSpec = describe "Error Handling" $ do + it "handles malformed JSON requests" $ do + let headers = [("Content-Type", "application/json")] + mcpPostRequestExpects headers "invalid json" 400 + + it "handles requests with wrong content type" $ + post "/mcp" "some text" `shouldRespondWith` 415 + + it "handles empty requests" $ do + let headers = [("Content-Type", "application/json")] + -- should auth fail first (401)? + mcpPostRequestExpects headers "" 400 + + it "handles large requests appropriately" $ do + withAuthenticatedRequest $ \headers -> do + let large_value = toJSON $ replicate 1000 ('x' :: Char) + let large_json = + toJSON $ + createJSONRPCRequest Nothing (1 :: Int) "ping" large_value + mcpPostRequestOk headers large_json + +-- | Test that methods are rejected before initialization +preInitializationSpec :: SpecWith (AuthServer.JWTSettings, Application) +preInitializationSpec = describe "Pre-Initialization Enforcement" $ do + it "rejects tools/list before initialization" $ + withAuthenticatedRequest $ \headers -> do + let req = toJSON $ createListToolsRequest 1 + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 1 $ \err_info -> + code err_info `shouldBe` sERVER_NOT_INITIALIZED + + it "rejects tools/call before initialization" $ + withAuthenticatedRequest $ \headers -> do + let req = toJSON $ createCallToolRequest 1 "addition-tool" [("arg1", toJSON (1 :: Int)), ("arg2", toJSON (2 :: Int))] + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 1 $ \err_info -> + code err_info `shouldBe` sERVER_NOT_INITIALIZED + + it "rejects resources/list before initialization" $ + withAuthenticatedRequest $ \headers -> do + let req = toJSON $ createListResourcesRequest 1 + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 1 $ \err_info -> + code err_info `shouldBe` sERVER_NOT_INITIALIZED + + it "rejects prompts/list before initialization" $ + withAuthenticatedRequest $ \headers -> do + let req = toJSON $ createPromptListRequest 1 + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 1 $ \err_info -> + code err_info `shouldBe` sERVER_NOT_INITIALIZED + + it "rejects resources/templates/list before initialization" $ + withAuthenticatedRequest $ \headers -> do + let req = toJSON $ createListResourceTemplatesRequest 1 + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 1 $ \err_info -> + code err_info `shouldBe` sERVER_NOT_INITIALIZED + + it "rejects completion/complete before initialization" $ + withAuthenticatedRequest $ \headers -> do + let req = toJSON $ createCompleteRequest 1 "code-review" "code" "" + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 1 $ \err_info -> + code err_info `shouldBe` sERVER_NOT_INITIALIZED + + it "allows ping before initialization" $ + withAuthenticatedRequest $ \headers -> do + let req = toJSON createPingRequest + mcpPostRequestOk headers req + + it "allows initialize before initialization" $ + withAuthenticatedRequest $ \headers -> do + let req = toJSON createInitializeRequest + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 1 validateInitializationResponse + +-- | Test various protocol-level methods +protocolMethodsSpec :: SpecWith (AuthServer.JWTSettings, Application) +protocolMethodsSpec = describe "Protocol Methods" $ do + it "handles ping after initialization" $ + withInitializedServer $ \headers -> do + let req = toJSON createPingRequest + mcpPostRequestOk headers req + + it "handles logging/setLevel" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createSetLevelRequest 2 Debug + mcpPostRequestOk headers req + + it "returns method_not_found for unknown methods" $ + withInitializedServer $ \headers -> do + let req = + toJSON $ + createJSONRPCRequest Nothing (2 :: Int) "unknown/method" (object []) + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` mETHOD_NOT_FOUND + + it "handles GET /mcp with valid authentication" $ + withAuthenticatedRequest $ \headers -> do + let get_headers = filter (\(h, _) -> h /= "Content-Type") headers + let auth_header = filter (\(h, _) -> h == "Authorization") get_headers + resp <- getWithHeaders "/mcp" auth_header + liftIO $ HTTP.statusCode (simpleStatus resp) `shouldBe` 200 + +-- | Test tool call error scenarios +toolErrorSpec :: SpecWith (AuthServer.JWTSettings, Application) +toolErrorSpec = describe "Tool Call Errors" $ do + it "returns error for non-existent tool" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createCallToolRequest 2 "nonexistent-tool" [] + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` 404 + + it "returns error for missing required arguments" $ + withInitializedServer $ \headers -> do + -- addition-tool requires arg1 and arg2, call with no args + let req = toJSON $ createCallToolRequest 2 "addition-tool" [] + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` 400 + + it "returns error for partially missing required arguments" $ + withInitializedServer $ \headers -> do + -- addition-tool requires arg1 and arg2, call with only arg1 + let req = toJSON $ createCallToolRequest 2 "addition-tool" [("arg1", toJSON (5 :: Int))] + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` 400 + + it "returns error for invalid argument types" $ + withInitializedServer $ \headers -> do + -- addition-tool expects numbers, pass strings + let req = toJSON $ createCallToolRequest 2 "addition-tool" [("arg1", toJSON ("not-a-number" :: Text)), ("arg2", toJSON (5 :: Int))] + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` 400 + +-- | Test resource error scenarios +resourceErrorSpec :: SpecWith (AuthServer.JWTSettings, Application) +resourceErrorSpec = describe "Resource Errors" $ do + it "returns error for non-existent resource" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createReadResourceRequest 2 "resource://nonexistent/thing" + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` 404 + +-- | Test prompt error scenarios +promptErrorSpec :: SpecWith (AuthServer.JWTSettings, Application) +promptErrorSpec = describe "Prompt Errors" $ do + it "returns error for non-existent prompt" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createGetPromptRequest 2 "nonexistent-prompt" Nothing + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` 404 + +-- | Test resource template operations +resourceTemplateSpec :: SpecWith (AuthServer.JWTSettings, Application) +resourceTemplateSpec = describe "Resource Templates" $ do + it "handles resources/templates/list successfully" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createListResourceTemplatesRequest 2 + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(ListResourceTemplatesResult{resourceTemplates = templates}) -> do + let template_names = fmap (\ResourceTemplate{name = n} -> n) templates + template_names `shouldMatchList` ["user-profile", "log-file"] + + it "handles resources/templates/list with null params" $ + withInitializedServer $ \headers -> do + let req = + toJSON $ + createJSONRPCRequest Nothing (2 :: Int) "resources/templates/list" Aeson.Null + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(ListResourceTemplatesResult{resourceTemplates = templates}) -> + length templates `shouldBe` length availableResourceTemplates + +-- | Test completion operations +completionSpec :: SpecWith (AuthServer.JWTSettings, Application) +completionSpec = describe "Completions" $ do + it "handles completion/complete for known prompt argument" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createCompleteRequest 2 "code-review" "code" "" + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(CompleteResult{completion = CompletionResult{values = vals}}) -> + vals `shouldBe` completionValues + + it "handles completion/complete with prefix filter" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createCompleteRequest 2 "code-review" "code" "def" + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(CompleteResult{completion = CompletionResult{values = vals}}) -> + vals `shouldBe` ["def foo():"] + + it "returns empty completions for unknown prompt" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createCompleteRequest 2 "nonexistent" "arg" "" + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(CompleteResult{completion = CompletionResult{values = vals}}) -> + vals `shouldBe` [] + + it "returns empty completions for unknown argument" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createCompleteRequest 2 "code-review" "nonexistent-arg" "" + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(CompleteResult{completion = CompletionResult{values = vals}}) -> + vals `shouldBe` [] + +-- | Test methods whose handlers are not configured +unimplementedHandlerSpec :: SpecWith (AuthServer.JWTSettings, Application) +unimplementedHandlerSpec = describe "Unimplemented Handler Methods" $ do + it "returns method_not_found for resources/subscribe" $ + withInitializedServer $ \headers -> do + let req = toJSON $ createSubscribeRequest 2 "resource://example/document" + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` mETHOD_NOT_FOUND + +-- | Test that null params work for list methods +nullParamsSpec :: SpecWith (AuthServer.JWTSettings, Application) +nullParamsSpec = describe "Null Params Handling" $ do + it "handles tools/list with null params" $ + withInitializedServer $ \headers -> do + let req = + toJSON $ + createJSONRPCRequest Nothing (2 :: Int) "tools/list" Aeson.Null + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(ListToolsResult{tools = ls_tools}) -> + length ls_tools `shouldBe` length availableTools + + it "handles resources/list with null params" $ + withInitializedServer $ \headers -> do + let req = + toJSON $ + createJSONRPCRequest Nothing (2 :: Int) "resources/list" Aeson.Null + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(ListResourcesResult{resources = ls_resources}) -> + length ls_resources `shouldBe` length availableResources + + it "handles prompts/list with null params" $ + withInitializedServer $ \headers -> do + let req = + toJSON $ + createJSONRPCRequest Nothing (2 :: Int) "prompts/list" Aeson.Null + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(ListPromptsResult{prompts = ls_prompts}) -> + length ls_prompts `shouldBe` length availablePrompts + + it "handles resources/templates/list with null params" $ + withInitializedServer $ \headers -> do + let req = + toJSON $ + createJSONRPCRequest Nothing (2 :: Int) "resources/templates/list" Aeson.Null + resp <- mcpPostRequest headers req + withValidJSONRPCResponse resp 2 $ \(ListResourceTemplatesResult{resourceTemplates = templates}) -> + length templates `shouldBe` length availableResourceTemplates + + it "rejects resources/read with null params" $ + withInitializedServer $ \headers -> do + let req = + toJSON $ + createJSONRPCRequest Nothing (2 :: Int) "resources/read" Aeson.Null + resp <- mcpPostRequest headers req + withValidJSONRPCErrorResponse resp 2 $ \err_info -> + code err_info `shouldBe` iNVALID_PARAMS + +-- * Helper Functions + +-- ** Validation + +{- | Validates that the JSON-RPC response can be parsed and applies the given +properties to the parsed result +-} +withValidJSONRPCResponse :: + (FromJSON a) => + SResponse -> + Int -> + (a -> Expectation) -> + WaiSession AuthServer.JWTSettings () +withValidJSONRPCResponse resp expected_id props = do + liftIO $ + case parseJSONRPCResponse resp of + Right (JSONRPCResponse rpc_vrs req_id json_result) -> do + case Aeson.fromJSON json_result of + Aeson.Error err -> expectationFailure $ "Failed to parse result: " <> err + Aeson.Success val -> do + rpc_vrs `shouldBe` rPC_VERSION + req_id `shouldBe` toRequestId expected_id + props val + Left err_msg -> expectationFailure err_msg + +-- | Validates that the initialization response conforms to the protocol +validateInitializationResponse :: InitializeResult -> Expectation +validateInitializationResponse InitializeResult{protocolVersion = init_protocol_version} = do + init_protocol_version `shouldBe` pROTOCOL_VERSION + +-- | Validates that the tools list response contains the expected tools +validateToolsListResponse :: [Text] -> ListToolsResult -> Expectation +validateToolsListResponse expected_tools = \case + (ListToolsResult{tools = ls_tools}) -> do + let tools_names = fmap (\(Tool{name = t_name}) -> t_name) ls_tools + tools_names `shouldMatchList` expected_tools + +-- | Validates that the tool call response contains the expected result +validateToolCallResponse :: Aeson.Value -> CallToolResult -> Expectation +validateToolCallResponse expected_result = \case + (CallToolResult{structuredContent = structured}) -> do + case structured of + Just map_results -> + Map.lookup "result" map_results `shouldBe` Just expected_result + Nothing -> expectationFailure "Expected structured content in tool call result" + +-- | Validates that the prompt list response contains the expected prompts +validatePromptListResponse :: [Text] -> ListPromptsResult -> Expectation +validatePromptListResponse expected_prompts = \case + (ListPromptsResult{prompts = ls_prompts}) -> do + let prompt_names = fmap (\(Prompt{name = p_name}) -> p_name) ls_prompts + prompt_names `shouldMatchList` expected_prompts + +{- | Validates that the get prompt response contains the expected description +and messages with correct roles +-} +validateGetPromptResponse :: Text -> [Role] -> GetPromptResult -> Expectation +validateGetPromptResponse expected_description expected_roles = \case + (GetPromptResult{description = p_description, messages = p_messages}) -> do + p_description `shouldBe` Just expected_description + length p_messages `shouldBe` length expected_roles + fmap (\(PromptMessage{role = m_role}) -> m_role) p_messages + `shouldSatisfy` all (`elem` expected_roles) + +-- | Validates that the list resources response is as expected +validateListResourcesResponse :: [Text] -> ListResourcesResult -> Expectation +validateListResourcesResponse expected_resources = \case + (ListResourcesResult{resources = ls_resources}) -> do + let resource_uris = fmap (\(Resource{uri = r_uri}) -> r_uri) ls_resources + resource_uris `shouldMatchList` expected_resources + +-- | Validates that reading a resource response is as expected +validateReadResourceResponse :: Text -> Text -> ReadResourceResult -> Expectation +validateReadResourceResponse expected_uri expected_content = \case + (ReadResourceResult{contents = r_contents}) -> do + let uris_contents = + fmap + ( \case + TextResource (TextResourceContents{uri = r_uri, text = r_content}) -> (r_uri, r_content) + BlobResource (BlobResourceContents{uri = r_uri, blob = r_content}) -> (r_uri, r_content) + ) + r_contents + case uris_contents of + [(res_uri, res_content)] -> do + res_uri `shouldBe` expected_uri + res_content `shouldBe` expected_content + _ -> expectationFailure $ "Expected exactly 1 resource, got " <> show (length uris_contents) + +{- | Validates that the JSON-RPC error response can be parsed and applies +the given properties to the parsed error info +-} +withValidJSONRPCErrorResponse :: + SResponse -> + Int -> + (JSONRPCErrorInfo -> Expectation) -> + WaiSession AuthServer.JWTSettings () +withValidJSONRPCErrorResponse resp expected_id props = do + liftIO $ + case parseJSONRPCErrorResponse resp of + Right (JSONRPCError rpc_vrs req_id err_info) -> do + rpc_vrs `shouldBe` rPC_VERSION + req_id `shouldBe` toRequestId expected_id + props err_info + Left err_msg -> expectationFailure err_msg + +-- | Helper for making GET requests with specific headers +getWithHeaders :: + BS.ByteString -> + [(HTTP.HeaderName, BS.ByteString)] -> + WaiSession st SResponse +getWithHeaders path headers = + Test.Hspec.Wai.request HTTP.methodGet path headers "" + +-- ** Parsing + +-- | Parse JSON-RPC response from SSE response body +parseJSONRPCResponse :: SResponse -> Either String JSONRPCResponse +parseJSONRPCResponse resp = + case extractSSEData (simpleBody resp) of + Just bs_response -> + case Aeson.decodeStrict bs_response of + Just json_resp -> Right json_resp + Nothing -> Left $ "Failed to decode JSON-RPC response from: " <> show bs_response + Nothing -> Left $ "Failed to extract JSON data from SSE response: " <> show (simpleBody resp) + +-- | Parse JSON-RPC error response from SSE response body +parseJSONRPCErrorResponse :: SResponse -> Either String JSONRPCError +parseJSONRPCErrorResponse resp = + case extractSSEData (simpleBody resp) of + Just bs_response -> + case Aeson.decodeStrict bs_response of + Just json_err -> Right json_err + Nothing -> Left $ "Failed to decode JSON-RPC error from: " <> show bs_response + Nothing -> Left $ "Failed to extract JSON data from SSE response: " <> show (simpleBody resp) + +{- | Extract JSON data from Server-Sent Events (SSE) format +SSE format: "event: message\ndata:{json}\n\n" +-} +extractSSEData :: LBS.ByteString -> Maybe BS.ByteString +extractSSEData sseBody = snd <$> P.maybeResult (P.parse parseEvent sseBody) + where + parseEvent = do + _ <- P.string "event:" + msg_type <- P.takeWhileIncluding (not . C.isEndOfLine) + _ <- C.string "data:" + json_data <- P.takeWhile (not . C.isEndOfLine) + return (msg_type, json_data) diff --git a/test/MCP/StdioIntegration.hs b/test/MCP/StdioIntegration.hs new file mode 100644 --- /dev/null +++ b/test/MCP/StdioIntegration.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module: MCP.StdioIntegration +License: MPL-2.0 +Maintainer: , + +Integration tests for the MCP stdio transport. +Tests serveStdio by creating in-process pipes and exercising +the full protocol over them. +-} +module MCP.StdioIntegration where + +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Exception (bracket) +import Data.Aeson (FromJSON, toJSON) +import Data.Aeson qualified as Aeson +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Map qualified as Map +import Data.Text (Text) +import MCP.Protocol +import MCP.Server ( + MCPServerState (..), + serveStdio, + ) +import MCP.TestServer ( + availableResourceTemplates, + completionValues, + csvTestData, + initializeTestState, + mb_handler_finalize, + processHandlers, + ) +import MCP.TestUtils +import MCP.Types +import System.IO (BufferMode (..), Handle, hClose, hFlush, hSetBuffering) +import System.Process (createPipe) +import Test.Hspec + +-- * Stdio Integration Tests + +-- | Complete stdio integration test suite +stdioIntegrationSpec :: Spec +stdioIntegrationSpec = describe "Stdio Transport" $ do + initializationSpec + pingSpec + toolSpec + resourceSpec + resourceTemplateStdioSpec + promptSpec + completionStdioSpec + loggingSpec + errorSpec + +-- ** Test Helpers + +-- | Create initial server state for stdio tests (no JWT/user) +createStdioServerState :: MCPServerState +createStdioServerState = + MCPServerState + { mcp_server_initialized = False + , mcp_handler_state = initializeTestState + , mcp_handler_init = Nothing -- No user in stdio mode + , mcp_handler_finalize = mb_handler_finalize + , mcp_client_capabilities = Nothing + , mcp_log_level = Nothing + , mcp_pending_responses = mempty + , mcp_pending_responses_next = 1 + , mcp_server_capabilities = + ServerCapabilities + { logging = Just LoggingCapability + , prompts = Just (PromptsCapability{listChanged = Nothing}) + , resources = Just (ResourcesCapability{listChanged = Nothing, subscribe = Nothing}) + , tools = Just (ToolsCapability{listChanged = Just True}) + , completions = Just CompletionsCapability + , experimental = Nothing + } + , mcp_implementation = Implementation "test-server-stdio" "1.0.0" Nothing + , mcp_instructions = Nothing + , mcp_process_handlers = processHandlers + } + +{- | Bracket that creates pipes, starts the stdio server in a background +thread, and yields the client-side handles for reading/writing. +-} +withStdioServer :: + ((Handle, Handle) -> IO a) -> + IO a +withStdioServer f = do + -- Pipe for server reading (client writes here) + (client_to_server_read, client_to_server_write) <- createPipe + -- Pipe for server writing (client reads here) + (server_to_client_read, server_to_client_write) <- createPipe + + hSetBuffering client_to_server_write LineBuffering + hSetBuffering server_to_client_read LineBuffering + + bracket + ( do + tid <- forkIO $ serveStdio client_to_server_read server_to_client_write createStdioServerState + -- Small delay to let the server start its loop + threadDelay 10000 + return tid + ) + ( \tid -> do + killThread tid + hClose client_to_server_write + hClose client_to_server_read + hClose server_to_client_write + hClose server_to_client_read + ) + (\_ -> f (server_to_client_read, client_to_server_write)) + +-- | Send a JSON-RPC message to the server via the write handle +sendMsg :: (Aeson.ToJSON a) => Handle -> a -> IO () +sendMsg h msg = do + BSL.hPut h (Aeson.encode msg) + BSL.hPut h "\n" + hFlush h + +-- | Read a JSON-RPC response from the server via the read handle +recvResponse :: Handle -> IO JSONRPCResponse +recvResponse h = do + line <- BS.hGetLine h + case Aeson.eitherDecodeStrict' line of + Right resp -> return resp + Left err -> fail $ "Failed to parse response: " <> err + +-- | Read a JSON-RPC error from the server via the read handle +recvError :: Handle -> IO JSONRPCError +recvError h = do + line <- BS.hGetLine h + case Aeson.eitherDecodeStrict' line of + Right err -> return err + Left parse_err -> fail $ "Failed to parse error response: " <> parse_err + +-- | Read a JSON-RPC response and extract a typed result +recvTypedResponse :: (FromJSON a) => Handle -> IO (RequestId, a) +recvTypedResponse h = do + JSONRPCResponse _rpc req_id res_val <- recvResponse h + case Aeson.fromJSON res_val of + Aeson.Success val -> return (req_id, val) + Aeson.Error err -> fail $ "Failed to parse typed result: " <> err + +-- | Initialize the server (send initialize + initialized notification) +initializeServer :: Handle -> Handle -> IO () +initializeServer h_read h_write = do + -- Send initialize request + sendMsg h_write (toJSON createInitializeRequest) + (_, InitializeResult{protocolVersion = pv}) <- recvTypedResponse h_read + pv `shouldBe` pROTOCOL_VERSION + + -- Send initialized notification + sendMsg h_write (toJSON createInitializedNotification) + +-- ** Test Specs + +initializationSpec :: Spec +initializationSpec = describe "Initialization" $ do + it "completes the initialization handshake" $ do + withStdioServer $ \(h_read, h_write) -> do + sendMsg h_write (toJSON createInitializeRequest) + (req_id, InitializeResult{protocolVersion = pv}) <- recvTypedResponse h_read + req_id `shouldBe` toRequestId (1 :: Int) + pv `shouldBe` pROTOCOL_VERSION + + -- Send initialized notification (no response expected) + sendMsg h_write (toJSON createInitializedNotification) + +pingSpec :: Spec +pingSpec = describe "Ping" $ do + it "handles ping after initialization" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON createPingRequest) + resp <- recvResponse h_read + let JSONRPCResponse _ _ res_val = resp + res_val `shouldBe` Aeson.Object mempty + +toolSpec :: Spec +toolSpec = describe "Tools" $ do + it "lists available tools" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createListToolsRequest 2) + (_, ListToolsResult{tools = ts}) <- recvTypedResponse h_read + let tool_names = fmap (\Tool{name = n} -> n) ts + tool_names `shouldMatchList` ["addition-tool", "constant-msg-tool"] + + it "calls the addition tool" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createCallToolRequest 2 "addition-tool" [("arg1", toJSON (5 :: Int)), ("arg2", toJSON (7 :: Int))]) + (_, CallToolResult{structuredContent = structured}) <- recvTypedResponse h_read + case structured of + Just m -> Map.lookup "result" m `shouldBe` Just (toJSON (12 :: Int)) + Nothing -> expectationFailure "Expected structured content" + + it "calls the constant message tool" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createCallToolRequest 2 "constant-msg-tool" []) + (_, CallToolResult{structuredContent = structured}) <- recvTypedResponse h_read + case structured of + Just m -> Map.lookup "result" m `shouldBe` Just (toJSON ("Hello, World!" :: Text)) + Nothing -> expectationFailure "Expected structured content" + + it "returns error for non-existent tool" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createCallToolRequest 2 "nonexistent-tool" []) + JSONRPCError _ _ err_info <- recvError h_read + code err_info `shouldBe` 404 + +resourceSpec :: Spec +resourceSpec = describe "Resources" $ do + it "lists available resources" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createListResourcesRequest 2) + (_, ListResourcesResult{resources = rs}) <- recvTypedResponse h_read + let resource_uris = fmap (\Resource{uri = u} -> u) rs + resource_uris `shouldMatchList` ["resource://example/document", "resource://example/data", "resource://example/image"] + + it "reads a text resource" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createReadResourceRequest 2 "resource://example/document") + (_, ReadResourceResult{contents = cs}) <- recvTypedResponse h_read + case cs of + [TextResource (TextResourceContents{text = t})] -> t `shouldBe` csvTestData + _ -> expectationFailure "Expected single text resource" + + it "returns error for non-existent resource" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createReadResourceRequest 2 "resource://nonexistent") + JSONRPCError _ _ err_info <- recvError h_read + code err_info `shouldBe` 404 + +resourceTemplateStdioSpec :: Spec +resourceTemplateStdioSpec = describe "Resource Templates" $ do + it "lists available resource templates" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createListResourceTemplatesRequest 2) + (_, ListResourceTemplatesResult{resourceTemplates = ts}) <- recvTypedResponse h_read + length ts `shouldBe` length availableResourceTemplates + +promptSpec :: Spec +promptSpec = describe "Prompts" $ do + it "lists available prompts" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createPromptListRequest 2) + (_, ListPromptsResult{prompts = ps}) <- recvTypedResponse h_read + let prompt_names = fmap (\Prompt{name = n} -> n) ps + prompt_names `shouldMatchList` ["code-review"] + + it "gets a prompt with arguments" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + let args = Map.fromList [("code", "def foo():\n return 42")] + sendMsg h_write (toJSON $ createGetPromptRequest 2 "code-review" (Just args)) + (_, GetPromptResult{description = desc, messages = msgs}) <- recvTypedResponse h_read + desc `shouldBe` Just "A prompt to request a code review from the LLM" + length msgs `shouldBe` 2 + fmap (\PromptMessage{role = r} -> r) msgs `shouldBe` [User, Assistant] + + it "returns error for non-existent prompt" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createGetPromptRequest 2 "nonexistent" Nothing) + JSONRPCError _ _ err_info <- recvError h_read + code err_info `shouldBe` 404 + +completionStdioSpec :: Spec +completionStdioSpec = describe "Completions" $ do + it "returns completions for known prompt argument" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createCompleteRequest 2 "code-review" "code" "") + (_, CompleteResult{completion = CompletionResult{values = vals}}) <- recvTypedResponse h_read + vals `shouldBe` completionValues + + it "returns filtered completions with prefix" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createCompleteRequest 2 "code-review" "code" "def") + (_, CompleteResult{completion = CompletionResult{values = vals}}) <- recvTypedResponse h_read + vals `shouldBe` ["def foo():"] + + it "returns empty completions for unknown prompt" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createCompleteRequest 2 "nonexistent" "arg" "") + (_, CompleteResult{completion = CompletionResult{values = vals}}) <- recvTypedResponse h_read + vals `shouldBe` [] + +loggingSpec :: Spec +loggingSpec = describe "Logging" $ do + it "handles logging/setLevel" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createSetLevelRequest 2 Debug) + resp <- recvResponse h_read + let JSONRPCResponse _ _ res_val = resp + res_val `shouldBe` Aeson.Null + +errorSpec :: Spec +errorSpec = describe "Error Handling" $ do + it "rejects tools/list before initialization" $ do + withStdioServer $ \(h_read, h_write) -> do + sendMsg h_write (toJSON $ createListToolsRequest 1) + JSONRPCError _ _ err_info <- recvError h_read + code err_info `shouldBe` sERVER_NOT_INITIALIZED + + it "returns method_not_found for unknown methods" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON $ createJSONRPCRequest Nothing (2 :: Int) "unknown/method" (Aeson.object [])) + JSONRPCError _ _ err_info <- recvError h_read + code err_info `shouldBe` mETHOD_NOT_FOUND + + it "returns parse error for malformed JSON" $ do + withStdioServer $ \(h_read, h_write) -> do + BS.hPut h_write "this is not json\n" + hFlush h_write + JSONRPCError _ _ err_info <- recvError h_read + code err_info `shouldBe` pARSE_ERROR + + it "handles EOF gracefully" $ do + withStdioServer $ \(h_read, h_write) -> do + initializeServer h_read h_write + sendMsg h_write (toJSON createPingRequest) + _ <- recvResponse h_read + -- Closing the write handle signals EOF to the server + hClose h_write + -- Server should exit cleanly (no exception) + -- Wait a bit for the server to process EOF + threadDelay 50000 + return () diff --git a/test/MCP/TestServer.hs b/test/MCP/TestServer.hs new file mode 100644 --- /dev/null +++ b/test/MCP/TestServer.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | +Module: MCP.TestServer +License: MPL-2.0 +Maintainer: , + +This module provides server configuration utilities for testing the MCP server +implementation. +-} +module MCP.TestServer where + +import Control.Concurrent.MVar (MVar, newMVar) +import Data.Aeson (FromJSON, ToJSON, fromJSON, object, toJSON, (.=)) +import Data.Aeson qualified as Aeson +import Data.Map qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import MCP.Server +import Network.Wai (Application) +import Servant (Context (..), Proxy (..), serveWithContext) +import Servant.Auth.Server qualified as AuthServer + +-- * Server Configuration Types and Functions + +-- ** Test user + +-- | A simple test user for MCP tests +data TestUser = TestUser + { userId :: Text + , userName :: Text + , userEmail :: Text + } + deriving (Eq, Show, Generic) + +instance ToJSON TestUser + +instance FromJSON TestUser + +instance AuthServer.ToJWT TestUser + +instance AuthServer.FromJWT TestUser + +type instance MCPHandlerState = TestStateHandler + +type instance MCPHandlerUser = TestUser + +-- ** MCP Handler State + +-- | A simple state handler for MCP tests +newtype TestStateHandler = TestStateHandler {handle_curr_user :: Maybe Text} + +-- | Initialize a fresh test state handler +initializeTestState :: TestStateHandler +initializeTestState = TestStateHandler{handle_curr_user = Nothing} + +-- | Initialization of the handler with the current user +mb_handler_init :: Maybe (TestUser -> TestStateHandler -> IO TestStateHandler) +mb_handler_init = + Just $ \user state -> do + let usr_id = userId user + return state{handle_curr_user = Just usr_id} + +-- | Finalization of the handler, clearing the current user +mb_handler_finalize :: Maybe (TestStateHandler -> IO TestStateHandler) +mb_handler_finalize = + Just $ \state -> do + return state{handle_curr_user = Nothing} + +-- ** Process Handlers + +-- | Process handlers to be used in tests +processHandlers :: ProcessHandlers +processHandlers = + defaultProcessHandlers + { listResourcesHandler = Just processListResourcesHandler + , readResourceHandler = Just processReadResourceHandler + , listToolsHandler = Just processListToolsHandler + , callToolHandler = Just processCallToolHandler + , listPromptsHandler = Just processListPromptsHandler + , getPromptHandler = Just processGetPromptHandler + , listResourceTemplatesHandler = Just processListResourceTemplatesHandler + , completeHandler = Just processCompleteHandler + } + where + -- Example process handler for listing resources + processListResourcesHandler :: ListResourcesParams -> MCPServerT (ProcessResult ListResourcesResult) + processListResourcesHandler = + return $ + return $ + ProcessSuccess $ + ListResourcesResult + { resources = availableResources + , nextCursor = Nothing + , _meta = Nothing + } + + -- Example process handler for reading a resource + processReadResourceHandler :: ReadResourceParams -> MCPServerT (ProcessResult ReadResourceResult) + processReadResourceHandler (ReadResourceParams{uri = req_uri}) = do + let rsc_content = + case req_uri of + "resource://example/document" -> + Just $ + TextResource $ + TextResourceContents + { uri = req_uri + , text = csvTestData + , mimeType = Just "text/plain" + , _meta = Nothing + } + "resource://example/data" -> + Just $ + TextResource $ + TextResourceContents + { uri = req_uri + , text = jsonTestData + , mimeType = Just "application/json" + , _meta = Nothing + } + "resource://example/image" -> + Just $ + BlobResource $ + BlobResourceContents + { uri = req_uri + , blob = imageTestData + , mimeType = Just "image/png" + , _meta = Nothing + } + _ -> Nothing + case rsc_content of + Just rsc_content' -> + return $ ProcessSuccess (ReadResourceResult{contents = [rsc_content'], _meta = Nothing}) + Nothing -> + return $ ProcessRPCError 404 "Resource not found" + + -- Example process handler for listing tools + processListToolsHandler :: ListToolsParams -> MCPServerT (ProcessResult ListToolsResult) + processListToolsHandler = + return $ + return $ + ProcessSuccess $ + ListToolsResult + { tools = availableTools + , nextCursor = Nothing + , _meta = Nothing + } + + -- Example process handler for calling tools + processCallToolHandler :: CallToolParams -> MCPServerT (ProcessResult CallToolResult) + processCallToolHandler (CallToolParams t_name t_args) = do + case t_name of + "addition-tool" -> case t_args of + Just args_map -> do + let parseInt v = + case fromJSON @Int v of + Aeson.Success i -> Just i + Aeson.Error _ -> Nothing + let mb_arg1 = Map.lookup "arg1" args_map >>= parseInt + let mb_arg2 = Map.lookup "arg2" args_map >>= parseInt + case (mb_arg1, mb_arg2) of + (Just arg1, Just arg2) -> do + let t_result = arg1 + arg2 + let result_value = Map.fromList [("result", toJSON t_result)] + let ctx_result = + TextBlock $ TextContent "text" ("The result is: " <> T.pack (show t_result)) Nothing Nothing + return $ ProcessSuccess (CallToolResult [ctx_result] (Just result_value) Nothing Nothing) + _ -> return $ ProcessRPCError 400 "addition-tool: Missing or invalid arguments" + Nothing -> return $ ProcessRPCError 400 "addition-tool: Missing arguments" + "constant-msg-tool" -> do + let t_result = "Hello, World!" :: Text + let result_value = Map.fromList [("result", toJSON t_result)] + let ctx_result = + TextBlock $ TextContent "text" ("This is a constant message: " <> t_result) Nothing Nothing + return $ ProcessSuccess (CallToolResult [ctx_result] (Just result_value) Nothing Nothing) + _ -> return $ ProcessRPCError 404 "Tool not found" + + -- Example list prompts handler + processListPromptsHandler :: ListPromptsParams -> MCPServerT (ProcessResult ListPromptsResult) + processListPromptsHandler = + return $ + return $ + ProcessSuccess $ + ListPromptsResult + { prompts = availablePrompts + , nextCursor = Nothing + , _meta = Nothing + } + + -- Example get prompt handler + processGetPromptHandler :: GetPromptParams -> MCPServerT (ProcessResult GetPromptResult) + processGetPromptHandler = \case + GetPromptParams{name = "code-review", arguments = Just map_args} -> do + let msgs = + [ + ( User + , T.unlines $ + [ "Help me revise the syntax of the following python code snippet:" + , "```python" + , Map.findWithDefault "" "code" map_args + , "```" + ] + ) + , (Assistant, "Yes, I can help with that. I will make sure to check common issues and keep practices in mind.") + ] + let toMsg msg_role msg_content = + PromptMessage + { role = msg_role + , content = + TextBlock $ + TextContent + { textType = "text" + , text = msg_content + , annotations = Nothing + , _meta = Nothing + } + } + return $ + ProcessSuccess $ + GetPromptResult + { description = Just "A prompt to request a code review from the LLM" + , messages = fmap (uncurry toMsg) msgs + , _meta = Nothing + } + _ -> return $ ProcessRPCError 404 "Prompt not found" + + -- Resource templates handler + processListResourceTemplatesHandler :: ListResourceTemplatesParams -> MCPServerT (ProcessResult ListResourceTemplatesResult) + processListResourceTemplatesHandler = + return $ + return $ + ProcessSuccess $ + ListResourceTemplatesResult + { resourceTemplates = availableResourceTemplates + , nextCursor = Nothing + , _meta = Nothing + } + + -- Completion handler: prefix-based completions for the code-review prompt's "code" argument + processCompleteHandler :: CompleteParams -> MCPServerT (ProcessResult CompleteResult) + processCompleteHandler (CompleteParams cref (CompletionArgument arg_name arg_value) _ctx) = + case cref of + PromptRef (PromptReference _ "code-review" _) -> + case arg_name of + "code" -> + let suggestions = filter (T.isPrefixOf arg_value) completionValues + in return $ + ProcessSuccess $ + CompleteResult + { completion = + CompletionResult + { values = suggestions + , total = Just (length suggestions) + , hasMore = Just False + } + , _meta = Nothing + } + _ -> emptyCompletion + _ -> emptyCompletion + where + emptyCompletion = + return $ + ProcessSuccess $ + CompleteResult + { completion = CompletionResult{values = [], total = Just 0, hasMore = Just False} + , _meta = Nothing + } + +-- | Completion suggestion values for the code-review prompt +completionValues :: [Text] +completionValues = ["def foo():", "class MyClass:", "import os"] + +-- ** Available Tools + +-- | Tools available in the test server +availableTools :: [Tool] +availableTools = + [ Tool + { name = "addition-tool" + , title = Just "Addition Tool" + , description = Just "An example tool that adds two numbers" + , inputSchema = + InputSchema + { schemaType = "object" + , properties = + Just $ + Map.fromList + [ ("arg1", object ["type" .= ("number" :: Text)]) + , ("arg2", object ["type" .= ("number" :: Text)]) + ] + , required = Just ["arg1", "arg2"] + } + , outputSchema = + Just $ + InputSchema + { schemaType = "object" + , properties = Just $ Map.fromList [("result", object ["type" .= ("number" :: Text)])] + , required = Just ["result"] + } + , annotations = Nothing + , _meta = Nothing + } + , Tool + { name = "constant-msg-tool" + , title = Just "Constant Message Tool" + , description = Just "Another example tool" + , inputSchema = + InputSchema + { schemaType = "object" + , properties = Nothing + , required = Nothing + } + , outputSchema = + Just $ + InputSchema + { schemaType = "object" + , properties = Just (Map.fromList [("message", object ["type" .= ("string" :: Text)])]) + , required = Just ["message"] + } + , annotations = Nothing + , _meta = Nothing + } + ] + +-- ** Available Prompts + +-- | Prompts available in the test server +availablePrompts :: [Prompt] +availablePrompts = + [ Prompt + { name = "code-review" + , title = Just "Code Review Prompt" + , description = Just "Asks the LLM to analyze code quality and suggest improvements" + , arguments = + Just + [ PromptArgument + { name = "code" + , title = Just "Code Snippet" + , description = Just "The code snippet to review" + , required = Just True + } + ] + , _meta = Nothing + } + ] + +-- ** Available Resources + +-- | Resources available in the test server +availableResources :: [Resource] +availableResources = + [ Resource + { uri = "resource://example/document" + , name = "text-document" + , title = Just "An example resource for testing" + , description = Just "This is a sample text document." + , mimeType = Just "text/plain" + , size = Nothing + , annotations = Nothing + , _meta = Nothing + } + , Resource + { uri = "resource://example/data" + , name = "json-data" + , title = Just "Example Resource 2" + , description = Just "Another example resource for testing" + , mimeType = Just "application/json" + , size = Nothing + , annotations = Nothing + , _meta = Nothing + } + , Resource + { uri = "resource://example/image" + , name = "image-resource" + , title = Just "An inspiring image" + , description = Just "Image of a sunset" + , mimeType = Just "image/png" + , size = Nothing + , annotations = Nothing + , _meta = Nothing + } + ] + +-- ** Available Resource Templates + +-- | Resource templates available in the test server +availableResourceTemplates :: [ResourceTemplate] +availableResourceTemplates = + [ ResourceTemplate + { name = "user-profile" + , title = Just "User Profile Template" + , uriTemplate = "resource://example/users/{userId}" + , description = Just "Returns a user profile by ID" + , mimeType = Just "application/json" + , annotations = Nothing + , _meta = Nothing + } + , ResourceTemplate + { name = "log-file" + , title = Just "Log File Template" + , uriTemplate = "resource://example/logs/{date}" + , description = Just "Returns logs for a specific date" + , mimeType = Just "text/plain" + , annotations = Nothing + , _meta = Nothing + } + ] + +-- *** Sample Resource Contents + +-- | Sample CSV data for testing +csvTestData :: Text +csvTestData = "name,age,city\nJohn,25,New York\nJane,30,London\nBob,35,Paris" + +-- | Sample JSON data for testing +jsonTestData :: Text +jsonTestData = + T.pack $ + show $ + object ["key1" .= ("value1" :: Text), "key2" .= (42 :: Int), "key3" .= (True :: Bool)] + +-- | Sample image data for testing (base64 encoded) +imageTestData :: Text +imageTestData = "" + +-- ** Server State Creation + +-- | Create test server state for MCP tests +createTestServerState :: IO (MVar MCPServerState) +createTestServerState = do + let impl = Implementation "test-server" "1.0.0" Nothing + let server_caps = + ServerCapabilities + { logging = Just LoggingCapability + , prompts = Just (PromptsCapability{listChanged = Nothing}) + , resources = + Just + (ResourcesCapability{listChanged = Nothing, subscribe = Nothing}) + , tools = Just (ToolsCapability{listChanged = Just True}) + , completions = Just CompletionsCapability + , experimental = Nothing + } + newMVar + MCPServerState + { mcp_server_initialized = False + , mcp_handler_state = initializeTestState + , mcp_handler_init = mb_handler_init + , mcp_handler_finalize = mb_handler_finalize + , mcp_client_capabilities = Nothing + , mcp_log_level = Just Info -- Set to Debug if you want to see json requests + , mcp_pending_responses = mempty + , mcp_pending_responses_next = 1 + , mcp_server_capabilities = server_caps + , mcp_implementation = impl + , mcp_instructions = Nothing + , mcp_process_handlers = processHandlers + } + +-- ** Application Setup + +-- | Create test application with access to JWT configuration +createTestAppWithJWT :: IO (AuthServer.JWTSettings, Application) +createTestAppWithJWT = do + state_var <- createTestServerState + key <- AuthServer.generateKey + let jwt_cfg = AuthServer.defaultJWTSettings key + let cookie_cfg = AuthServer.defaultCookieSettings + let auth_cfg = cookie_cfg :. jwt_cfg :. EmptyContext + let app = serveWithContext (Proxy @MCPAPI) auth_cfg (mcpAPI state_var) + return (jwt_cfg, app) diff --git a/test/MCP/TestUtils.hs b/test/MCP/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/MCP/TestUtils.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module: MCP.TestUtils +License: MPL-2.0 +Maintainer: , + +This module provides utility functions and types for testing the MCP server +implementation. +-} +module MCP.TestUtils where + +import Crypto.JOSE.Error as Crypto +import Data.Aeson (ToJSON, Value (..), encode, toJSON) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import MCP.Protocol qualified as MCP +import MCP.TestServer (TestUser (..)) +import MCP.Types qualified as MCP +import Network.HTTP.Types qualified as HTTP +import Network.Wai.Test (SResponse) +import Servant.Auth.Server qualified as AuthServer +import Test.Hspec.Wai ( + ResponseMatcher, + WaiExpectation, + WaiSession, + getState, + liftIO, + request, + shouldRespondWith, + ) + +-- * Utility Functions for MCP testing + +-- ** Test Combinators + +-- | Create a post request with the provided headers +postWith :: + BS.ByteString -> + [(HTTP.HeaderName, BS.ByteString)] -> + BSL.ByteString -> + WaiSession st SResponse +postWith = request HTTP.methodPost + +-- | Helper function for making MCP requests with authentication +mcpPostRequest :: + [(HTTP.HeaderName, BS.ByteString)] -> Value -> WaiSession st SResponse +mcpPostRequest headers request_object = + postWith "/mcp" headers (encode request_object) + +{- | Helper function for making MCP requests with authentication and expecting a +specific response +-} +mcpPostRequestExpects :: + [(HTTP.HeaderName, BS.ByteString)] -> + Value -> + ResponseMatcher -> + WaiExpectation st +mcpPostRequestExpects headers request_object expected_response = + mcpPostRequest headers request_object `shouldRespondWith` expected_response + +{- | Helper function for making MCP requests with authentication and expecting +200 +-} +mcpPostRequestOk :: [(HTTP.HeaderName, BS.ByteString)] -> Value -> WaiExpectation st +mcpPostRequestOk headers request_object = + mcpPostRequestExpects headers request_object 200 + +-- | Create an authenticated request with JWT token +withAuthenticatedRequest :: + ([(HTTP.HeaderName, BS.ByteString)] -> WaiSession AuthServer.JWTSettings a) -> + WaiSession AuthServer.JWTSettings a +withAuthenticatedRequest = withAuthenticatedRequestForSession "test-user-id" + +-- | Create an authenticated request with JWT token +withAuthenticatedRequestForSession :: + Text -> -- Session ID to include in JWT + ([(HTTP.HeaderName, BS.ByteString)] -> WaiSession AuthServer.JWTSettings a) -> + WaiSession AuthServer.JWTSettings a +withAuthenticatedRequestForSession session_id action = do + jwt_cfg <- getState + let test_user = TestUser session_id "Test User" "test@example.com" + eitherToken <- liftIO $ generateTestJWT test_user jwt_cfg + case eitherToken of + Left _ -> error "Failed to generate test JWT token" + Right token -> do + let tokenStr = BSL.toStrict token + headers = + [ ("Content-Type", "application/json") + , ("Authorization", "Bearer " <> tokenStr) + ] + action headers + where + -- generate a JWT token for the given user using the provided JWT settings + generateTestJWT :: + (AuthServer.ToJWT a) => + a -> + AuthServer.JWTSettings -> + IO (Either Crypto.Error BSL.ByteString) + generateTestJWT user jwt_cfg' = AuthServer.makeJWT user jwt_cfg' Nothing + +{- | Computes an action after initializing the server (authenticate, initialize, +and send initialized notification) +-} +withInitializedServer :: + ([(HTTP.HeaderName, BS.ByteString)] -> WaiSession AuthServer.JWTSettings a) -> + WaiSession AuthServer.JWTSettings a +withInitializedServer action = + withAuthenticatedRequest $ \headers -> do + let init_request = toJSON createInitializeRequest + mcpPostRequestOk headers init_request + let notify_request = toJSON createInitializedNotification + mcpPostRequestOk headers notify_request + action headers + +-- ** Request builders + +-- | Create a JSON-RPC request object. +createJSONRPCRequest :: + (ToJSON a) => + Maybe Text -> + a -> + Text -> + Value -> + MCP.JSONRPCRequest +createJSONRPCRequest mb_jsonrpc req_id method params = + MCP.JSONRPCRequest + { jsonrpc = fromMaybe "2.0" mb_jsonrpc + , id = toRequestId req_id + , method = method + , params = params + } + +-- | Create a JSON-RPC request ID from an integer +toRequestId :: (ToJSON a) => a -> MCP.RequestId +toRequestId = MCP.RequestId . toJSON + +-- | Create a JSON-RPC initialize request +createInitializeRequest :: MCP.InitializeRequest +createInitializeRequest = + MCP.InitializeRequest + { id = toRequestId (1 :: Int) + , params = init_params + } + where + init_params = + MCP.InitializeParams + { protocolVersion = MCP.pROTOCOL_VERSION + , capabilities = client_caps + , clientInfo = client_info + } + + client_caps :: MCP.ClientCapabilities + client_caps = + MCP.ClientCapabilities + { roots = Just $ MCP.RootsCapability (Just True) + , sampling = Nothing + , elicitation = Just MCP.ElicitationCapability + , experimental = Nothing + } + + client_info :: MCP.Implementation + client_info = + MCP.Implementation + { name = "test-client" + , version = "0.1.0" + , title = Nothing + } + +-- | Create a JSON-RPC ping request +createPingRequest :: MCP.PingRequest +createPingRequest = + MCP.PingRequest + { id = toRequestId (1 :: Int) + , params = Nothing + } + +-- | Create a JSON-RPC call tool request +createCallToolRequest :: Int -> Text -> [(Text, Value)] -> MCP.CallToolRequest +createCallToolRequest req_id t_name map_args = + MCP.CallToolRequest + { id = toRequestId req_id + , params = tool_call_params + } + where + tool_call_params :: MCP.CallToolParams + tool_call_params = + MCP.CallToolParams + { name = t_name + , arguments = case map_args of + [] -> Nothing + _ -> Just $ Map.fromList map_args + } + +-- | Create a JSON-RPC tools list request +createListToolsRequest :: Int -> MCP.ListToolsRequest +createListToolsRequest int_id = + MCP.ListToolsRequest + { id = toRequestId int_id + , params = Just $ MCP.ListToolsParams Nothing + } + +-- | Create a JSON-RPC resources list request +createListResourcesRequest :: Int -> MCP.ListResourcesRequest +createListResourcesRequest req_id = + MCP.ListResourcesRequest + { id = toRequestId req_id + , params = Just $ MCP.ListResourcesParams Nothing + } + +-- | Create a JSON-RPC resources read request +createReadResourceRequest :: Int -> Text -> MCP.ReadResourceRequest +createReadResourceRequest req_id txt_uri = + MCP.ReadResourceRequest + { id = toRequestId req_id + , params = MCP.ReadResourceParams txt_uri + } + +-- | Create a JSON-RPC resources subscribe request +createSubscribeRequest :: Int -> Text -> MCP.SubscribeRequest +createSubscribeRequest req_id txt_uri = + MCP.SubscribeRequest + { id = toRequestId req_id + , params = MCP.SubscribeParams txt_uri + } + +-- | Create a JSON-RPC list prompts request +createPromptListRequest :: Int -> MCP.ListPromptsRequest +createPromptListRequest req_id = + MCP.ListPromptsRequest + { id = toRequestId req_id + , params = Just $ MCP.ListPromptsParams Nothing + } + +-- | Create a JSON-RPC get prompt request +createGetPromptRequest :: Int -> Text -> Maybe (Map.Map Text Text) -> MCP.GetPromptRequest +createGetPromptRequest req_id p_name args = + MCP.GetPromptRequest + { id = toRequestId req_id + , params = MCP.GetPromptParams p_name args + } + +-- ** Notification helpers + +-- | Create a JSON-RPC initialized notification +createInitializedNotification :: MCP.InitializedNotification +createInitializedNotification = + MCP.InitializedNotification{params = Nothing} + +-- | Create a JSON-RPC logging/setLevel request +createSetLevelRequest :: Int -> MCP.LoggingLevel -> MCP.SetLevelRequest +createSetLevelRequest req_id lvl = + MCP.SetLevelRequest + { id = toRequestId req_id + , params = MCP.SetLevelParams lvl + } + +-- | Create a JSON-RPC request for a resource template list +createListResourceTemplatesRequest :: Int -> MCP.ListResourceTemplatesRequest +createListResourceTemplatesRequest req_id = + MCP.ListResourceTemplatesRequest + { id = toRequestId req_id + , params = Just $ MCP.ListResourceTemplatesParams Nothing + } + +-- | Create a JSON-RPC request for completion/complete +createCompleteRequest :: Int -> Text -> Text -> Text -> MCP.CompleteRequest +createCompleteRequest req_id ref_name arg_name arg_value = + MCP.CompleteRequest + { id = toRequestId req_id + , params = + MCP.CompleteParams + { ref = MCP.PromptRef $ MCP.PromptReference "ref/prompt" ref_name Nothing + , argument = MCP.CompletionArgument arg_name arg_value + , context = Nothing + } + } diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,22 @@ -module Main (main) where +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{- | +Module: Main +License: MPL-2.0 +Maintainer: , + +Main test suite for the MCP library +-} +module Main where + +import MCP.Integration qualified as Integration +import MCP.StdioIntegration qualified as StdioIntegration +import Test.Hspec (describe, hspec) + +-- | Main function to run all tests main :: IO () -main = putStrLn "Test suite not yet implemented." +main = hspec $ do + describe "MCP Library" $ do + Integration.integrationSpec + StdioIntegration.stdioIntegrationSpec