mcp 0.2.0.1 → 0.3.0.1

raw patch · 22 files changed

+3321/−4185 lines, 22 filesdep +attoparsecdep +hspecdep +hspec-waidep −asyncdep −base64-bytestringdep −cryptonitedep ~basedep ~bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, hspec, hspec-wai, http-media, mcp-types, process, wai-test

Dependencies removed: async, base64-bytestring, cryptonite, http-conduit, memory, optparse-applicative, random, scientific, servant-auth, stm, transformers, unordered-containers, uuid, warp

Dependency ranges changed: base, bytestring, containers, mtl, text, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−46
• LICENSE +370/−17
• README.md +91/−0
• app/Main.hs +0/−112
• examples/README.md +0/−253
• examples/claude-desktop-config.json +0/−24
• examples/full-config-example.json +0/−34
• examples/http-server.hs +0/−244
• mcp.cabal +114/−203
• src/MCP/Protocol.hs +0/−1132
• src/MCP/Server.hs +17/−112
• src/MCP/Server/Auth.hs +0/−307
• src/MCP/Server/Common.hs +471/−0
• src/MCP/Server/HTTP.hs +272/−807
• src/MCP/Server/StdIO.hs +0/−280
• src/MCP/Server/Stdio.hs +187/−0
• src/MCP/Types.hs +0/−612
• test/MCP/Integration.hs +651/−0
• test/MCP/StdioIntegration.hs +349/−0
• test/MCP/TestServer.hs +481/−0
• test/MCP/TestUtils.hs +285/−0
• test/Main.hs +20/−2

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

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

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

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

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

@@ -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": {}-    }-  }-}

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

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

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

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

@@ -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:  <matti@dpella.io>, <lobo@dpella.io> --- | 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

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

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>++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

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>++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]}

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

@@ -0,0 +1,187 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++{- |+Module:      MCP.Server.Stdio+License:     MPL-2.0+Maintainer:  <matti@dpella.io>, <lobo@dpella.io>++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

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

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>++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)

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>++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 ()