diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Changelog +## 0.3.1.0 + +### Added +- Simple unauthenticated HTTP transport (`SimpleHTTPAPI` / `simpleHttpApp`) in + `MCP.Server.HTTP`, for local development or use behind a reverse proxy. +- `MCP.Server.HTTP.Internal`: shared handler core factored out of the HTTP + transport, eliminating duplication between the JWT and simple transports. +- `--simple-http` flag in the example server. +- Integration tests for the simple HTTP transport. + ## 0.3.0.1 ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ 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`. +built on Servant. 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. @@ -14,8 +14,11 @@ - **`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.HTTP`** — Servant-based HTTP transports with streaming SSE + responses at the `/mcp` endpoint. Provides both a JWT-authenticated API + (`MCPAPI` / `mcpAPI`) and a simple unauthenticated API + (`SimpleHTTPAPI` / `simpleHttpApp`) for local development or use behind a + reverse proxy. - **`MCP.Server.Stdio`** — Stdio transport reading/writing JSON-RPC messages line-by-line, suitable for subprocess-based integrations. @@ -76,8 +79,9 @@ ## Features -- **Two transports**: HTTP (Servant + SSE) and stdio -- **JWT authentication** via `servant-auth-server` (HTTP transport) +- **Three transports**: HTTP with JWT auth, simple unauthenticated HTTP, and stdio +- **JWT authentication** via `servant-auth-server` (authenticated HTTP transport) +- **Simple HTTP** for local development or behind a reverse proxy (`simpleHttpApp`) - **Extensible handler framework**: `ProcessHandlers` record with optional handlers for each MCP method - **Tool helpers**: `ToolHandler`, `toolHandler`, `withToolHandlers`, diff --git a/mcp.cabal b/mcp.cabal --- a/mcp.cabal +++ b/mcp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: mcp -version: 0.3.0.1 +version: 0.3.1.0 license: MPL-2.0 license-file: LICENSE copyright: (c) 2025 DPella AB @@ -17,18 +17,21 @@ 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. + Protocol (MCP) for Haskell, built on Servant. 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. + Three transports are provided: HTTP with JWT authentication via + @servant-auth-server@, a simple unauthenticated HTTP transport for local + development or use behind a reverse proxy, and a stdio transport for + subprocess-based integrations. All HTTP transports use 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/DPella/mcp bug-reports: https://github.com/DPella/mcp/issues @@ -62,6 +65,7 @@ MCP.Server MCP.Server.Common MCP.Server.HTTP + MCP.Server.HTTP.Internal MCP.Server.Stdio build-depends: @@ -77,6 +81,7 @@ servant-server >=0.19 && <0.21, text >=2.0 && <2.2, time >=1.12 && <1.15, + wai >=3.2 && <3.3, test-suite test-mcp type: exitcode-stdio-1.0 @@ -103,6 +108,7 @@ other-modules: MCP.Integration + MCP.SimpleHTTPIntegration MCP.StdioIntegration MCP.TestServer MCP.TestUtils diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -8,9 +8,9 @@ This module re-exports everything from the transport-specific modules for backwards compatibility. For finer-grained imports use: -* "MCP.Server.Common" — types, state, request routing, tool helpers -* "MCP.Server.HTTP" — Servant-based HTTP transport with JWT auth -* "MCP.Server.Stdio" — stdio transport +* "MCP.Server.Common" — types, state, request routing, tool helpers +* "MCP.Server.HTTP" — HTTP transports (JWT-authenticated and unauthenticated) +* "MCP.Server.Stdio" — stdio transport -} module MCP.Server ( module MCP.Server.Common, diff --git a/src/MCP/Server/HTTP.hs b/src/MCP/Server/HTTP.hs --- a/src/MCP/Server/HTTP.hs +++ b/src/MCP/Server/HTTP.hs @@ -1,8 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} {- | @@ -10,57 +7,51 @@ License: MPL-2.0 Maintainer: , -Servant-based HTTP transport for the MCP server. +Servant-based HTTP transports 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. +This module provides two HTTP transports: + +* 'MCPAPI' / 'mcpAPI' — a JWT-authenticated transport using @servant-auth@. + Use this when your server is exposed to the network and you need + per-request identity. + +* 'SimpleHTTPAPI' / 'simpleHttpApp' — an unauthenticated transport that + accepts all requests unconditionally. This should only be used on + @localhost@ for local development, or behind a reverse proxy (e.g. + Nginx, Envoy, Cloudflare Access) that handles authentication before + requests reach the application. Do __not__ expose it directly to the + public internet. + +Both transports accept JSON-RPC requests via POST and return responses as +SSE streams at the @\/mcp@ endpoint. -} module MCP.Server.HTTP ( - -- * Servant API + -- * JWT-authenticated API MCPAPI, mcpAPI, handleMCPRequest, handleMCPEvents, + + -- * Simple (unauthenticated) API + SimpleHTTPAPI, + simpleHttpApp, ) 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.Aeson (encode, object, (.=)) 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 MCP.Server.HTTP.Internal 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") +-- --------------------------------------------------------------------------- +-- JWT-authenticated API +-- --------------------------------------------------------------------------- -{- | Servant API type for the MCP endpoint. +{- | Servant API type for the JWT-authenticated MCP endpoint. Accepts JSON-RPC requests with JWT authentication via servant-auth. All MCP methods are multiplexed through this single endpoint. @@ -96,16 +87,8 @@ {- | 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. +Validates JWT authentication, then delegates to the shared +'handleMCPRequestCore' from "MCP.Server.HTTP.Internal". -} handleMCPRequest :: MVar MCPServerState -> @@ -113,161 +96,55 @@ 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 auth_result of + AuthServer.NoSuchUser -> mcpAuthError "Invalid authentication credentials" + AuthServer.BadPassword -> mcpAuthError "Authentication failed" + AuthServer.Indefinite -> mcpAuthError "Authentication error" + AuthServer.Authenticated auth_user -> + handleMCPRequestCore state_var (Just auth_user) request_value + where + mcpAuthError :: Text -> Handler (SourceIO JSONRPCMessage) + mcpAuthError err = throwError err401{errBody = encode $ object ["error" .= err]} - 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 <> "'"} +-- --------------------------------------------------------------------------- +-- Simple (unauthenticated) API +-- --------------------------------------------------------------------------- - -- Validate request ID - when (not $ isValidRequestId req_id) $ - throwError err400{errBody = "Invalid request ID, must be string, number, or null"} +{- | Servant API type for the unauthenticated MCP endpoint. - -- 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'} +Unlike 'MCPAPI', this does not use @servant-auth@ and performs no +authentication. See the module documentation for guidance on when it is +safe to use this transport. +-} +type SimpleHTTPAPI = + "mcp" + :> ReqBody '[JSON] JSONRPCMessage + :> StreamPost JSONRPCFrame JSONRPCEvent (SourceIO JSONRPCMessage) + :<|> "mcp" + :> StreamGet JSONRPCFrame JSONRPCEvent (SourceIO JSONRPCMessage) - -- Process the request routing to the appropriate handler - res <- liftIO $ modifyMVar state_var $ fmap swap <$> runStateT (processMethod server_initialized method params) +{- | Build a WAI 'Application' for the unauthenticated HTTP transport. - -- 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 () +Every request is accepted without authentication. This should only be +used on @localhost@ or behind an authenticating reverse proxy. +-} +simpleHttpApp :: MVar MCPServerState -> Application +simpleHttpApp state_var = + serve (Proxy @SimpleHTTPAPI) $ + handleSimpleHTTPRequest state_var + :<|> handleSimpleHTTPEvents - -- Get the final result to return - final_result <- liftIO $ handleProcessResult req_id res +-- | Handle GET \/mcp requests (unauthenticated). +handleSimpleHTTPEvents :: Handler (SourceIO JSONRPCMessage) +handleSimpleHTTPEvents = return $ fromStepT Stop - -- 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) +{- | Handle incoming MCP JSON-RPC requests (unauthenticated). - -- Helper to throw unauthorized errors - mcpAuthError :: Text -> Handler (StepT IO JSONRPCMessage) - mcpAuthError err = throwError err401{errBody = encode $ object ["error" .= err]} +Delegates directly to 'handleMCPRequestCore'. No user type is available, +so @mcp_handler_init@ is not called. +-} +handleSimpleHTTPRequest :: + MVar MCPServerState -> + JSONRPCMessage -> + Handler (SourceIO JSONRPCMessage) +handleSimpleHTTPRequest state_var = handleMCPRequestCore state_var Nothing diff --git a/src/MCP/Server/HTTP/Internal.hs b/src/MCP/Server/HTTP/Internal.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/HTTP/Internal.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module: MCP.Server.HTTP.Internal +License: MPL-2.0 +Maintainer: , + +Shared internals for HTTP-based MCP transports. + +This module contains the SSE framing types and the core request handler +used by both the JWT-authenticated and simple (unauthenticated) HTTP +transports in 'MCP.Server.HTTP'. Each transport handles authentication +(or skips it) and then delegates to 'handleMCPRequestCore'. +-} +module MCP.Server.HTTP.Internal ( + -- * SSE framing + JSONRPCFrame, + JSONRPCEvent, + + -- * Core request handler + handleMCPRequestCore, +) 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 qualified as T +import Data.Text.Encoding (encodeUtf8) +import Data.Tuple (swap) +import MCP.Server.Common +import Network.HTTP.Media ((//)) +import Servant +import Servant.Types.SourceT +import Servant.Types.SourceT qualified as Source + +-- --------------------------------------------------------------------------- +-- SSE framing types +-- --------------------------------------------------------------------------- + +-- | Frame for JSON-RPC messages — appends a newline after each chunk. +data JSONRPCFrame + +instance FramingRender JSONRPCFrame where + framingRender _ f = fmap (\x -> f x <> "\n") + +-- | Content-type for Server-Sent Events. +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") + +-- --------------------------------------------------------------------------- +-- Core request handler +-- --------------------------------------------------------------------------- + +{- | Transport-agnostic HTTP request handler. + +Both 'MCP.Server.HTTP.handleMCPRequest' and +'MCP.Server.SimpleHTTP.handleSimpleHTTPRequest' delegate here after +performing their own authentication checks. + +When @mb_user@ is @'Just' user@, the server calls @mcp_handler_init user@ +on the first @initialize@ request (JWT\/HTTP transport). When @'Nothing'@, +the init hook is skipped (SimpleHTTP \/ Stdio convention). +-} +handleMCPRequestCore :: + MVar MCPServerState -> + -- | Authenticated user, if available (for @mcp_handler_init@) + Maybe MCPHandlerUser -> + JSONRPCMessage -> + Handler (SourceIO JSONRPCMessage) +handleMCPRequestCore state_var mb_user request_value = + fromStepT <$> do + MCPServerState + { mcp_server_initialized = server_initialized + , mcp_log_level = log_level + } <- + liftIO $ readMVar state_var + + -- Log the request if debug level + 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} + -- 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 + -- (only when an authenticated user is available) + case mb_user of + Just auth_user -> + 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'} + Nothing -> return () + + -- 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 + handler_st' <- handler_finalize handler_st + return st{mcp_handler_state = handler_st'} + return final_result + where + 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 + ci_resp <- liftIO $ takeMVar mvar + 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) diff --git a/test/MCP/SimpleHTTPIntegration.hs b/test/MCP/SimpleHTTPIntegration.hs new file mode 100644 --- /dev/null +++ b/test/MCP/SimpleHTTPIntegration.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Module: MCP.SimpleHTTPIntegration +License: MPL-2.0 +Maintainer: , + +Integration tests for the SimpleHTTP transport. +-} +module MCP.SimpleHTTPIntegration where + +import Control.Concurrent.MVar (MVar, newMVar) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, 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.IntMap qualified as IM +import Data.Map qualified as Map +import MCP.Protocol +import MCP.Server.Common +import MCP.Server.HTTP (simpleHttpApp) +import MCP.TestServer ( + availablePrompts, + availableResourceTemplates, + availableResources, + availableTools, + initializeTestState, + mb_handler_finalize, + processHandlers, + ) +import MCP.TestUtils +import Network.HTTP.Types qualified as HTTP +import Network.Wai (Application) +import Network.Wai.Test (SResponse (..)) +import Test.Hspec +import Test.Hspec.Wai ( + WaiSession, + get, + shouldRespondWith, + withState, + ) + +-- --------------------------------------------------------------------------- +-- Test application setup +-- --------------------------------------------------------------------------- + +-- | Create a test application using SimpleHTTP (no auth) +createTestApp :: IO ((), Application) +createTestApp = do + state_var <- createSimpleHTTPTestState + let app = simpleHttpApp state_var + return ((), app) + +-- | Create test server state for SimpleHTTP (no handler_init, same as Stdio) +createSimpleHTTPTestState :: IO (MVar MCPServerState) +createSimpleHTTPTestState = do + let impl = Implementation "test-server" "1.0.0" Nothing + let server_caps = + ServerCapabilities + { logging = Just LoggingCapability + , prompts = Just (PromptsCapability{listChanged = Nothing}) + , resources = + Just + (ResourcesCapability{listChanged = Nothing, subscribe = Nothing}) + , tools = Just (ToolsCapability{listChanged = Just True}) + , completions = Just CompletionsCapability + , experimental = Nothing + } + newMVar + MCPServerState + { mcp_server_initialized = False + , mcp_handler_state = initializeTestState + , mcp_handler_init = Nothing -- no user type in SimpleHTTP + , mcp_handler_finalize = mb_handler_finalize + , mcp_client_capabilities = Nothing + , mcp_log_level = Just Info + , mcp_pending_responses = IM.empty + , mcp_pending_responses_next = 1 + , mcp_server_capabilities = server_caps + , mcp_implementation = impl + , mcp_instructions = Nothing + , mcp_process_handlers = processHandlers + } + +-- --------------------------------------------------------------------------- +-- Test specifications +-- --------------------------------------------------------------------------- + +-- | Complete SimpleHTTP integration test suite +simpleHTTPIntegrationSpec :: Spec +simpleHTTPIntegrationSpec = describe "SimpleHTTP Integration Tests" $ do + withState createTestApp $ do + protocolFlowSpec + endpointsSpec + preInitializationSpec + +-- --------------------------------------------------------------------------- +-- Protocol flow tests +-- --------------------------------------------------------------------------- + +protocolFlowSpec :: SpecWith ((), Application) +protocolFlowSpec = describe "Protocol Flow" $ do + it "initialization handshake works" $ do + let init_req = toJSON createInitializeRequest + resp_init <- mcpPostRequest headers init_req + withValidSimpleHTTPResponse resp_init 1 validateInitializationResponse + + let notify_request = toJSON createInitializedNotification + mcpPostRequestOk headers notify_request + + it "rejects request with wrong jsonrpc version" $ do + let invalid_request = + toJSON $ + createJSONRPCRequest (Just "1.0") (1 :: Int) "ping" Aeson.Null + mcpPostRequestExpects headers invalid_request 400 + + it "accepts GET /mcp" $ + get "/mcp" `shouldRespondWith` 200 + +-- --------------------------------------------------------------------------- +-- Endpoint tests +-- --------------------------------------------------------------------------- + +endpointsSpec :: SpecWith ((), Application) +endpointsSpec = describe "Endpoints" $ do + it "handles tools/list request" $ + withInitializedSimpleHTTP $ do + let req = toJSON $ createListToolsRequest 2 + resp <- mcpPostRequest headers req + withValidSimpleHTTPResponse resp 2 $ \(ListToolsResult{tools = ls_tools}) -> + length ls_tools `shouldBe` length availableTools + + it "handles tools/call request" $ + withInitializedSimpleHTTP $ do + let req = toJSON $ createCallToolRequest 3 "addition-tool" [("arg1", toJSON (5 :: Int)), ("arg2", toJSON (7 :: Int))] + resp <- mcpPostRequest headers req + withValidSimpleHTTPResponse resp 3 $ \(CallToolResult{structuredContent = structured}) -> + case structured of + Just map_results -> + Map.lookup "result" map_results `shouldBe` Just (toJSON (12 :: Int)) + Nothing -> expectationFailure "Expected structured content" + + it "handles resources/list request" $ + withInitializedSimpleHTTP $ do + let req = toJSON $ createListResourcesRequest 4 + resp <- mcpPostRequest headers req + withValidSimpleHTTPResponse resp 4 $ \(ListResourcesResult{resources = ls_resources}) -> + length ls_resources `shouldBe` length availableResources + + it "handles prompts/list request" $ + withInitializedSimpleHTTP $ do + let req = toJSON $ createPromptListRequest 5 + resp <- mcpPostRequest headers req + withValidSimpleHTTPResponse resp 5 $ \(ListPromptsResult{prompts = ls_prompts}) -> + length ls_prompts `shouldBe` length availablePrompts + + it "handles resources/templates/list request" $ + withInitializedSimpleHTTP $ do + let req = toJSON $ createListResourceTemplatesRequest 6 + resp <- mcpPostRequest headers req + withValidSimpleHTTPResponse resp 6 $ \(ListResourceTemplatesResult{resourceTemplates = templates}) -> + length templates `shouldBe` length availableResourceTemplates + + it "handles ping after initialization" $ + withInitializedSimpleHTTP $ do + let req = toJSON createPingRequest + mcpPostRequestOk headers req + +-- --------------------------------------------------------------------------- +-- Pre-initialization tests +-- --------------------------------------------------------------------------- + +preInitializationSpec :: SpecWith ((), Application) +preInitializationSpec = describe "Pre-Initialization Enforcement" $ do + it "rejects tools/list before initialization" $ do + let req = toJSON $ createListToolsRequest 1 + resp <- mcpPostRequest headers req + withValidSimpleHTTPErrorResponse resp 1 $ \err_info -> + code err_info `shouldBe` sERVER_NOT_INITIALIZED + + it "allows ping before initialization" $ do + let req = toJSON createPingRequest + mcpPostRequestOk headers req + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +-- | Standard headers for SimpleHTTP requests (no auth needed) +headers :: [(HTTP.HeaderName, BS.ByteString)] +headers = [("Content-Type", "application/json")] + +-- | Initialize server then run action +withInitializedSimpleHTTP :: WaiSession () a -> WaiSession () a +withInitializedSimpleHTTP f = do + let init_request = toJSON createInitializeRequest + mcpPostRequestOk headers init_request + let notify_request = toJSON createInitializedNotification + mcpPostRequestOk headers notify_request + f + +-- | Parse and validate a SimpleHTTP JSON-RPC response +withValidSimpleHTTPResponse :: + (FromJSON a) => + SResponse -> + Int -> + (a -> Expectation) -> + WaiSession () () +withValidSimpleHTTPResponse 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 + +-- | Parse and validate a SimpleHTTP JSON-RPC error response +withValidSimpleHTTPErrorResponse :: + SResponse -> + Int -> + (JSONRPCErrorInfo -> Expectation) -> + WaiSession () () +withValidSimpleHTTPErrorResponse 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 + +-- | Validates initialization response +validateInitializationResponse :: InitializeResult -> Expectation +validateInitializationResponse InitializeResult{protocolVersion = init_protocol_version} = do + init_protocol_version `shouldBe` pROTOCOL_VERSION + +-- ** SSE parsing (same as Integration.hs) + +-- | 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 SSE format +extractSSEData :: LBS.ByteString -> Maybe BS.ByteString +extractSSEData sseBody = snd <$> P.maybeResult (P.parse parseEvent sseBody) + where + parseEvent = do + _ <- P.string "event:" + msg_type <- P.takeWhileIncluding (not . C.isEndOfLine) + _ <- C.string "data:" + json_data <- P.takeWhile (not . C.isEndOfLine) + return (msg_type, json_data) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,6 +11,7 @@ module Main where import MCP.Integration qualified as Integration +import MCP.SimpleHTTPIntegration qualified as SimpleHTTPIntegration import MCP.StdioIntegration qualified as StdioIntegration import Test.Hspec (describe, hspec) @@ -19,4 +20,5 @@ main = hspec $ do describe "MCP Library" $ do Integration.integrationSpec + SimpleHTTPIntegration.simpleHTTPIntegrationSpec StdioIntegration.stdioIntegrationSpec