mcp 0.3.1.0 → 0.3.2.0

raw patch · 8 files changed

+99/−16 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• mcp.cabal +1/−1
• src/MCP/Server/Common.hs +26/−1
• src/MCP/Server/HTTP/Internal.hs +20/−12
• test/MCP/Integration.hs +12/−1
• test/MCP/SimpleHTTPIntegration.hs +1/−0
• test/MCP/StdioIntegration.hs +2/−1
• test/MCP/TestServer.hs +31/−0

@@ -1,5 +1,11 @@ # Changelog +## 0.3.2.0++### Fixed+- Use the authenticated user from each HTTP request when processing JWT-authenticated+  MCP requests.+ ## 0.3.1.0  ### Added

@@ -1,6 +1,6 @@ cabal-version: 2.2 name: mcp-version: 0.3.1.0+version: 0.3.2.0 license: MPL-2.0 license-file: LICENSE copyright: (c) 2025 DPella AB

@@ -38,6 +38,9 @@     MCPServerState (..),     initMCPServerState, +    -- * Per-request authentication+    getCurrentUser,+     -- * Type families     MCPHandlerState,     MCPHandlerUser,@@ -300,8 +303,24 @@     ProcessHandlers ->     MCPServerState initMCPServerState init_state handler_init handler_finalize =-    MCPServerState False init_state handler_init handler_finalize Nothing (Just Warning) IM.empty 0+    MCPServerState False init_state Nothing handler_init handler_finalize Nothing (Just Warning) IM.empty 0 +{- | Read the authenticated user associated with the request currently being+processed.++This reflects the @servant-auth@ result attached to the in-flight HTTP request+(JWT transport) and is set per request before each handler runs.  It is the+recommended way to derive identity inside a handler, unlike the one-shot+'mcp_handler_init' hook, which only fires on the first @initialize@ call to+the server-process-wide singleton state and is unsafe for multi-tenant+deployments.++Returns 'Nothing' under transports that do not perform per-request auth+(stdio, @simpleHttpApp@).+-}+getCurrentUser :: MCPServerT (Maybe MCPHandlerUser)+getCurrentUser = gets mcp_current_user+ {- | Type family used to configure the handler state threaded through 'MCPServerT'. Users must provide a type instance before using the MCP server, e.g. @type instance MCPHandlerState = MyState@.@@ -324,6 +343,12 @@     -- ^ Whether initialize has been called     , mcp_handler_state :: MCPHandlerState     -- ^ Current handler state for this session+    , mcp_current_user :: Maybe MCPHandlerUser+    -- ^ Authenticated user for the request currently being processed.  Set+    -- per request by the HTTP JWT transport before each handler runs and+    -- cleared afterward; always 'Nothing' under stdio and 'simpleHttpApp'.+    -- Prefer reading this via 'getCurrentUser' rather than touching the+    -- field directly.     , mcp_handler_init :: Maybe (MCPHandlerUser -> MCPHandlerState -> IO MCPHandlerState)     -- ^ Initialize the handler state on server initialization     , mcp_handler_finalize :: Maybe (MCPHandlerState -> IO MCPHandlerState)

@@ -11,9 +11,9 @@ 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'.+used by both 'MCP.Server.HTTP' (JWT) and 'MCP.Server.SimpleHTTP' (Bearer+token).  Transport modules handle authentication and then delegate to+'handleMCPRequestCore'. -} module MCP.Server.HTTP.Internal (     -- * SSE framing@@ -34,7 +34,6 @@ 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@@ -148,8 +147,12 @@                                                 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)+                -- Process the request routing to the appropriate handler.+                -- Set mcp_current_user while the handler runs, then clear it+                -- before releasing the shared state. Handlers read this via+                -- getCurrentUser.+                res <- liftIO $ modifyMVar state_var $+                    runWithCurrentUser (processMethod server_initialized method params)                  -- Log the response if debug level                 cur_log_level <- liftIO $ mcp_log_level <$> readMVar state_var@@ -214,13 +217,12 @@                     Yield msg $                         Effect $ do                             ci_resp <- liftIO $ takeMVar mvar-                            cur_st <- liftIO $ readMVar state_var-                            (result, cur_st') <-+                            result <-                                 liftIO $-                                    flip runStateT cur_st $-                                        runExceptT $-                                            ci_cont ci_resp-                            liftIO $ modifyMVar_ state_var $ \_ -> return cur_st'+                                    modifyMVar state_var $+                                        runWithCurrentUser $+                                            runExceptT $+                                                ci_cont ci_resp                             case result of                                 Left err -> do                                     return $ Source.Error $ T.unpack err@@ -231,3 +233,9 @@                     flip Yield Stop $                         ResponseMessage $                             JSONRPCResponse rPC_VERSION req_id (recurReplaceMeta $ toJSON response)++    runWithCurrentUser :: StateT MCPServerState IO a -> MCPServerState -> IO (MCPServerState, a)+    runWithCurrentUser action cur_st = do+        let cur_st_with_user = cur_st{mcp_current_user = mb_user}+        (result, final_st) <- runStateT action cur_st_with_user+        pure (final_st{mcp_current_user = Nothing}, result)

@@ -151,7 +151,7 @@     it "handles list/tools request successfully" $ do         withInitializedServer $ \headers -> do             let req_id = 2-            let expected_tools = ["addition-tool", "constant-msg-tool"]+            let expected_tools = ["addition-tool", "constant-msg-tool", "current-user-tool"]             let list_tool_req = toJSON $ createListToolsRequest req_id             -- the client sends the list tools request             resp_list_tool <- mcpPostRequest headers list_tool_req@@ -178,6 +178,17 @@             resp_call2 <- mcpPostRequest headers call_req2             withValidJSONRPCResponse resp_call2 req_id2 $                 validateToolCallResponse (toJSON ("Hello, World!" :: Text))++    it "uses the authenticated user from each request" $ do+        withInitializedServer $ \_headers -> do+            withAuthenticatedRequestForSession "second-user-id" $ \headers -> do+                let req_id = 11+                let call_req =+                        toJSON $+                            createCallToolRequest req_id "current-user-tool" []+                resp_call <- mcpPostRequest headers call_req+                withValidJSONRPCResponse resp_call req_id $+                    validateToolCallResponse (toJSON ("second-user-id" :: Text))      it "handles prompt/list requests successfully" $ do         withInitializedServer $ \headers -> do

@@ -78,6 +78,7 @@         MCPServerState             { mcp_server_initialized = False             , mcp_handler_state = initializeTestState+            , mcp_current_user = Nothing             , mcp_handler_init = Nothing -- no user type in SimpleHTTP             , mcp_handler_finalize = mb_handler_finalize             , mcp_client_capabilities = Nothing

@@ -67,6 +67,7 @@     MCPServerState         { mcp_server_initialized = False         , mcp_handler_state = initializeTestState+        , mcp_current_user = Nothing         , mcp_handler_init = Nothing -- No user in stdio mode         , mcp_handler_finalize = mb_handler_finalize         , mcp_client_capabilities = Nothing@@ -192,7 +193,7 @@             sendMsg h_write (toJSON $ createListToolsRequest 2)             (_, ListToolsResult{tools = ts}) <- recvTypedResponse h_read             let tool_names = fmap (\Tool{name = n} -> n) ts-            tool_names `shouldMatchList` ["addition-tool", "constant-msg-tool"]+            tool_names `shouldMatchList` ["addition-tool", "constant-msg-tool", "current-user-tool"]      it "calls the addition tool" $ do         withStdioServer $ \(h_read, h_write) -> do

@@ -184,6 +184,16 @@                 let ctx_result =                         TextBlock $ TextContent "text" ("This is a constant message: " <> t_result) Nothing Nothing                 return $ ProcessSuccess (CallToolResult [ctx_result] (Just result_value) Nothing Nothing)+            "current-user-tool" -> do+                mb_user <- getCurrentUser+                case mb_user of+                    Just user -> do+                        let t_result = userId user+                        let result_value = Map.fromList [("result", toJSON t_result)]+                        let ctx_result =+                                TextBlock $ TextContent "text" ("The current user is: " <> t_result) Nothing Nothing+                        return $ ProcessSuccess (CallToolResult [ctx_result] (Just result_value) Nothing Nothing)+                    Nothing -> return $ ProcessRPCError 401 "No authenticated user"             _ -> return $ ProcessRPCError 404 "Tool not found"      -- Example list prompts handler@@ -331,6 +341,26 @@         , annotations = Nothing         , _meta = Nothing         }+    , Tool+        { name = "current-user-tool"+        , title = Just "Current User Tool"+        , description = Just "Returns the authenticated request user"+        , inputSchema =+            InputSchema+                { schemaType = "object"+                , properties = Nothing+                , required = Nothing+                }+        , outputSchema =+            Just $+                InputSchema+                    { schemaType = "object"+                    , properties = Just (Map.fromList [("result", object ["type" .= ("string" :: Text)])])+                    , required = Just ["result"]+                    }+        , annotations = Nothing+        , _meta = Nothing+        }     ]  -- ** Available Prompts@@ -455,6 +485,7 @@         MCPServerState             { mcp_server_initialized = False             , mcp_handler_state = initializeTestState+            , mcp_current_user = Nothing             , mcp_handler_init = mb_handler_init             , mcp_handler_finalize = mb_handler_finalize             , mcp_client_capabilities = Nothing