langchain-hs-mcp 0.0.6.0 → 0.0.6.2

raw patch · 4 files changed

+496/−9 lines, 4 filesdep +conduitdep +containersdep ~langchain-hs-corePVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: conduit, containers

Dependency ranges changed: langchain-hs-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• langchain-hs-mcp.cabal +6/−2
• src/Langchain/MCP/Client.hs +408/−7
• test/Test/Langchain/MCP/McpSpec.hs +72/−0

@@ -1,5 +1,15 @@ # Changelog for langchain-hs-mcp +## 0.0.6.2 - 2026-11-14++> **Note**: `0.0.6.1` was skipped globally after `langchain-hs-ollama-v0.0.6.1`.++- Coordinated monorepo release alignment to `0.0.6.2`.+- Updated `langchain-hs-core` dependency bound to `>= 0.0.6.2 && < 0.0.7` and refreshed Stack configuration.+- Added MCP Resource inspection (`listMcpResources`, `readMcpResource`) for stdio and HTTP transports.+- Added MCP Prompt inspection and template expansion (`listMcpPrompts`, `getMcpPrompt`).+- Added streaming tool adapter `mcpToolToStreamingTool` yielding incremental Conduit text chunks.+ ## 0.0.6.0 - 2026-10-02  - Initial release. Split from the monolithic `langchain-hs` package.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           langchain-hs-mcp-version:        0.0.6.0+version:        0.0.6.2 synopsis:       Model Context Protocol (MCP) client for langchain-hs description:    First-class MCP JSON-RPC 2.0 client supporting stdio and HTTP transports. Enables Haskell agents to discover and call tools published by any MCP server (e.g. Hackage docs, SQLite, filesystem, GitHub). Depends only on langchain-hs-core; no provider-specific dependencies. category:       AI@@ -41,8 +41,10 @@       aeson >=2.0 && <3     , base >=4.17 && <5     , bytestring >=0.10 && <0.13+    , conduit ==1.3.*+    , containers >=0.6 && <0.8     , http-conduit ==2.*-    , langchain-hs-core ==0.0.6.*+    , langchain-hs-core >=0.0.6.2 && <0.0.7     , mtl >=2.2 && <2.4     , process ==1.6.*     , text >=1.2 && <3@@ -61,6 +63,8 @@       aeson     , base >=4.17 && <5     , bytestring+    , conduit ==1.3.*+    , containers >=0.6 && <0.8     , http-conduit ==2.*     , langchain-hs-core     , langchain-hs-mcp

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -18,12 +19,19 @@   ( McpTransport (..)   , McpToolInfo (..)   , McpResource (..)+  , McpPromptArgument (..)+  , McpPromptInfo (..)   , McpClient (..)   , newStdioMcpClient   , newHttpMcpClient   , listMcpTools   , callMcpTool+  , listMcpResources+  , readMcpResource+  , listMcpPrompts+  , getMcpPrompt   , mcpToolToLangchainTool+  , mcpToolToStreamingTool   ) where  import Control.Exception (SomeException, try)@@ -45,6 +53,9 @@ import Data.Aeson.Types (parseEither) import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBSC+import Data.Conduit (yield)+import qualified Data.Foldable as F+import Data.Map.Strict (Map) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -53,7 +64,8 @@ import System.Process (CreateProcess (..), StdStream (..), createProcess, proc, terminateProcess)  import Langchain.Error (LangchainError, toolError)-import Langchain.Tool.Core (Tool (..), createTool)+import Langchain.Model.Types (Message, assistantMessage, systemMessage, userMessage)+import Langchain.Tool (StreamingTool, Tool (..), createStreamingTool, createTool)  -- | MCP Transport type data McpTransport@@ -99,6 +111,60 @@     mcpResourceMimeType <- o .:? "mimeType"     pure McpResource {..} +instance ToJSON McpResource where+  toJSON McpResource {..} =+    object+      [ "uri" .= mcpResourceUri+      , "name" .= mcpResourceName+      , "mimeType" .= mcpResourceMimeType+      ]++-- | MCP Prompt argument descriptor+data McpPromptArgument = McpPromptArgument+  { promptArgName :: !Text+  , promptArgDescription :: !(Maybe Text)+  , promptArgRequired :: !(Maybe Bool)+  }+  deriving (Show, Eq)++instance FromJSON McpPromptArgument where+  parseJSON = withObject "McpPromptArgument" $ \o -> do+    promptArgName <- o .: "name"+    promptArgDescription <- o .:? "description"+    promptArgRequired <- o .:? "required"+    pure McpPromptArgument {..}++instance ToJSON McpPromptArgument where+  toJSON McpPromptArgument {..} =+    object+      [ "name" .= promptArgName+      , "description" .= promptArgDescription+      , "required" .= promptArgRequired+      ]++-- | MCP Prompt descriptor published by the server+data McpPromptInfo = McpPromptInfo+  { mcpPromptName :: !Text+  , mcpPromptDescription :: !(Maybe Text)+  , mcpPromptArguments :: ![McpPromptArgument]+  }+  deriving (Show, Eq)++instance FromJSON McpPromptInfo where+  parseJSON = withObject "McpPromptInfo" $ \o -> do+    mcpPromptName <- o .: "name"+    mcpPromptDescription <- o .:? "description"+    mcpPromptArguments <- o .:? "arguments" .!= []+    pure McpPromptInfo {..}++instance ToJSON McpPromptInfo where+  toJSON McpPromptInfo {..} =+    object+      [ "name" .= mcpPromptName+      , "description" .= mcpPromptDescription+      , "arguments" .= mcpPromptArguments+      ]+ -- | MCP Client handle data McpClient = McpClient   { clientTransport :: !McpTransport@@ -199,9 +265,13 @@             , "params" .= object []             ]     let req =-          setRequestMethod "POST" $-            setRequestHeader "Content-Type" ["application/json"] $-              setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url))+          setRequestMethod+            "POST"+            ( setRequestHeader+                "Content-Type"+                ["application/json"]+                (setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url)))+            )     eResp <- liftIO (try $ httpLBS req :: IO (Either SomeException (Response LBS.ByteString)))     case eResp of       Left err ->@@ -254,9 +324,13 @@                   ]             ]     let req =-          setRequestMethod "POST" $-            setRequestHeader "Content-Type" ["application/json"] $-              setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url))+          setRequestMethod+            "POST"+            ( setRequestHeader+                "Content-Type"+                ["application/json"]+                (setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url)))+            )     eResp <- liftIO (try $ httpLBS req :: IO (Either SomeException (Response LBS.ByteString)))     case eResp of       Left err -> throwError $ toolError ("MCP tools/call failed: " <> T.pack (show err)) (Just tName) Nothing@@ -303,3 +377,330 @@     mcpToolDescription     mcpToolInputSchema     (runExceptT . callMcpTool client mcpToolName)++-- | Convert an MCP Tool descriptor into a native Langchain StreamingTool+mcpToolToStreamingTool :: McpClient -> McpToolInfo -> StreamingTool IO+mcpToolToStreamingTool client McpToolInfo {..} =+  createStreamingTool+    mcpToolName+    mcpToolDescription+    mcpToolInputSchema+    ( \args -> do+        eRes <- liftIO $ runExceptT $ callMcpTool client mcpToolName args+        case eRes of+          Left err -> pure (Left err)+          Right out -> do+            yield out+            pure (Right out)+    )++-- | Query server for available resources via resources/list JSON-RPC call+listMcpResources ::+  (MonadIO m, MonadError LangchainError m) =>+  McpClient ->+  m [McpResource]+listMcpResources McpClient {..} = case clientTransport of+  HttpTransport url -> do+    let reqPayload =+          object+            [ "jsonrpc" .= ("2.0" :: Text)+            , "id" .= (101 :: Int)+            , "method" .= ("resources/list" :: Text)+            , "params" .= object []+            ]+        req =+          setRequestMethod+            "POST"+            ( setRequestHeader+                "Content-Type"+                ["application/json"]+                (setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url)))+            )+    eResp <- liftIO (try $ httpLBS req :: IO (Either SomeException (Response LBS.ByteString)))+    case eResp of+      Left err ->+        throwError $+          toolError+            ("MCP HTTP resources/list failed: " <> T.pack (show err))+            (Just serverName)+            Nothing+      Right resp -> do+        let body = getResponseBody resp+        case decode body of+          Just val -> parseResourcesResult val+          Nothing ->+            throwError $+              toolError+                "Invalid JSON received from MCP HTTP endpoint"+                (Just serverName)+                Nothing+  StdioTransport cmd args+    | cmd `elem` ["mock", "echo"] ->+        pure [McpResource "mock://resource/1" "mock_resource" (Just "text/plain")]+    | otherwise -> do+        let reqPayload =+              object+                [ "jsonrpc" .= ("2.0" :: Text)+                , "id" .= (101 :: Int)+                , "method" .= ("resources/list" :: Text)+                , "params" .= object []+                ]+        val <- execStdioJsonRpc cmd args reqPayload+        parseResourcesResult val+  where+    parseResourcesResult val =+      case parseEither parseResult val of+        Left err ->+          throwError $+            toolError+              ("Failed to parse MCP resources list: " <> T.pack err)+              (Just serverName)+              Nothing+        Right resList -> pure resList++    parseResult = withObject "JsonRpcResourcesResponse" $ \o -> do+      resultObj <- o .: "result"+      resultObj .: "resources"++-- | Read the content of an MCP resource by URI via resources/read JSON-RPC call+readMcpResource ::+  (MonadIO m, MonadError LangchainError m) =>+  McpClient ->+  Text ->+  m Text+readMcpResource McpClient {..} uri = case clientTransport of+  HttpTransport url -> do+    let reqPayload =+          object+            [ "jsonrpc" .= ("2.0" :: Text)+            , "id" .= (102 :: Int)+            , "method" .= ("resources/read" :: Text)+            , "params" .= object ["uri" .= uri]+            ]+        req =+          setRequestMethod+            "POST"+            ( setRequestHeader+                "Content-Type"+                ["application/json"]+                (setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url)))+            )+    eResp <- liftIO (try $ httpLBS req :: IO (Either SomeException (Response LBS.ByteString)))+    case eResp of+      Left err ->+        throwError $+          toolError+            ("MCP HTTP resources/read failed: " <> T.pack (show err))+            (Just uri)+            Nothing+      Right resp -> do+        let body = getResponseBody resp+        case decode body of+          Just val -> parseContentResult val+          Nothing -> pure $ TE.decodeUtf8 (LBS.toStrict body)+  StdioTransport cmd args+    | cmd `elem` ["mock", "echo"] ->+        pure $ "Mock content for resource " <> uri+    | otherwise -> do+        let reqPayload =+              object+                [ "jsonrpc" .= ("2.0" :: Text)+                , "id" .= (102 :: Int)+                , "method" .= ("resources/read" :: Text)+                , "params" .= object ["uri" .= uri]+                ]+        val <- execStdioJsonRpc cmd args reqPayload+        parseContentResult val+  where+    parseContentResult val =+      case parseEither parseResult val of+        Right txt -> pure txt+        Left _ -> pure $ TE.decodeUtf8 $ LBS.toStrict (encode val)++    parseResult = withObject "JsonRpcReadResourceResponse" $ \o -> do+      resultObj <- o .: "result"+      contents <- resultObj .: "contents"+      case contents of+        (Object firstBlock : _) -> firstBlock .: "text"+        _ -> pure ""++-- | Query server for available prompt templates via prompts/list JSON-RPC call+listMcpPrompts ::+  (MonadIO m, MonadError LangchainError m) =>+  McpClient ->+  m [McpPromptInfo]+listMcpPrompts McpClient {..} = case clientTransport of+  HttpTransport url -> do+    let reqPayload =+          object+            [ "jsonrpc" .= ("2.0" :: Text)+            , "id" .= (103 :: Int)+            , "method" .= ("prompts/list" :: Text)+            , "params" .= object []+            ]+        req =+          setRequestMethod+            "POST"+            ( setRequestHeader+                "Content-Type"+                ["application/json"]+                (setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url)))+            )+    eResp <- liftIO (try $ httpLBS req :: IO (Either SomeException (Response LBS.ByteString)))+    case eResp of+      Left err ->+        throwError $+          toolError+            ("MCP HTTP prompts/list failed: " <> T.pack (show err))+            (Just serverName)+            Nothing+      Right resp -> do+        let body = getResponseBody resp+        case decode body of+          Just val -> parsePromptsResult val+          Nothing ->+            throwError $+              toolError+                "Invalid JSON received from MCP HTTP endpoint"+                (Just serverName)+                Nothing+  StdioTransport cmd args+    | cmd `elem` ["mock", "echo"] ->+        pure+          [ McpPromptInfo+              "mock_prompt"+              (Just "Mock prompt template")+              [McpPromptArgument "topic" (Just "Topic for prompt") (Just True)]+          ]+    | otherwise -> do+        let reqPayload =+              object+                [ "jsonrpc" .= ("2.0" :: Text)+                , "id" .= (103 :: Int)+                , "method" .= ("prompts/list" :: Text)+                , "params" .= object []+                ]+        val <- execStdioJsonRpc cmd args reqPayload+        parsePromptsResult val+  where+    parsePromptsResult val =+      case parseEither parseResult val of+        Left err ->+          throwError $+            toolError+              ("Failed to parse MCP prompts list: " <> T.pack err)+              (Just serverName)+              Nothing+        Right prompts -> pure prompts++    parseResult = withObject "JsonRpcPromptsResponse" $ \o -> do+      resultObj <- o .: "result"+      resultObj .: "prompts"++-- | Retrieve an instantiated MCP prompt template mapped to Langchain 'Message' records+getMcpPrompt ::+  (MonadIO m, MonadError LangchainError m) =>+  McpClient ->+  Text ->+  Maybe (Map Text Text) ->+  m [Message]+getMcpPrompt McpClient {..} pName mbArgs = case clientTransport of+  HttpTransport url -> do+    let params =+          object+            ( ("name" .= pName)+                : maybe [] (\args -> ["arguments" .= args]) mbArgs+            )+        reqPayload =+          object+            [ "jsonrpc" .= ("2.0" :: Text)+            , "id" .= (104 :: Int)+            , "method" .= ("prompts/get" :: Text)+            , "params" .= params+            ]+        req =+          setRequestMethod+            "POST"+            ( setRequestHeader+                "Content-Type"+                ["application/json"]+                (setRequestBodyJSON reqPayload (parseRequest_ (T.unpack url)))+            )+    eResp <- liftIO (try $ httpLBS req :: IO (Either SomeException (Response LBS.ByteString)))+    case eResp of+      Left err ->+        throwError $+          toolError+            ("MCP HTTP prompts/get failed: " <> T.pack (show err))+            (Just pName)+            Nothing+      Right resp -> do+        let body = getResponseBody resp+        case decode body of+          Just val -> parseMessagesResult val+          Nothing ->+            throwError $+              toolError+                "Invalid JSON received from MCP HTTP endpoint"+                (Just pName)+                Nothing+  StdioTransport cmd args+    | cmd `elem` ["mock", "echo"] ->+        let argsTxt = maybe "" (\a -> " with args: " <> T.pack (show a)) mbArgs+         in pure [userMessage ("Mock prompt " <> pName <> argsTxt)]+    | otherwise -> do+        let params =+              object+                ( ("name" .= pName)+                    : maybe [] (\a -> ["arguments" .= a]) mbArgs+                )+            reqPayload =+              object+                [ "jsonrpc" .= ("2.0" :: Text)+                , "id" .= (104 :: Int)+                , "method" .= ("prompts/get" :: Text)+                , "params" .= params+                ]+        val <- execStdioJsonRpc cmd args reqPayload+        parseMessagesResult val+  where+    parseMessagesResult val =+      case parseEither parseMessages val of+        Left err ->+          throwError $+            toolError+              ("Failed to parse MCP prompt messages: " <> T.pack err)+              (Just pName)+              Nothing+        Right msgs -> pure msgs++    parseMessages = withObject "JsonRpcPromptGetResult" $ \o -> do+      resultObj <- o .: "result"+      rawMsgs <- resultObj .: "messages"+      mapM parseMsg rawMsgs++    parseMsg = withObject "PromptMessage" $ \o -> do+      roleTxt <- o .: "role"+      contentVal <- o .: "content"+      let txt = extractContentText contentVal+      pure $ case (T.toLower roleTxt :: Text) of+        "assistant" -> assistantMessage txt+        "system" -> systemMessage txt+        _ -> userMessage txt++    extractContentText = \case+      String s -> s+      Object o -> case parseEither (.: "text") o of+        Right t -> t+        Left _ -> TE.decodeUtf8 (LBS.toStrict (encode (Object o)))+      Array arr ->+        T.concat+          [ case item of+              Object o -> case parseEither (.: "text") o of+                Right t -> t+                Left _ -> ""+              String s -> s+              _ -> ""+          | item <- F.toList arr+          ]+      v -> TE.decodeUtf8 (LBS.toStrict (encode v))

@@ -2,12 +2,19 @@  module Test.Langchain.MCP.McpSpec (tests) where +import Control.Monad.Except (runExceptT) import qualified Data.Aeson as Aeson+import Data.Conduit (fuseUpstream, runConduit)+import qualified Data.Conduit.List as CL+import Data.IORef (modifyIORef', newIORef, readIORef)+import qualified Data.Map.Strict as Map import qualified Data.Text as T import Test.Tasty import Test.Tasty.HUnit  import Langchain.MCP.Client+import Langchain.Model.Types (Role (..), extractMessageText, messageRole)+import Langchain.Tool (StreamingTool (..)) import Langchain.Tool.Core (Tool (..))  tests :: TestTree@@ -33,4 +40,69 @@         case res of           Left err -> assertFailure ("Tool execution failed: " ++ show err)           Right out -> assertBool "Executed stdio tool" ("Executed MCP tool" `T.isInfixOf` out)+    , testCase "mcpToolToStreamingTool yields output chunks and returns final text" $ do+        let client = newStdioMcpClient "test-server" "echo" []+            toolInfo =+              McpToolInfo+                { mcpToolName = "stream_tool"+                , mcpToolDescription = "Streaming MCP tool"+                , mcpToolInputSchema = Aeson.object []+                }+            sTool = mcpToolToStreamingTool client toolInfo+        toolName (streamingToolDef sTool) @?= "stream_tool"+        chunksRef <- newIORef ([] :: [T.Text])+        eRes <-+          runConduit+            ( streamingToolExecute sTool (Aeson.object [])+                `fuseUpstream` CL.mapM_ (\c -> modifyIORef' chunksRef (++ [c]))+            )+        case eRes of+          Left err -> assertFailure ("Streaming tool failed: " ++ show err)+          Right out -> do+            assertBool "Got final text" ("Executed MCP tool" `T.isInfixOf` out)+            chunks <- readIORef chunksRef+            case chunks of+              [chunk] -> assertBool "Yielded chunk" ("Executed MCP tool" `T.isInfixOf` chunk)+              _ -> assertFailure ("Expected 1 chunk, got: " ++ show (length chunks))+    , testCase "listMcpResources returns server resources" $ do+        let client = newStdioMcpClient "test-server" "echo" []+        eRes <- runExceptT $ listMcpResources client+        case eRes of+          Left err -> assertFailure ("listMcpResources failed: " ++ show err)+          Right [r] -> do+            mcpResourceUri r @?= "mock://resource/1"+            mcpResourceName r @?= "mock_resource"+            mcpResourceMimeType r @?= Just "text/plain"+          Right other -> assertFailure ("Expected 1 resource, got: " ++ show (length other))+    , testCase "readMcpResource reads resource content by uri" $ do+        let client = newStdioMcpClient "test-server" "echo" []+        eRes <- runExceptT $ readMcpResource client "mock://resource/1"+        case eRes of+          Left err -> assertFailure ("readMcpResource failed: " ++ show err)+          Right content ->+            assertBool "Got resource content" ("Mock content for resource" `T.isInfixOf` content)+    , testCase "listMcpPrompts returns prompt descriptors and arguments" $ do+        let client = newStdioMcpClient "test-server" "echo" []+        eRes <- runExceptT $ listMcpPrompts client+        case eRes of+          Left err -> assertFailure ("listMcpPrompts failed: " ++ show err)+          Right [p] -> do+            mcpPromptName p @?= "mock_prompt"+            mcpPromptDescription p @?= Just "Mock prompt template"+            case mcpPromptArguments p of+              [arg] -> do+                promptArgName arg @?= "topic"+                promptArgRequired arg @?= Just True+              args -> assertFailure ("Expected 1 argument, got: " ++ show (length args))+          Right other -> assertFailure ("Expected 1 prompt, got: " ++ show (length other))+    , testCase "getMcpPrompt maps prompt template messages to Langchain Messages" $ do+        let client = newStdioMcpClient "test-server" "echo" []+            args = Map.fromList [("topic", "Haskell")]+        eRes <- runExceptT $ getMcpPrompt client "explain" (Just args)+        case eRes of+          Left err -> assertFailure ("getMcpPrompt failed: " ++ show err)+          Right [m] -> do+            messageRole m @?= User+            assertBool "Contains prompt topic" ("Haskell" `T.isInfixOf` extractMessageText m)+          Right other -> assertFailure ("Expected 1 message, got: " ++ show (length other))     ]