Request cancellation for in-flight requests (ADR 0008)

CHANGELOG.md

@@ -9,6 +9,21 @@ 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). 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`

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

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,

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
 

specs/README.md

@@ -41,10 +41,10 @@ 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 |
-| [0008](ADR_0008_request_cancellation.md) | Cancellation of in-flight requests | 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 |
 | [0011](ADR_0011_protocol_completeness.md) | Pagination and the extensions capability | Proposed |

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,17 @@ 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 — 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) $
@@ -445,12 +460,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 +488,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

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,39 @@ 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'.
+--
+-- 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
   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 +155,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 +188,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 +226,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

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