From 1f1b4973537e31864932ff87755c8e5174e080dd Mon Sep 17 00:00:00 2001 From: tom Date: Sat, 1 Aug 2026 11:44:48 +0200 Subject: [PATCH 1/3] Implement request cancellation (ADR 0008) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In-flight requests can now actually be interrupted, per the spec's 'stop work as soon as practical, send nothing further for that request': - stdio: every request runs in its own async task, registered in an in-flight table by request id before its body starts (so cancellation can never race registration) and self-deregistering on any exit. notifications/cancelled cancels the referenced task — falling back from subscription teardown, ignoring unknown/completed ids as the spec requires. Writes to stdout are uninterruptible inside the write lock so a cancellation can never leave a half-written line on the channel; EOF cancels all in-flight tasks before subscription closure. - HTTP: for SSE responses the handler runs raced against a keep-alive writer that doubles as the disconnect detector — when the client closes the stream the next write throws and the handler task is cancelled. Keep-alive interval set to 5s (bounds cancellation latency); stream writes serialized behind a lock and made uninterruptible so an event can't be split. Single-JSON requests already get their thread torn down by Warp on disconnect. - Contract documented (README + haddock): cancellation reaches handler code as an asynchronous exception, so handlers acquiring resources must use bracket/finally. - New Spec.Cancellation covering the contract (no further emissions, no response, bracket release); live smoke-tested on both transports (cancelled stdio call: no response for that id, no completion marker, server keeps serving; aborted HTTP stream: handler cancelled, marker absent, server keeps serving). New dependency: async. ADR 0008 marked Landed (0.2.0.1). --- CHANGELOG.md | 10 ++++ README.md | 30 ++++++++++ mcp-server.cabal | 3 + specs/ADR_0008_request_cancellation.md | 2 +- specs/README.md | 2 +- src/MCP/Server/Transport/Http.hs | 44 +++++++++++--- src/MCP/Server/Transport/Stdio.hs | 80 ++++++++++++++++++++------ test/HspecMain.hs | 2 + test/Spec/Cancellation.hs | 80 ++++++++++++++++++++++++++ 9 files changed, 228 insertions(+), 25 deletions(-) create mode 100644 test/Spec/Cancellation.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 09e5a85..47a9731 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,16 @@ including changes that would ordinarily demand a major bump. Anyone explicitly pinning the deprecated 0.2.0.0 should move here. The unreleased 0.2.1.0 line below is folded in as well.) +* Request cancellation (ADR 0008): in-flight requests can now actually be + interrupted, per the spec's "stop work as soon as practical, send nothing + further for that request". On stdio every request runs in its own task + and `notifications/cancelled` cancels the referenced one (unknown or + completed ids are ignored); on HTTP, closing an SSE response stream + cancels the running handler (detected within one keep-alive interval, + now 5s), and Warp already tears down single-JSON request threads on + disconnect. Cancellation is delivered as an asynchronous exception, so + handlers acquiring resources should use `bracket` — documented in the + README. New dependency: `async`. * Progress notifications and per-request SSE (ADR 0007): handlers can call `reportProgress` and `logToClient` on the `ClientContext` — both safe unconditionally. `reportProgress` emits `notifications/progress` diff --git a/README.md b/README.md index 478304d..9c5fcac 100644 --- a/README.md +++ b/README.md @@ -18,6 +18,8 @@ A fully-featured Haskell library for building [Model Context Protocol (MCP)](htt - ✅ **Tools**: Model-controlled callable functions - ✅ **Completions**: Argument autocompletion for prompts and templates - ✅ **Change Notifications**: `listChanged`/resource-update pushes, via `subscriptions/listen` (2026-07-28) or legacy stdio delivery +- ✅ **Progress & Logging**: `notifications/progress` and `notifications/message` scoped to the requesting client +- ✅ **Cancellation**: `notifications/cancelled` (stdio) and stream closure (HTTP) interrupt in-flight handlers - ✅ **Initialization Flow**: Complete protocol lifecycle with version negotiation - ✅ **Error Handling**: Comprehensive error types and JSON-RPC error responses @@ -341,6 +343,34 @@ before the response; on HTTP, a request that opted in is answered with an SSE response stream carrying the notifications followed by the final response (requests that didn't opt in keep the single-JSON response). +## Cancellation + +In-flight requests can be cancelled, and per the spec the server then stops +work as soon as practical and sends nothing further for that request: + +- **stdio**: each request runs in its own task; a `notifications/cancelled` + naming its id cancels the task (cancellations for unknown or completed ids + are ignored, as required). +- **HTTP**: closing the response stream is the cancellation signal. For SSE + responses the handler is cancelled as soon as the disconnect is detected + (within one keep-alive interval); for single-JSON responses Warp tears the + request thread down on disconnect. + +Cancellation is delivered to handler code as an asynchronous exception (the +standard GHC mechanism, as used by `timeout` and `cancel`). Handlers are +interruptible wherever they block in `IO`; a handler that acquires resources +must release them with `bracket`/`finally` so cancellation cannot leak them: + +```haskell +handleTool ctx (ImportData file) = + bracket (openFile file ReadMode) hClose $ \h -> do + ... +``` + +Handlers that must not be interrupted mid-operation can shield critical +sections with `mask`, but should keep them short — cancellation waits for +them. + ## Change Notifications Servers whose tool/prompt/resource lists change at runtime can push change diff --git a/mcp-server.cabal b/mcp-server.cabal index 606f247..4ad752d 100644 --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -90,6 +90,7 @@ library -- Other library packages from which modules are imported. build-depends: aeson >=2 && <3, + async >=2.2 && <2.3, base >=4.18 && <4.23, base64-bytestring >=1.0 && <1.3, bytestring >=0.10 && <0.13, @@ -180,6 +181,7 @@ test-suite haskell-mcp-server-test other-modules: Spec.AdvancedDerivation Spec.BasicDerivation + Spec.Cancellation Spec.DefinitionMetadata Spec.DerivedOutput Spec.GoldenWire @@ -209,6 +211,7 @@ test-suite haskell-mcp-server-test build-depends: QuickCheck, aeson, + async, base, bytestring, containers, diff --git a/specs/ADR_0008_request_cancellation.md b/specs/ADR_0008_request_cancellation.md index 2bf9395..6d17832 100644 --- a/specs/ADR_0008_request_cancellation.md +++ b/specs/ADR_0008_request_cancellation.md @@ -1,6 +1,6 @@ # ADR 0008: Cancellation of in-flight requests -- **Status**: Proposed +- **Status**: Landed (0.2.0.1) - **Date**: 2026-08-01 - **Depends on**: ADR_0007 diff --git a/specs/README.md b/specs/README.md index 23b803f..904d78a 100644 --- a/specs/README.md +++ b/specs/README.md @@ -44,7 +44,7 @@ Filename `ADR_XXXX_short_slug.md`, numbered sequentially. Body: | [0005](ADR_0005_derived_output_schemas.md) | Derived output schemas and structured content | Proposed | | [0006](ADR_0006_definition_metadata.md) | Tool annotations, icons, content annotations | Proposed | | [0007](ADR_0007_progress_notifications.md) | Progress notifications and per-request SSE | Proposed | -| [0008](ADR_0008_request_cancellation.md) | Cancellation of in-flight requests | Proposed | +| [0008](ADR_0008_request_cancellation.md) | Cancellation of in-flight requests | Landed (0.2.0.1) | | [0009](ADR_0009_mrtr_input_required.md) | MRTR: input_required results (elicitation) | Proposed | | [0010](ADR_0010_oauth_resource_metadata.md) | OAuth protected-resource metadata | Proposed | | [0011](ADR_0011_protocol_completeness.md) | Pagination and the extensions capability | Proposed | diff --git a/src/MCP/Server/Transport/Http.hs b/src/MCP/Server/Transport/Http.hs index a2b779e..37787c1 100644 --- a/src/MCP/Server/Transport/Http.hs +++ b/src/MCP/Server/Transport/Http.hs @@ -17,8 +17,12 @@ module MCP.Server.Transport.Http , decodeSentinel ) where +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race) +import Control.Concurrent.MVar (newMVar, withMVar) import Control.Concurrent.STM (atomically, check, orElse, readTChan, readTVar, registerDelay) +import Control.Exception (uninterruptibleMask_) import Control.Monad (forever, when) import Data.Aeson import qualified Data.Aeson.KeyMap as KM @@ -122,6 +126,13 @@ sseHeaders = -- | Transport-specific implementation for HTTP +-- +-- A client closing the connection is its cancellation signal: for SSE +-- responses the handler task is cancelled once the disconnect surfaces (at +-- most one keep-alive interval later), and for single-JSON responses Warp +-- tears the request thread down. Cancellation reaches handler code as an +-- asynchronous exception: handlers that acquire resources should release +-- them with 'Control.Exception.bracket'. transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO () transportRunHttp config serverInfo handlers = do let settings = Warp.setHost (fromString $ httpHost config) $ @@ -445,12 +456,21 @@ handleSubscriptionsListen config src body respond = -- | Serve a request that opted into request-scoped notifications: the -- response is an SSE stream on which progress and client-log notifications -- flow, followed by the final JSON-RPC response. +-- +-- The handler runs in its own task, raced against a keep-alive writer that +-- doubles as the disconnect detector: when the client closes the stream the +-- next keep-alive write throws, the race cancels the handler task, and +-- nothing further is produced for the request. handleStreamingRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived handleStreamingRequest config serverInfo handlers ctx body respond = respond $ Wai.responseStream status200 sseHeaders $ \write flush -> do - let sendEvent v = do - write $ B.lazyByteString $ "data: " <> encode v <> "\n\n" + -- One writer at a time, and a cancellation arriving mid-write cannot + -- split an event in half + streamLock <- newMVar () + let sendChunk b = withMVar streamLock $ \_ -> uninterruptibleMask_ $ do + write b flush + sendEvent v = sendChunk $ B.lazyByteString $ "data: " <> encode v <> "\n\n" emit n = sendEvent (toJSON (n :: JsonRpcNotification)) case eitherDecode body of Left err -> do @@ -464,11 +484,21 @@ handleStreamingRequest config serverInfo handlers ctx body respond = { errorCode = -32600, errorMessage = "Invalid Request", errorData = Nothing } Right message -> do logVerbose config $ "Processing streaming HTTP message: " ++ show (getMessageSummary message) - maybeResponse <- handleMcpMessage serverInfo (httpCacheHints config) - (httpNotifSupport config) emit handlers ctx message - case maybeResponse of - Just responseMsg -> sendEvent (encodeJsonRpcMessage responseMsg) - Nothing -> pure () + -- 5s: short enough that an abandoned handler is cancelled + -- promptly (a write to a closed connection is what surfaces the + -- disconnect), long enough to stay negligible on the wire + let keepAlive :: IO () + keepAlive = forever $ do + threadDelay 5000000 + sendChunk $ B.byteString ": keep-alive\n\n" + outcome <- race + (handleMcpMessage serverInfo (httpCacheHints config) + (httpNotifSupport config) emit handlers ctx message) + keepAlive + case outcome of + Left (Just responseMsg) -> sendEvent (encodeJsonRpcMessage responseMsg) + Left Nothing -> pure () + Right () -> pure () -- | Handle JSON-RPC request from HTTP body handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers -> ClientContext -> Bool -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs index cc8cd24..6263e6c 100644 --- a/src/MCP/Server/Transport/Stdio.hs +++ b/src/MCP/Server/Transport/Stdio.hs @@ -10,9 +10,12 @@ module MCP.Server.Transport.Stdio ) where import Control.Concurrent (ThreadId, forkIO, killThread) -import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar, +import Control.Concurrent.Async (Async, async, cancel) +import Control.Concurrent.MVar (modifyMVar_, newEmptyMVar, newMVar, + putMVar, readMVar, takeMVar, withMVar) import Control.Concurrent.STM (atomically, readTChan) +import Control.Exception (finally, uninterruptibleMask_) import Control.Monad (forever, unless, when) import Data.Aeson import qualified Data.Aeson.KeyMap as KM @@ -61,23 +64,34 @@ transportRunStdio :: McpServerInfo -> McpServerHandlers -> IO () transportRunStdio = transportRunStdioWithConfig defaultStdioConfig -- | Run the STDIO transport with the given configuration. +-- +-- Each request is served in its own task, so a @notifications/cancelled@ +-- naming its id can interrupt it mid-flight (after which nothing further is +-- written for that id). Cancellation reaches handler code as an +-- asynchronous exception: handlers that acquire resources should release +-- them with 'Control.Exception.bracket'. transportRunStdioWithConfig :: StdioConfig -> McpServerInfo -> McpServerHandlers -> IO () transportRunStdioWithConfig config serverInfo handlers = do -- Ensure UTF-8 encoding for all handles hSetEncoding stderr utf8 hSetEncoding stdout utf8 - -- Subscription threads and the main loop share stdout: one line at a time. + -- Subscription threads, request tasks and the main loop share stdout: + -- one line at a time. writeLock <- newMVar () -- Active subscriptions_listen streams, by their request id subsVar <- newMVar ([] :: [(RequestId, ThreadId)]) + -- In-flight request tasks, by request id (cancellable) + inflightVar <- newMVar ([] :: [(RequestId, Async ())]) -- Whether a legacy client has completed initialize (gates legacy pushes) legacyReady <- newIORef False let logLine = TIO.hPutStrLn stderr logVerbose msg = when (stdioVerbose config) $ logLine msg - sendRaw bytes = withMVar writeLock $ \_ -> do + -- Writes are uninterruptible so a cancellation arriving mid-write + -- cannot corrupt the message channel with a half line + sendRaw bytes = withMVar writeLock $ \_ -> uninterruptibleMask_ $ do TIO.putStrLn $ TE.decodeUtf8 $ BSL.toStrict bytes hFlush stdout sendMessage msg = sendRaw $ encode $ encodeJsonRpcMessage msg @@ -136,6 +150,28 @@ transportRunStdioWithConfig config serverInfo handlers = do sendResponse $ closureResponse serverInfo subId) subs + -- Cancel an in-flight request task. 'cancel' waits for the task to + -- finish, so once this returns nothing further is written for that id. + cancelInflight cancelledId = do + inflight <- readMVar inflightVar + case lookup cancelledId inflight of + Nothing -> pure False + Just task -> do + cancel task + logLine $ "Cancelled request " <> T.pack (show cancelledId) + pure True + + dispatchMessage message = do + -- Request-scoped notifications (progress, client logs) share the + -- locked stdout channel, interleaved before the response + response <- handleMcpMessage serverInfo (stdioCacheHints config) notifSupport sendNotification handlers anonymousContext message + case response of + Just responseMsg -> do + logLine $ "Sending response for: " <> T.pack (show (getMessageSummary message)) + sendMessage responseMsg + Nothing -> + logLine $ "No response needed for: " <> T.pack (show (getMessageSummary message)) + handleParsed message = case message of -- subscriptions/listen is transport-level: the stream outlives the -- request. Only intercept when a source is configured and the @@ -147,15 +183,33 @@ transportRunStdioWithConfig config serverInfo handlers = do , maybe True (`elem` modernVersions) (metaProtocolVersion (requestParams req)) -> openSubscription src req - -- notifications/cancelled referencing an open subscription tears it - -- down (no response, per the cancellation rules) + -- Every other request runs in its own task so a later + -- notifications/cancelled can interrupt it while the read loop keeps + -- serving. The task is registered before its body starts (the gate) + -- so cancellation can never race registration; it deregisters itself + -- on any exit, including cancellation. + | otherwise -> do + let rid = requestId req + gate <- newEmptyMVar + task <- async $ do + takeMVar gate + dispatchMessage message + `finally` modifyMVar_ inflightVar (pure . filter ((/= rid) . fst)) + modifyMVar_ inflightVar (pure . ((rid, task) :)) + putMVar gate () + + -- notifications/cancelled tears down the referenced subscription or + -- in-flight request (no response either way, per the cancellation + -- rules; unknown ids are ignored as the spec requires) JsonRpcMessageNotification notif | notificationMethod notif == "notifications/cancelled" , Just cancelledId <- cancelledRequestId (notificationParams notif) -> do wasSub <- cancelSubscription cancelledId - unless wasSub $ - logLine $ "Ignoring cancellation for unknown request " <> T.pack (show cancelledId) + unless wasSub $ do + wasInflight <- cancelInflight cancelledId + unless wasInflight $ + logLine $ "Ignoring cancellation for unknown request " <> T.pack (show cancelledId) _ -> do -- The client's initialized notification is the legacy ready signal: @@ -167,20 +221,14 @@ transportRunStdioWithConfig config serverInfo handlers = do | notificationMethod n == "notifications/initialized" -> writeIORef legacyReady True _ -> pure () - -- Request-scoped notifications (progress, client logs) share the - -- locked stdout channel, interleaved before the response - response <- handleMcpMessage serverInfo (stdioCacheHints config) notifSupport sendNotification handlers anonymousContext message - case response of - Just responseMsg -> do - logLine $ "Sending response for: " <> T.pack (show (getMessageSummary message)) - sendMessage responseMsg - Nothing -> - logLine $ "No response needed for: " <> T.pack (show (getMessageSummary message)) + dispatchMessage message loop = do eof <- hIsEOF stdin if eof then do + inflight <- readMVar inflightVar + mapM_ (cancel . snd) inflight closeAllSubscriptions logLine "stdin closed - shutting down" else do diff --git a/test/HspecMain.hs b/test/HspecMain.hs index 4afbd9f..2675d6a 100644 --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -7,6 +7,7 @@ import qualified Spec.JSONConversion import qualified Spec.BasicDerivation import qualified Spec.SchemaValidation import qualified Spec.AdvancedDerivation +import qualified Spec.Cancellation import qualified Spec.UnicodeHandling import qualified Spec.DefinitionMetadata import qualified Spec.DerivedOutput @@ -26,6 +27,7 @@ main = hspec $ do Spec.BasicDerivation.spec Spec.SchemaValidation.spec Spec.AdvancedDerivation.spec + Spec.Cancellation.spec Spec.UnicodeHandling.spec Spec.DefinitionMetadata.spec Spec.DerivedOutput.spec diff --git a/test/Spec/Cancellation.hs b/test/Spec/Cancellation.hs new file mode 100644 index 0000000..d896668 --- /dev/null +++ b/test/Spec/Cancellation.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Coverage for the cancellation contract (ADR 0008): a request task +-- cancelled mid-handler stops emitting, never produces a response, and +-- releases bracket-acquired resources. The transports build on exactly +-- this shape (an 'async' around 'handleMcpMessage' that 'cancel' +-- interrupts), so the properties verified here are the ones the wire +-- behavior depends on. +module Spec.Cancellation (spec) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async, cancel, waitCatch) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (bracket_) +import Data.Aeson +import Data.IORef +import Data.Text (Text) +import MCP.Server +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import Test.Hspec + +-- A slow tools/call carrying a progressToken (so emissions are live), +-- driven from an async that the test cancels once the handler signals +-- it has started. +runCancelled :: (ClientContext -> IO ()) -> IO [JsonRpcNotification] +runCancelled handlerBody = do + sink <- newIORef [] + started <- newEmptyMVar + responded <- newIORef False + let handlers = noHandlers + { tools = Just + ( \_ -> pure [] + , \ctx _ _ -> do + reportProgress ctx 0 (Just 1) Nothing + putMVar started () + handlerBody ctx + pure $ Right $ toToolResult ("done" :: Text) + ) + } + params = object + [ "name" .= ("slow" :: Text) + , "arguments" .= object [] + , "_meta" .= object ["progressToken" .= ("t" :: Text)] + ] + task <- async $ do + resp <- handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints + noNotificationSupport (\n -> modifyIORef' sink (++ [n])) + handlers anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 1) "tools/call" (Just params))) + case resp of + Just _ -> writeIORef responded True + Nothing -> pure () + takeMVar started + cancel task -- waits for the task to finish + _ <- waitCatch task + readIORef responded `shouldReturn` False + readIORef sink + +spec :: Spec +spec = describe "Cancellation contract" $ do + + it "a cancelled handler stops emitting and never yields a response" $ do + lateEmit <- newIORef False + ns <- runCancelled $ \ctx -> do + threadDelay 5000000 + writeIORef lateEmit True + reportProgress ctx 1 (Just 1) Nothing + -- only the pre-cancellation progress made it out + map notificationMethod ns `shouldBe` ["notifications/progress"] + readIORef lateEmit `shouldReturn` False + + it "bracket releases handler resources on cancellation" $ do + acquired <- newIORef False + released <- newIORef False + _ <- runCancelled $ \_ -> + bracket_ (writeIORef acquired True) (writeIORef released True) $ + threadDelay 5000000 + readIORef acquired `shouldReturn` True + readIORef released `shouldReturn` True From 811cf6ba2e2908de5d6bc0ce53fac5cc20348865 Mon Sep 17 00:00:00 2001 From: tom Date: Sat, 1 Aug 2026 11:47:12 +0200 Subject: [PATCH 2/3] Sync ADR index statuses for landed 0005-0007 --- specs/README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/specs/README.md b/specs/README.md index 904d78a..cbd2c34 100644 --- a/specs/README.md +++ b/specs/README.md @@ -41,9 +41,9 @@ Filename `ADR_XXXX_short_slug.md`, numbered sequentially. Body: | [0002](ADR_0002_support_parameter_types.md) | Support for better parameter types | Historical | | [0003](ADR_0003_test_improvements.md) | Test suite improvements | Historical | | [0004](ADR_0004_upgrade_to_2025-06-18.md) | Upgrade to protocol 2025-06-18 | Historical | -| [0005](ADR_0005_derived_output_schemas.md) | Derived output schemas and structured content | Proposed | -| [0006](ADR_0006_definition_metadata.md) | Tool annotations, icons, content annotations | Proposed | -| [0007](ADR_0007_progress_notifications.md) | Progress notifications and per-request SSE | Proposed | +| [0005](ADR_0005_derived_output_schemas.md) | Derived output schemas and structured content | Landed (0.2.0.1) | +| [0006](ADR_0006_definition_metadata.md) | Tool annotations, icons, content annotations | Landed (0.2.0.1) | +| [0007](ADR_0007_progress_notifications.md) | Progress notifications and per-request SSE | Landed (0.2.0.1) | | [0008](ADR_0008_request_cancellation.md) | Cancellation of in-flight requests | Landed (0.2.0.1) | | [0009](ADR_0009_mrtr_input_required.md) | MRTR: input_required results (elicitation) | Proposed | | [0010](ADR_0010_oauth_resource_metadata.md) | OAuth protected-resource metadata | Proposed | From 6cc8355cb1f0ae785ce91b8069272bcb3600b3a0 Mon Sep 17 00:00:00 2001 From: tom Date: Sat, 1 Aug 2026 11:48:25 +0200 Subject: [PATCH 3/3] Address review: document concurrent stdio serving, correct single-JSON disconnect claim MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - README, stdio haddock, CHANGELOG: stdio requests are now served concurrently (previously strictly sequential) — handlers touching shared mutable state must synchronize, as already required with HTTP. Flagged as a behavioral break under 0.2.0.1. - HTTP haddock, README, CHANGELOG: single-JSON responses only detect a disconnect at the final write (the handler runs to completion first), so mid-handler cancellation applies to streaming requests; clients wanting cancellable calls should opt into streaming via a progressToken. --- CHANGELOG.md | 13 +++++++++---- README.md | 12 ++++++++++-- src/MCP/Server/Transport/Http.hs | 12 ++++++++---- src/MCP/Server/Transport/Stdio.hs | 5 +++++ 4 files changed, 32 insertions(+), 10 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 47a9731..fb51133 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,10 +15,15 @@ explicitly pinning the deprecated 0.2.0.0 should move here. The unreleased and `notifications/cancelled` cancels the referenced one (unknown or completed ids are ignored); on HTTP, closing an SSE response stream cancels the running handler (detected within one keep-alive interval, - now 5s), and Warp already tears down single-JSON request threads on - disconnect. Cancellation is delivered as an asynchronous exception, so - handlers acquiring resources should use `bracket` — documented in the - README. New dependency: `async`. + now 5s). Single-JSON HTTP responses only detect a disconnect at the + final write, so clients wanting cancellable calls should opt into + streaming via a `progressToken`. Cancellation is delivered as an + asynchronous exception, so handlers acquiring resources should use + `bracket` — documented in the README. BREAKING (behavioral): stdio + requests are now served concurrently rather than strictly + sequentially — handlers touching shared mutable state must + synchronize, as was already required with the HTTP transport. New + dependency: `async`. * Progress notifications and per-request SSE (ADR 0007): handlers can call `reportProgress` and `logToClient` on the `ClientContext` — both safe unconditionally. `reportProgress` emits `notifications/progress` diff --git a/README.md b/README.md index 9c5fcac..949318b 100644 --- a/README.md +++ b/README.md @@ -353,8 +353,16 @@ work as soon as practical and sends nothing further for that request: are ignored, as required). - **HTTP**: closing the response stream is the cancellation signal. For SSE responses the handler is cancelled as soon as the disconnect is detected - (within one keep-alive interval); for single-JSON responses Warp tears the - request thread down on disconnect. + (within one keep-alive interval). For single-JSON responses a disconnect + is only detected at the final write — the handler runs to completion + first — so mid-handler cancellation applies to streaming requests: + clients wanting cancellable calls should opt into streaming via a + `progressToken`. + +A consequence of cancellable requests: **requests are now served +concurrently on both transports** (stdio previously processed them strictly +sequentially). Handlers touching shared mutable state must synchronize +(`MVar`, `STM`, ...) — as was already required for HTTP servers. Cancellation is delivered to handler code as an asynchronous exception (the standard GHC mechanism, as used by `timeout` and `cancel`). Handlers are diff --git a/src/MCP/Server/Transport/Http.hs b/src/MCP/Server/Transport/Http.hs index 37787c1..7738ea3 100644 --- a/src/MCP/Server/Transport/Http.hs +++ b/src/MCP/Server/Transport/Http.hs @@ -129,10 +129,14 @@ sseHeaders = -- -- A client closing the connection is its cancellation signal: for SSE -- responses the handler task is cancelled once the disconnect surfaces (at --- most one keep-alive interval later), and for single-JSON responses Warp --- tears the request thread down. Cancellation reaches handler code as an --- asynchronous exception: handlers that acquire resources should release --- them with 'Control.Exception.bracket'. +-- most one keep-alive interval later — the periodic keep-alive write is +-- what detects it). For single-JSON responses nothing is written until the +-- handler finishes, so a disconnect is only detected — and the request +-- thread only torn down — at the final write: mid-handler cancellation +-- applies to streaming requests, and clients wanting cancellable calls +-- should opt into streaming via a @progressToken@. Cancellation reaches +-- handler code as an asynchronous exception: handlers that acquire +-- resources should release them with 'Control.Exception.bracket'. transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers -> IO () transportRunHttp config serverInfo handlers = do let settings = Warp.setHost (fromString $ httpHost config) $ diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs index 6263e6c..915b20f 100644 --- a/src/MCP/Server/Transport/Stdio.hs +++ b/src/MCP/Server/Transport/Stdio.hs @@ -70,6 +70,11 @@ transportRunStdio = transportRunStdioWithConfig defaultStdioConfig -- written for that id). Cancellation reaches handler code as an -- asynchronous exception: handlers that acquire resources should release -- them with 'Control.Exception.bracket'. +-- +-- This also means requests run /concurrently/ (before 0.2.0.1 the stdio +-- transport processed them strictly sequentially): handlers touching +-- shared mutable state must synchronize, as was already required of +-- handlers used with the HTTP transport. transportRunStdioWithConfig :: StdioConfig -> McpServerInfo -> McpServerHandlers -> IO () transportRunStdioWithConfig config serverInfo handlers = do -- Ensure UTF-8 encoding for all handles