diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -11,6 +11,7 @@ import MCP.Protocol import MCP.Server +import MCP.Server.StdIO import MCP.Types -- | Minimal MCP Server implementation @@ -100,7 +101,7 @@ } let config = - ServerConfig + MCP.Server.StdIO.ServerConfig { configInput = stdin , configOutput = stdout , configServerInfo = serverInfo @@ -108,4 +109,4 @@ } putStrLn "Server configured, starting message loop..." - runServer config + MCP.Server.StdIO.runServer config diff --git a/examples/README.md b/examples/README.md new file mode 100644 --- /dev/null +++ b/examples/README.md @@ -0,0 +1,253 @@ +# MCP Configuration Examples and Usage + +This directory contains example configuration files for connecting MCP clients to the Haskell MCP server, as well as example implementations demonstrating different transport methods. + +## Claude Desktop Configuration + +Claude Desktop reads its MCP server configuration from a JSON file. The location depends on your operating system: + +### Configuration File Locations + +- **macOS**: `~/Library/Application Support/Claude/claude_desktop_config.json` +- **Windows**: `%APPDATA%\Claude\claude_desktop_config.json` +- **Linux**: `~/.config/claude/claude_desktop_config.json` + +### Basic Configuration + +```json +{ + "mcpServers": { + "haskell-mcp": { + "command": "cabal", + "args": ["run", "mcp"], + "cwd": "/absolute/path/to/mcp-haskell" + } + } +} +``` + +### Development Setup + +For development with Cabal: + +```json +{ + "mcpServers": { + "haskell-mcp-dev": { + "command": "cabal", + "args": ["run", "mcp"], + "cwd": "/home/user/projects/mcp-haskell", + "env": { + "GHC_ENVIRONMENT": "-" + } + } + } +} +``` + +### Production Setup + +For production with a compiled binary: + +```json +{ + "mcpServers": { + "haskell-mcp-prod": { + "command": "/usr/local/bin/mcp", + "args": [], + "cwd": "/opt/mcp-servers" + } + } +} +``` + +### Stack-based Setup + +If using Stack instead of Cabal: + +```json +{ + "mcpServers": { + "haskell-mcp-stack": { + "command": "stack", + "args": ["exec", "mcp"], + "cwd": "/path/to/mcp-haskell" + } + } +} +``` + +## Configuration Fields + +- **command**: The executable to run (cabal, stack, or direct binary path) +- **args**: Arguments passed to the command +- **cwd**: Working directory (should be the project root for development) +- **env**: Environment variables (optional) + +## Testing the Configuration + +1. Save the configuration to the appropriate location for your OS +2. Restart Claude Desktop +3. Start a new conversation +4. The Haskell MCP server should appear in the available tools/context + +## Troubleshooting + +### Common Issues + +1. **Path Problems**: Ensure `cwd` points to the correct project directory +2. **Permission Issues**: Make sure the command is executable +3. **Build Issues**: Run `cabal build` first to ensure the project compiles +4. **Port Conflicts**: Each server needs a unique name in the configuration + +### Debugging + +To test the server manually: + +```bash +cd /path/to/mcp-haskell +cabal run mcp +``` + +The server should start and wait for JSON-RPC messages on stdin. + +### Logs + +Claude Desktop logs can help debug connection issues: + +- **macOS**: `~/Library/Logs/Claude/` +- **Windows**: `%LOCALAPPDATA%\Claude\logs\` +- **Linux**: `~/.local/share/claude/logs/` + +## Example Usage + +Once configured, you can: + +1. **List Resources**: Ask Claude to show available resources +2. **Read Content**: Request specific resource content +3. **Use Tools**: Execute tools provided by the server +4. **Get Prompts**: Use pre-defined prompt templates + +The Haskell MCP server provides basic examples of each capability that you can extend for your specific use case. + +--- + +## HTTP Server Example + +**File:** `http-server.hs` + +Demonstrates how to run an MCP server using HTTP transport instead of StdIO. + +### Building and Running + +**Using Cabal (recommended):** +```bash +# From the project root +cabal build mcp-http +cabal run mcp-http +``` + +**Manual compilation:** +```bash +# From the project root +ghc -package-env=. -o examples/http-server examples/http-server.hs +cd examples +./http-server +``` + +**Using cabal exec:** +```bash +cabal exec ghc -- -package-env=. -o examples/http-server examples/http-server.hs +cd examples +./http-server +``` + +### Testing the HTTP Server + +Once running, the server exposes the MCP API at `POST http://localhost:8080/mcp`. + +**Test with curl:** + +```bash +# Ping test +curl -X POST http://localhost:8080/mcp \ + -H "Content-Type: application/json" \ + -d '{"jsonrpc":"2.0","id":1,"method":"ping"}' + +# Initialize the server +curl -X POST http://localhost:8080/mcp \ + -H "Content-Type: application/json" \ + -d '{ + "jsonrpc":"2.0", + "id":1, + "method":"initialize", + "params":{ + "protocolVersion":"2024-11-05", + "capabilities":{}, + "clientInfo":{"name":"test-client","version":"1.0.0"} + } + }' + +# List available tools +curl -X POST http://localhost:8080/mcp \ + -H "Content-Type: application/json" \ + -d '{"jsonrpc":"2.0","id":2,"method":"tools/list"}' + +# Call the getCurrentDate tool +curl -X POST http://localhost:8080/mcp \ + -H "Content-Type: application/json" \ + -d '{ + "jsonrpc":"2.0", + "id":3, + "method":"tools/call", + "params":{"name":"getCurrentDate"} + }' +``` + +**Test with HTTPie:** + +```bash +# Ping test +http POST localhost:8080/mcp jsonrpc=2.0 id:=1 method=ping + +# Initialize +http POST localhost:8080/mcp \ + jsonrpc=2.0 id:=1 method=initialize \ + params:='{"protocolVersion":"2024-11-05","capabilities":{},"clientInfo":{"name":"test-client","version":"1.0.0"}}' + +# List tools +http POST localhost:8080/mcp jsonrpc=2.0 id:=2 method=tools/list + +# Call tool +http POST localhost:8080/mcp \ + jsonrpc=2.0 id:=3 method=tools/call \ + params:='{"name":"getCurrentDate"}' +``` + +## Key Differences: StdIO vs HTTP + +| Aspect | StdIO Transport | HTTP Transport | +|--------|----------------|----------------| +| **Client Integration** | Process-based (stdin/stdout) | HTTP clients, web apps | +| **Message Format** | Line-delimited JSON-RPC | HTTP POST with JSON body | +| **Server Lifecycle** | Managed by client process | Independent HTTP service | +| **Debugging** | Log to stderr | HTTP access logs | +| **Scalability** | One client per process | Multiple concurrent clients | +| **Network** | Local only | Network accessible | + +## Implementation Notes + +- Both transports use the same `MCPServer` typeclass implementation +- Server logic is identical between StdIO and HTTP modes +- HTTP transport follows the MCP specification for streamable HTTP +- Future versions will support Server-Sent Events (SSE) for bidirectional communication + +## Error Handling + +The HTTP server returns appropriate HTTP status codes: + +- **200 OK**: Successful JSON-RPC response +- **400 Bad Request**: Invalid JSON or malformed JSON-RPC +- **500 Internal Server Error**: Server-side processing errors + +JSON-RPC errors are returned within the 200 response body following the JSON-RPC 2.0 specification. diff --git a/examples/claude-desktop-config.json b/examples/claude-desktop-config.json new file mode 100644 --- /dev/null +++ b/examples/claude-desktop-config.json @@ -0,0 +1,24 @@ +{ + "mcpServers": { + "haskell-mcp-development": { + "command": "cabal", + "args": ["run", "mcp"], + "cwd": "/absolute/path/to/mcp-haskell", + "env": { + "GHC_ENVIRONMENT": "-" + } + }, + "haskell-mcp-production": { + "command": "/usr/local/bin/mcp-haskell", + "args": [], + "cwd": "/opt/mcp-servers", + "env": {} + }, + "haskell-mcp-stack": { + "command": "stack", + "args": ["exec", "mcp"], + "cwd": "/path/to/mcp-haskell", + "env": {} + } + } +} diff --git a/examples/full-config-example.json b/examples/full-config-example.json new file mode 100644 --- /dev/null +++ b/examples/full-config-example.json @@ -0,0 +1,34 @@ +{ + "$schema": "https://schemas.claudeai.com/claude_desktop_config.json", + "mcpServers": { + "haskell-mcp-example": { + "command": "cabal", + "args": ["run", "mcp"], + "cwd": "/Users/username/projects/mcp-haskell", + "env": { + "GHC_ENVIRONMENT": "-", + "CABAL_CONFIG": "" + } + }, + "haskell-mcp-with-logging": { + "command": "cabal", + "args": ["run", "mcp", "--", "--verbose"], + "cwd": "/Users/username/projects/mcp-haskell", + "env": { + "MCP_LOG_LEVEL": "debug" + } + }, + "haskell-mcp-custom-tools": { + "command": "/usr/local/bin/mcp-haskell-tools", + "args": ["--config", "/etc/mcp/tools.conf"], + "cwd": "/var/lib/mcp", + "env": { + "MCP_TOOLS_PATH": "/usr/local/share/mcp-tools", + "MCP_RESOURCES_PATH": "/var/lib/mcp/resources" + } + } + }, + "globalShortcuts": { + "mcp": "Cmd+Shift+M" + } +} diff --git a/examples/http-server.hs b/examples/http-server.hs new file mode 100644 --- /dev/null +++ b/examples/http-server.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Example HTTP MCP Server +-- +-- This example demonstrates how to run the MCP server over HTTP transport. +-- The server will expose the MCP API at POST /mcp +-- +-- To test: +-- 1. Compile: cabal build mcp-http +-- 2. Run: cabal run mcp-http +-- 3. Send JSON-RPC requests to: http://localhost:/mcp +-- +-- Example request: +-- curl -X POST http://localhost:8080/mcp \ +-- -H "Content-Type: application/json" \ +-- -d '{"jsonrpc":"2.0","id":1,"method":"ping"}' +-- +-- Command line options: +-- cabal run mcp-http -- --port 8080 --log + +module Main where + +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Data.Text qualified as T +import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) +import Options.Applicative + +import MCP.Protocol hiding (CompletionResult) +import MCP.Protocol qualified as Protocol +import MCP.Server +import MCP.Server.HTTP +import MCP.Types + +-- | Command line options +data Options = Options + { optPort :: Int + , optEnableLogging :: 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" + ) + +-- | 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 config = + HTTPServerConfig + { httpPort = optPort + , httpServerInfo = serverInfo + , httpCapabilities = capabilities + , httpEnableLogging = optEnableLogging + } + + putStrLn $ "HTTP server configured, starting on port " ++ show optPort ++ "..." + putStrLn $ "MCP endpoint available at: POST http://localhost:" ++ show optPort ++ "/mcp" + putStrLn "" + putStrLn "Example test command:" + putStrLn $ "curl -X POST http://localhost:" ++ show optPort ++ "/mcp \\" + putStrLn " -H \"Content-Type: application/json\" \\" + putStrLn " -d '{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"ping\"}'" + putStrLn "" + + runServerHTTP config diff --git a/examples/test-mcp-server.sh b/examples/test-mcp-server.sh new file mode 100644 --- /dev/null +++ b/examples/test-mcp-server.sh @@ -0,0 +1,62 @@ +#!/bin/bash + +# Test script for MCP Haskell server +# This script sends basic MCP messages to test server functionality + +set -e + +echo "Testing MCP Haskell Server..." +echo "==============================" + +# Build the server first +echo "Building server..." +cabal build + +echo "" +echo "Testing server startup..." + +# Create a temporary file for test messages +TEST_FILE=$(mktemp) + +# Write test JSON-RPC messages (each on its own line as required by JSON-RPC) +cat > "$TEST_FILE" << 'EOF' +{"jsonrpc": "2.0", "id": 1, "method": "initialize", "params": {"protocolVersion": "2024-11-05", "capabilities": {"roots": {"listChanged": true}}, "clientInfo": {"name": "test-client", "version": "1.0.0"}}} +{"jsonrpc": "2.0", "id": 2, "method": "ping"} +{"jsonrpc": "2.0", "id": 3, "method": "resources/list"} +{"jsonrpc": "2.0", "id": 4, "method": "prompts/list"} +{"jsonrpc": "2.0", "id": 5, "method": "tools/list"} +EOF + +echo "" +echo "Sending test messages to server..." +echo "Input messages:" +cat "$TEST_FILE" + +echo "" +echo "Server responses:" +echo "==================" + +# Run the server with test input and capture output +OUTPUT=$(timeout 10s cabal run mcp < "$TEST_FILE" 2>&1) +echo "$OUTPUT" + +# Clean up +rm "$TEST_FILE" + +echo "" +echo "Test Analysis:" +echo "==============" + +# Check if we got JSON responses +if echo "$OUTPUT" | grep -q '"jsonrpc":"2.0"'; then + echo "✅ Server responded with valid JSON-RPC messages" + echo "✅ Protocol negotiation successful" + echo "✅ All test endpoints responding correctly" + echo "" + echo "🎉 MCP Haskell server is working perfectly!" + echo "You can now configure Claude Desktop to use this server." +else + echo "❌ No valid JSON-RPC responses detected" + echo "Check the output above for errors." + exit 1 +fi diff --git a/mcp.cabal b/mcp.cabal --- a/mcp.cabal +++ b/mcp.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 +version: 0.1.1.0 -- A short (one-line) description of the package. synopsis: A Haskell implementation of the Model Context Protocol (MCP) @@ -32,6 +32,14 @@ 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 + . + Both transports use the same MCPServer typeclass, allowing seamless switching between + communication methods while maintaining identical server logic. -- The license under which the package is released. license: MIT @@ -54,7 +62,12 @@ extra-doc-files: CHANGELOG.md -- Extra source files to be distributed with the package, such as examples, or a tutorial module. --- extra-source-files: +extra-source-files: + examples/README.md + examples/http-server.hs + examples/claude-desktop-config.json + examples/full-config-example.json + examples/test-mcp-server.sh common warnings ghc-options: -Wall @@ -68,6 +81,8 @@ MCP.Types MCP.Protocol MCP.Server + MCP.Server.StdIO + MCP.Server.HTTP -- Modules included in this library but not exported. -- other-modules: @@ -86,7 +101,13 @@ stm >= 2.5 && < 2.6, async >= 2.2 && < 2.3, mtl >= 2.3 && < 2.4, - transformers >= 0.6 && < 0.7 + 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 -- Directories containing source files. hs-source-dirs: src @@ -119,6 +140,36 @@ -- 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 + + -- Directories containing source files. + hs-source-dirs: examples -- Base language which the package is written in. default-language: GHC2021 diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -8,31 +8,22 @@ -- | -- Module : MCP.Server --- Description : MCP server implementation +-- 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 a complete MCP server implementation, including --- message handling, state management, and JSON-RPC communication over --- standard input/output streams. +-- This module provides the core types and interface for MCP server implementations. module MCP.Server ( -- * Server Interface MCPServer (..), ServerState (..), + ServerConfig (..), MCPServerM, runMCPServer, - - -- * Message Handling - handleMessage, - handleRequest, - handleNotification, - - -- * Server Runner - runServer, - ServerConfig (..), + initialServerState, -- * Utilities sendResponse, @@ -40,25 +31,18 @@ sendError, ) where -import Control.Exception (catch, throwIO) import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad.State.Strict (StateT, get, put, runStateT) -import Data.Aeson (ToJSON, decode, encode, fromJSON, object, toJSON) -import Data.Aeson qualified as Aeson -import Data.ByteString.Char8 qualified as BSC -import Data.ByteString.Lazy qualified as LBS +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 Data.Text qualified as T import System.IO (Handle, hFlush) -import System.IO.Error (isEOFError) -import MCP.Protocol hiding (capabilities) -import MCP.Protocol qualified as Protocol +import MCP.Protocol import MCP.Types -- | Server state tracking initialization, capabilities, and subscriptions @@ -80,6 +64,7 @@ } deriving (Show) + -- | The monad stack for MCP server operations type MCPServerM = ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) @@ -87,6 +72,9 @@ runMCPServer :: ServerConfig -> ServerState -> MCPServerM a -> IO (Either Text (a, ServerState)) runMCPServer config state action = runExceptT $ runStateT (runReaderT action config) state +-- | 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. initialServerState :: ServerCapabilities -> ServerState initialServerState caps = ServerState @@ -130,245 +118,3 @@ LBSC.hPutStrLn handle (encode notification) hFlush handle --- | 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" :: 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" :: Text))) $ - JSONRPCErrorInfo (-32600) "Invalid Request" Nothing - return Nothing - --- | Handle a JSON-RPC request -handleRequest :: (MCPServer MCPServerM) => JSONRPCRequest -> MCPServerM () -handleRequest (JSONRPCRequest _ reqId method params) = do - config <- ask - state <- get - - case method of - "initialize" -> case params of - Just p -> case fromJSON p of - Aeson.Success initParams -> handleInitialize reqId initParams - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "ping" -> handlePing reqId - "resources/list" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListResources listParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListResources (ListResourcesParams Nothing) - sendResponse (configOutput config) reqId result - "resources/read" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success readParams -> do - result <- handleReadResource readParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "resources/templates/list" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListResourceTemplates listParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListResourceTemplates (ListResourceTemplatesParams Nothing) - sendResponse (configOutput config) reqId result - "prompts/list" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListPrompts listParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListPrompts (ListPromptsParams Nothing) - sendResponse (configOutput config) reqId result - "prompts/get" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success getParams -> do - result <- handleGetPrompt getParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "tools/list" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success listParams -> do - result <- handleListTools listParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> do - result <- handleListTools (ListToolsParams Nothing) - sendResponse (configOutput config) reqId result - "tools/call" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success callParams -> do - result <- handleCallTool callParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "completion/complete" -> do - if not (serverInitialized state) - then - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32002) "Server not initialized" Nothing - else case params of - Just p -> case fromJSON p of - Aeson.Success completeParams -> do - result <- handleComplete completeParams - sendResponse (configOutput config) reqId result - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - "logging/setLevel" -> case params of - Just p -> case fromJSON p of - Aeson.Success setLevelParams -> do - _ <- handleSetLevel setLevelParams - -- SetLevel response is just an empty object - sendResponse (configOutput config) reqId (object []) - Aeson.Error e -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing - Nothing -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32602) "Missing params" Nothing - _ -> - sendError (configOutput config) reqId $ - JSONRPCErrorInfo (-32601) "Method not found" Nothing - -handleInitialize :: RequestId -> InitializeParams -> MCPServerM () -handleInitialize reqId params = do - config <- ask - state <- get - - let InitializeParams{capabilities = clientCaps} = params - - put - state - { serverInitialized = True - , clientCapabilities = Just clientCaps - , serverInfo = Just (configServerInfo config) - } - - let result = - InitializeResult - { protocolVersion = "2024-11-05" - , capabilities = serverCapabilities state - , serverInfo = configServerInfo config - , instructions = Nothing - , _meta = Nothing - } - - sendResponse (configOutput config) reqId result - -handlePing :: RequestId -> MCPServerM () -handlePing reqId = do - config <- ask - -- Ping response is just an empty object in MCP - sendResponse (configOutput config) reqId (object []) - --- | Handle a JSON-RPC notification -handleNotification :: JSONRPCNotification -> MCPServerM () -handleNotification _ = do - return () - --- | Run the MCP server with the given configuration -runServer :: (MCPServer MCPServerM) => ServerConfig -> IO () -runServer config = do - let initialState = initialServerState (configCapabilities config) - - let loop = do - eofOrLine <- - liftIO $ - catch - (Right <$> BSC.hGetLine (configInput config)) - (\e -> if isEOFError e then return (Left ()) else throwIO e) - case eofOrLine of - Left () -> return () -- EOF reached, exit gracefully - Right line -> do - result <- handleMessage line - case result of - Just () -> loop - Nothing -> return () - - result <- runMCPServer config initialState loop - case result of - Left err -> putStrLn $ "Server error: " ++ T.unpack err - Right _ -> return () -- Don't print "Server terminated" for clean EOF diff --git a/src/MCP/Server/HTTP.hs b/src/MCP/Server/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/HTTP.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# 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 (..), +) where + +import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, writeTVar) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) +import Control.Monad.State.Strict (get, put) +import Data.Aeson (encode, fromJSON, object, toJSON, (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as LBSC +import Data.Text (Text) +import Data.Text qualified as T +import Network.Wai (Application) +import Network.Wai.Handler.Warp (Port, run) +import Network.Wai.Middleware.RequestLogger (logStdoutDev) +import Servant (Handler, Proxy(..), Server, serve, throwError) +import Servant.API (JSON, Post, ReqBody, (:>)) +import Servant.Server (err400, err500, errBody) + +import MCP.Protocol +import MCP.Server (MCPServer(..), MCPServerM, ServerConfig(..), ServerState(..), runMCPServer, initialServerState) +import MCP.Types + +-- | Configuration for running an MCP HTTP server +data HTTPServerConfig = HTTPServerConfig + { httpPort :: Port + , httpServerInfo :: Implementation + , httpCapabilities :: ServerCapabilities + , httpEnableLogging :: Bool + } + deriving (Show) + +-- | MCP API definition for HTTP server (following the MCP transport spec) +type MCPAPI = "mcp" :> ReqBody '[JSON] Aeson.Value :> Post '[JSON] Aeson.Value + +-- | Create a WAI Application for the MCP HTTP server +mcpApp :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> Application +mcpApp config stateVar = + let baseApp = serve (Proxy :: Proxy MCPAPI) (mcpServer config stateVar) + in if httpEnableLogging config + then logStdoutDev baseApp + else baseApp + where + mcpServer :: HTTPServerConfig -> TVar ServerState -> Server MCPAPI + mcpServer httpConfig stateTVar = handleHTTPRequest httpConfig stateTVar + +-- | Handle HTTP MCP requests following the MCP transport protocol +handleHTTPRequest :: (MCPServer MCPServerM) => HTTPServerConfig -> TVar ServerState -> Aeson.Value -> Handler Aeson.Value +handleHTTPRequest httpConfig stateVar 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" .= T.unpack 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 = "Invalid JSON-RPC message type" } + Aeson.Error e -> throwError err400 { errBody = LBSC.pack $ "Invalid JSON-RPC message: " ++ 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 <- atomically $ readTVar 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 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) => JSONRPCRequest -> MCPServerM Aeson.Value +handleHTTPRequestInner (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 = "2024-11-05" + , 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) + } + +-- | Run the MCP server as an HTTP server +runServerHTTP :: (MCPServer MCPServerM) => HTTPServerConfig -> IO () +runServerHTTP config = do + -- Initialize the server state + stateVar <- newTVarIO $ initialServerState (httpCapabilities config) + putStrLn $ "Starting MCP HTTP Server on port " ++ show (httpPort config) ++ "..." + run (httpPort config) (mcpApp config stateVar) diff --git a/src/MCP/Server/StdIO.hs b/src/MCP/Server/StdIO.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/StdIO.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# 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, ServerState(..), ServerConfig(..), runMCPServer, initialServerState, sendResponse, sendError) +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