mcp 0.3.0.1 → 0.3.1.0

raw patch · 8 files changed

+623/−211 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +9/−5
• mcp.cabal +13/−7
• src/MCP/Server.hs +3/−3
• src/MCP/Server/HTTP.hs +73/−196
• src/MCP/Server/HTTP/Internal.hs +233/−0
• test/MCP/SimpleHTTPIntegration.hs +280/−0
• test/Main.hs +2/−0

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

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

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

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

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

@@ -0,0 +1,233 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module:      MCP.Server.HTTP.Internal+License:     MPL-2.0+Maintainer:  <matti@dpella.io>, <lobo@dpella.io>++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)

@@ -0,0 +1,280 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module:      MCP.SimpleHTTPIntegration+License:     MPL-2.0+Maintainer:  <matti@dpella.io>, <lobo@dpella.io>++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)

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