mcp-server 0.1.0.10 → 0.1.0.11

raw patch · 10 files changed

+804/−355 lines, 10 filesdep +http-typesdep +vectordep +waidep ~basedep ~textnew-component:exe:http-simple-examplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-types, vector, wai, warp

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• README.md +34/−5
• examples/HttpSimple/Main.hs +43/−0
• examples/HttpSimple/Types.hs +18/−0
• mcp-server.cabal +29/−1
• src/MCP/Server.hs +22/−326
• src/MCP/Server/Handlers.hs +332/−0
• src/MCP/Server/Protocol.hs +22/−23
• src/MCP/Server/Transport/Http.hs +212/−0
• src/MCP/Server/Transport/Stdio.hs +59/−0
• src/MCP/Server/Transport/Types.hs +33/−0

@@ -4,11 +4,11 @@  ## Features -- **Complete MCP Implementation**: Designed against the MCP 2024-11-05 server specification+- **Complete MCP Implementation**: Supports MCP 2025-03-26 specification (with backward compatibility for 2024-11-05) - **Type-Safe API**: Leverage Haskell's type system for robust MCP servers - **Multiple Abstractions**: Both low-level fine-grained control and high-level derived interfaces - **Template Haskell Support**: Automatic handler derivation from data types-- **Stdio Transport Only**: HTTP/SSE coming soon!+- **Multiple Transports**: STDIO and HTTP Streaming transport (MCP 2025-03-26 Streamable HTTP)  ## Supported MCP Features @@ -141,12 +141,41 @@       } ``` +## HTTP Transport (NEW!)++The library now supports MCP 2025-03-26 Streamable HTTP transport:++```haskell+import MCP.Server.Transport.Http++-- Simple HTTP server (localhost:3000/mcp)+main = runMcpServerHttp serverInfo handlers++-- Custom configuration+main = runMcpServerHttpWithConfig customConfig serverInfo handlers+  where+    customConfig = HttpConfig+      { httpPort = 8080+      , httpHost = "0.0.0.0"+      , httpEndpoint = "/api/mcp"+      , httpVerbose = True  -- Enable detailed logging+      }+```++**Features:**+- JSON-RPC batching support+- CORS enabled for web clients  +- GET `/mcp` for server discovery+- POST `/mcp` for JSON-RPC messages+- Full MCP 2025-03-26 compliance+ ## Examples -The library includes a few different examples:+The library includes several examples: -- **`examples/Simple/`**: Basic key-value store using Template Haskell derivation-- **`examples/Complete/`**: Full-featured example with prompts, resources, and tools+- **`examples/Simple/`**: Basic key-value store using Template Haskell derivation (STDIO)+- **`examples/Complete/`**: Full-featured example with prompts, resources, and tools (STDIO)+- **`examples/HttpSimple/`**: HTTP version of the simple key-value store  ## Docker Usage 

@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Main where++import           Data.IORef+import           MCP.Server+import           MCP.Server.Derive+import           System.IO         (hPutStrLn, stderr)+import           Types++main :: IO ()+main = do+    hPutStrLn stderr "Starting HTTP Simple MCP Server..."++    -- Create a simple in-memory store+    store <- newIORef []++    let handleTool :: SimpleTool -> IO Content+        handleTool (GetValue k) = do+            pairs <- readIORef store+            case lookup k pairs of+                Nothing -> pure $ ContentText $ "Key '" <> k <> "' not found"+                Just v  -> pure $ ContentText v+        handleTool (SetValue k v) = do+            pairs <- readIORef store+            let newPairs = (k, v) : filter ((/= k) . fst) pairs+            writeIORef store newPairs+            pure $ ContentText $ "Set '" <> k <> "' to '" <> v <> "'"++    -- Derive the tool handlers using Template Haskell with descriptions+    let tools = $(deriveToolHandlerWithDescription ''SimpleTool 'handleTool simpleDescriptions)+     in runMcpServerHttp+        McpServerInfo+            { serverName = "HTTP Simple Key-Value MCP Server"+            , serverVersion = "1.0.0"+            , serverInstructions = "A simple HTTP key-value store with GetValue and SetValue tools"+            }+        McpServerHandlers+            { prompts = Nothing     -- No prompts in this example+            , resources = Nothing   -- No resources in this example+            , tools = Just tools    -- Only tools in this example+            }

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}++module Types where++import           Data.Text (Text)++data SimpleTool+    = GetValue { key :: Text }+    | SetValue { key :: Text, value :: Text }+    deriving (Show, Eq)++simpleDescriptions :: [(String, String)]+simpleDescriptions =+    [ ("GetValue", "Retrieve the value associated with the given key")+    , ("SetValue", "Set the value for the given key")+    , ("key", "The key to look up or set")+    , ("value", "The value to store")+    ]

@@ -15,7 +15,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.1.0.10+version: 0.1.0.11 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.@@ -63,9 +63,13 @@   exposed-modules:     MCP.Server     MCP.Server.Derive+    MCP.Server.Handlers     MCP.Server.JsonRpc     MCP.Server.Protocol     MCP.Server.Types+    MCP.Server.Transport.Types+    MCP.Server.Transport.Stdio+    MCP.Server.Transport.Http    -- Modules included in this library but not exported.   -- other-modules:@@ -77,9 +81,13 @@     base >=4.20.0 && <4.22,     bytestring >=0.10 && <0.13,     containers >=0.6 && <0.8,+    http-types >=0.12 && <1.0,     network-uri >=2.6 && <2.8,     template-haskell >=2.16 && <2.24,     text >=1.2 && <3.0,+    vector >=0.12 && <1.0,+    wai >=3.2 && <4.0,+    warp >=3.3 && <4.0,    -- Directories containing source files.   hs-source-dirs: src@@ -145,6 +153,26 @@    -- Directories containing source files.   hs-source-dirs: examples/Complete+  -- Base language which the package is written in.+  default-language: GHC2024++executable http-simple-example+  -- Import common warning flags.+  import: warnings+  -- .hs or .lhs file containing the Main module.+  main-is: Main.hs+  -- Modules included in this executable, other than Main.+  other-modules: Types+  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:+  -- Other library packages from which modules are imported.+  build-depends:+    base,+    mcp-server,+    text,++  -- Directories containing source files.+  hs-source-dirs: examples/HttpSimple   -- Base language which the package is written in.   default-language: GHC2024 

@@ -3,10 +3,14 @@  module MCP.Server   ( -- * Server Runtime-    runMcpServer-  , runMcpServerStdIn-  , handleMcpMessage+    runMcpServerStdIn+  , runMcpServerWithTransport +    -- * Transport Support+  , module MCP.Server.Transport.Types+  , module MCP.Server.Transport.Stdio+  , module MCP.Server.Transport.Http+     -- * Utility Functions   , jsonValueToText @@ -14,19 +18,14 @@   , module MCP.Server.Types   ) where -import           Control.Monad          (when)-import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Control.Monad.IO.Class (MonadIO) import           Data.Aeson-import qualified Data.ByteString.Lazy   as BSL-import qualified Data.Map               as Map import           Data.Text              (Text) import qualified Data.Text              as T-import qualified Data.Text.Encoding     as TE-import qualified Data.Text.IO           as TIO-import           System.IO              (hFlush, hPutStrLn, stderr, stdout) -import           MCP.Server.JsonRpc-import           MCP.Server.Protocol+import           MCP.Server.Transport.Types+import           MCP.Server.Transport.Stdio+import           MCP.Server.Transport.Http import           MCP.Server.Types  -- | Convert JSON Value to Text representation suitable for handlers@@ -42,322 +41,19 @@ jsonValueToText Null = "" jsonValueToText v = T.pack $ show v --- | Extract a brief summary of a JSON-RPC message for logging-getMessageSummary :: JsonRpcMessage -> String-getMessageSummary (JsonRpcMessageRequest req) = -  "Request[" ++ show (requestId req) ++ "] " ++ T.unpack (requestMethod req)-getMessageSummary (JsonRpcMessageNotification notif) = -  "Notification " ++ T.unpack (notificationMethod notif)-getMessageSummary (JsonRpcMessageResponse resp) = -  "Response[" ++ show (responseId resp) ++ "]"+-- | Run an MCP server with a specific transport+runMcpServerWithTransport :: (MonadIO m, McpTransport t) +                         => t                      -- ^ Transport configuration  +                         -> McpServerInfo          -- ^ Server information+                         -> McpServerHandlers m    -- ^ Message handlers+                         -> m TransportResult      -- ^ Result of transport operation+runMcpServerWithTransport transport serverInfo handlers = +  runTransport transport serverInfo handlers --- | Validate protocol version and return negotiated version-validateProtocolVersion :: Text -> Either Text Text-validateProtocolVersion clientVersion-  | clientVersion == protocolVersion = Right protocolVersion  -- Exact match-  | clientVersion == "2024-11-05" = Right "2024-11-05"        -- Accept this version-  | otherwise = Left $ "Unsupported protocol version: " <> clientVersion <> ". Server supports: " <> protocolVersion --- | Run an MCP server with custom input/output handlers-runMcpServer :: (MonadIO m)-             => McpServerInfo-             -> McpServerHandlers m-             -> (Text -> m ())      -- ^ Output handler-             -> m Text              -- ^ Input handler-             -> m ()-runMcpServer serverInfo handlers outputHandler inputHandler = do-  loop-  where-    loop = do-      input <- inputHandler-      when (not $ T.null $ T.strip input) $ do-        liftIO $ hPutStrLn stderr $ "Received request: " ++ T.unpack input-        case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of-          Left err -> liftIO $ hPutStrLn stderr $ "Parse error: " ++ err-          Right jsonValue -> do-            case parseJsonRpcMessage jsonValue of-              Left err -> liftIO $ hPutStrLn stderr $ "JSON-RPC parse error: " ++ err-              Right message -> do-                liftIO $ hPutStrLn stderr $ "Processing message: " ++ show (getMessageSummary message)-                response <- handleMcpMessage serverInfo handlers message-                case response of-                  Just responseMsg -> do-                    liftIO $ hPutStrLn stderr $ "Sending response for: " ++ show (getMessageSummary message)-                    outputHandler $ TE.decodeUtf8 $ BSL.toStrict $ encode $ encodeJsonRpcMessage responseMsg-                  Nothing -> liftIO $ hPutStrLn stderr $ "No response needed for: " ++ show (getMessageSummary message)-        loop- -- | Run an MCP server using stdin/stdout runMcpServerStdIn :: McpServerInfo -> McpServerHandlers IO -> IO ()-runMcpServerStdIn serverInfo handlers =-  runMcpServer serverInfo handlers outputHandler inputHandler-  where-    outputHandler text = do-      TIO.putStrLn text-      hFlush stdout-    inputHandler = TIO.getLine---- | Handle an MCP message and return a response if needed-handleMcpMessage :: (MonadIO m)-                 => McpServerInfo-                 -> McpServerHandlers m-                 -> JsonRpcMessage-                 -> m (Maybe JsonRpcMessage)-handleMcpMessage serverInfo handlers (JsonRpcMessageRequest req) = do-  response <- case requestMethod req of-    "initialize" -> handleInitialize serverInfo req-    "ping" -> handlePing req-    "prompts/list" -> handlePromptsList handlers req-    "prompts/get" -> handlePromptsGet handlers req-    "resources/list" -> handleResourcesList handlers req-    "resources/read" -> handleResourcesRead handlers req-    "tools/list" -> handleToolsList handlers req-    "tools/call" -> handleToolsCall handlers req-    method -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32601-      , errorMessage = "Method not found: " <> method-      , errorData = Nothing-      }-  return $ Just $ JsonRpcMessageResponse response--handleMcpMessage _ _ (JsonRpcMessageNotification notif) = do-  case notificationMethod notif of-    "notifications/initialized" -> do-      liftIO $ hPutStrLn stderr "Received initialized notification - server is ready for operation"-      return ()-    _ -> do-      liftIO $ hPutStrLn stderr $ "Received unknown notification: " ++ T.unpack (notificationMethod notif)-      return ()-  return Nothing--handleMcpMessage _ _ (JsonRpcMessageResponse _) =-  return Nothing---- | Handle initialize request-handleInitialize :: (MonadIO m) => McpServerInfo -> JsonRpcRequest -> m JsonRpcResponse-handleInitialize serverInfo req = do-  case requestParams req of-    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32602-      , errorMessage = "Missing required parameters for initialize"-      , errorData = Nothing-      }-    Just params ->-      case fromJSON params of-        Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError-          { errorCode = -32602-          , errorMessage = "Invalid initialize parameters: " <> T.pack err-          , errorData = Nothing-          }-        Success initReq -> do-          -- Check protocol version compatibility-          let clientVersion = initProtocolVersion initReq-          case validateProtocolVersion clientVersion of-            Left errorMsg -> return $ makeErrorResponse (requestId req) $ JsonRpcError-              { errorCode = -32602-              , errorMessage = errorMsg-              , errorData = Nothing-              }-            Right negotiatedVersion -> do-              liftIO $ hPutStrLn stderr $ "Client version: " ++ T.unpack clientVersion ++ ", using: " ++ T.unpack negotiatedVersion-              let capabilities = ServerCapabilities-                    { capabilityPrompts = Just $ PromptCapabilities { promptListChanged = Nothing }-                    , capabilityResources = Just $ ResourceCapabilities { resourceSubscribe = Nothing, resourceListChanged = Nothing }-                    , capabilityTools = Just $ ToolCapabilities { toolListChanged = Nothing }-                    , capabilityLogging = Nothing  -- Not supported yet-                    }-              let response = InitializeResponse-                    { initRespProtocolVersion = negotiatedVersion-                    , initRespCapabilities = capabilities-                    , initRespServerInfo = serverInfo-                    }-              return $ makeSuccessResponse (requestId req) (toJSON response)---- | Handle ping request-handlePing :: (MonadIO m) => JsonRpcRequest -> m JsonRpcResponse-handlePing req = return $ makeSuccessResponse (requestId req) (toJSON PongResponse)---- | Handle prompts/list request-handlePromptsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handlePromptsList handlers req =-  case prompts handlers of-    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32601-      , errorMessage = "Prompts not supported"-      , errorData = Nothing-      }-    Just (listHandler, _) -> do-      promptsList <- listHandler-      let response = PromptsListResponse-            { promptsListPrompts = promptsList-            }-      return $ makeSuccessResponse (requestId req) (toJSON response)---- | Handle prompts/get request-handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handlePromptsGet handlers req =-  case prompts handlers of-    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32601-      , errorMessage = "Prompts not supported"-      , errorData = Nothing-      }-    Just (_, getHandler) -> do-      case requestParams req of-        Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-          { errorCode = -32602-          , errorMessage = "Missing parameters"-          , errorData = Nothing-          }-        Just params ->-          case fromJSON params of-            Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError-              { errorCode = -32602-              , errorMessage = "Invalid parameters: " <> T.pack err-              , errorData = Nothing-              }-            Success getReq -> do-              let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (promptsGetArguments getReq)-              result <- getHandler (promptsGetName getReq) args-              case result of-                Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError-                  { errorCode = errorCodeFromMcpError err-                  , errorMessage = errorMessageFromMcpError err-                  , errorData = Nothing-                  }-                Right content -> do-                  let response = PromptsGetResponse-                        { promptsGetDescription = Nothing-                        , promptsGetMessages = [PromptMessage RoleUser content]-                        }-                  return $ makeSuccessResponse (requestId req) (toJSON response)---- | Handle resources/list request-handleResourcesList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleResourcesList handlers req =-  case resources handlers of-    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32601-      , errorMessage = "Resources not supported"-      , errorData = Nothing-      }-    Just (listHandler, _) -> do-      resourcesList <- listHandler-      let response = ResourcesListResponse-            { resourcesListResources = resourcesList-            }-      return $ makeSuccessResponse (requestId req) (toJSON response)---- | Handle resources/read request-handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleResourcesRead handlers req =-  case resources handlers of-    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32601-      , errorMessage = "Resources not supported"-      , errorData = Nothing-      }-    Just (_, readHandler) -> do-      case requestParams req of-        Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-          { errorCode = -32602-          , errorMessage = "Missing parameters"-          , errorData = Nothing-          }-        Just params ->-          case fromJSON params of-            Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError-              { errorCode = -32602-              , errorMessage = "Invalid parameters: " <> T.pack err-              , errorData = Nothing-              }-            Success readReq -> do-              result <- readHandler (resourcesReadUri readReq)-              case result of-                Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError-                  { errorCode = errorCodeFromMcpError err-                  , errorMessage = errorMessageFromMcpError err-                  , errorData = Nothing-                  }-                Right resourceContent -> do-                  let response = ResourcesReadResponse-                        { resourcesReadContents = [resourceContent]-                        }-                  return $ makeSuccessResponse (requestId req) (toJSON response)---- | Handle tools/list request-handleToolsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleToolsList handlers req =-  case tools handlers of-    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32601-      , errorMessage = "Tools not supported"-      , errorData = Nothing-      }-    Just (listHandler, _) -> do-      toolsList <- listHandler-      let response = ToolsListResponse-            { toolsListTools = toolsList-            }-      return $ makeSuccessResponse (requestId req) (toJSON response)---- | Handle tools/call request-handleToolsCall :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse-handleToolsCall handlers req =-  case tools handlers of-    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-      { errorCode = -32601-      , errorMessage = "Tools not supported"-      , errorData = Nothing-      }-    Just (_, callHandler) -> do-      case requestParams req of-        Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError-          { errorCode = -32602-          , errorMessage = "Missing parameters"-          , errorData = Nothing-          }-        Just params ->-          case fromJSON params of-            Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError-              { errorCode = -32602-              , errorMessage = "Invalid parameters: " <> T.pack err-              , errorData = Nothing-              }-            Success callReq -> do-              let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (toolsCallArguments callReq)-              result <- callHandler (toolsCallName callReq) args-              case result of-                Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError-                  { errorCode = errorCodeFromMcpError err-                  , errorMessage = errorMessageFromMcpError err-                  , errorData = Nothing-                  }-                Right content -> do-                  let response = ToolsCallResponse-                        { toolsCallContent = [content]-                        , toolsCallIsError = Nothing-                        }-                  return $ makeSuccessResponse (requestId req) (toJSON response)---- | Convert MCP error to JSON-RPC error code-errorCodeFromMcpError :: Error -> Int-errorCodeFromMcpError (InvalidPromptName _)     = -32602-errorCodeFromMcpError (MissingRequiredParams _) = -32602-errorCodeFromMcpError (ResourceNotFound _)      = -32602-errorCodeFromMcpError (InternalError _)         = -32603-errorCodeFromMcpError (UnknownTool _)           = -32602-errorCodeFromMcpError (InvalidRequest _)        = -32600-errorCodeFromMcpError (MethodNotFound _)        = -32601-errorCodeFromMcpError (InvalidParams _)         = -32602+runMcpServerStdIn serverInfo handlers = do+  _ <- runMcpServerWithTransport StdioTransport serverInfo handlers+  return () --- | Convert MCP error to JSON-RPC error message-errorMessageFromMcpError :: Error -> Text-errorMessageFromMcpError (InvalidPromptName msg) = "Invalid prompt name: " <> msg-errorMessageFromMcpError (MissingRequiredParams msg) = "Missing required parameters: " <> msg-errorMessageFromMcpError (ResourceNotFound msg) = "Resource not found: " <> msg-errorMessageFromMcpError (InternalError msg) = "Internal error: " <> msg-errorMessageFromMcpError (UnknownTool msg) = "Unknown tool: " <> msg-errorMessageFromMcpError (InvalidRequest msg) = "Invalid request: " <> msg-errorMessageFromMcpError (MethodNotFound msg) = "Method not found: " <> msg-errorMessageFromMcpError (InvalidParams msg) = "Invalid parameters: " <> msg

@@ -0,0 +1,332 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module MCP.Server.Handlers+  ( -- * Core Message Handling+    handleMcpMessage+  , jsonValueToText+  +    -- * Individual Request Handlers+  , handleInitialize+  , handlePing+  , handlePromptsList+  , handlePromptsGet+  , handleResourcesList+  , handleResourcesRead+  , handleToolsList+  , handleToolsCall+  +    -- * Protocol Support+  , validateProtocolVersion+  , getMessageSummary+  +    -- * Error Conversion+  , errorCodeFromMcpError+  , errorMessageFromMcpError+  ) where++import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Data.Aeson+import qualified Data.Map               as Map+import           Data.Text              (Text)+import qualified Data.Text              as T+import           System.IO              (hPutStrLn, stderr)++import           MCP.Server.JsonRpc+import           MCP.Server.Protocol+import           MCP.Server.Types++-- | Convert JSON Value to Text representation suitable for handlers+jsonValueToText :: Value -> Text+jsonValueToText (String t) = t+jsonValueToText (Number n) = +    -- Check if it's a whole number, if so format as integer+    if fromInteger (round n) == n+        then T.pack $ show (round n :: Integer)+        else T.pack $ show n+jsonValueToText (Bool True) = "true"+jsonValueToText (Bool False) = "false"+jsonValueToText Null = ""+jsonValueToText v = T.pack $ show v++-- | Extract a brief summary of a JSON-RPC message for logging+getMessageSummary :: JsonRpcMessage -> String+getMessageSummary (JsonRpcMessageRequest req) = +  "Request[" ++ show (requestId req) ++ "] " ++ T.unpack (requestMethod req)+getMessageSummary (JsonRpcMessageNotification notif) = +  "Notification " ++ T.unpack (notificationMethod notif)+getMessageSummary (JsonRpcMessageResponse resp) = +  "Response[" ++ show (responseId resp) ++ "]"++-- | Validate protocol version and return negotiated version+validateProtocolVersion :: Text -> Either Text Text+validateProtocolVersion clientVersion+  | clientVersion == protocolVersion = Right protocolVersion  -- Exact match (2025-03-26)+  | clientVersion == "2025-03-26" = Right "2025-03-26"        -- Accept latest version+  | clientVersion == "2024-11-05" = Right "2024-11-05"        -- Accept legacy version+  | otherwise = Left $ "Unsupported protocol version: " <> clientVersion <> ". Server supports: 2025-03-26, 2024-11-05"++-- | Handle an MCP message and return a response if needed+handleMcpMessage :: (MonadIO m)+                 => McpServerInfo+                 -> McpServerHandlers m+                 -> JsonRpcMessage+                 -> m (Maybe JsonRpcMessage)+handleMcpMessage serverInfo handlers (JsonRpcMessageRequest req) = do+  response <- case requestMethod req of+    "initialize" -> handleInitialize serverInfo req+    "ping" -> handlePing req+    "prompts/list" -> handlePromptsList handlers req+    "prompts/get" -> handlePromptsGet handlers req+    "resources/list" -> handleResourcesList handlers req+    "resources/read" -> handleResourcesRead handlers req+    "tools/list" -> handleToolsList handlers req+    "tools/call" -> handleToolsCall handlers req+    method -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Method not found: " <> method+      , errorData = Nothing+      }+  return $ Just $ JsonRpcMessageResponse response++handleMcpMessage _ _ (JsonRpcMessageNotification notif) = do+  case notificationMethod notif of+    "notifications/initialized" -> do+      liftIO $ hPutStrLn stderr "Received initialized notification - server is ready for operation"+      return ()+    _ -> do+      liftIO $ hPutStrLn stderr $ "Received unknown notification: " ++ T.unpack (notificationMethod notif)+      return ()+  return Nothing++handleMcpMessage _ _ (JsonRpcMessageResponse _) =+  return Nothing++-- | Handle initialize request+handleInitialize :: (MonadIO m) => McpServerInfo -> JsonRpcRequest -> m JsonRpcResponse+handleInitialize serverInfo req = do+  case requestParams req of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32602+      , errorMessage = "Missing required parameters for initialize"+      , errorData = Nothing+      }+    Just params ->+      case fromJSON params of+        Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+          { errorCode = -32602+          , errorMessage = "Invalid initialize parameters: " <> T.pack err+          , errorData = Nothing+          }+        Success initReq -> do+          -- Check protocol version compatibility+          let clientVersion = initProtocolVersion initReq+          case validateProtocolVersion clientVersion of+            Left errorMsg -> return $ makeErrorResponse (requestId req) $ JsonRpcError+              { errorCode = -32602+              , errorMessage = errorMsg+              , errorData = Nothing+              }+            Right negotiatedVersion -> do+              liftIO $ hPutStrLn stderr $ "Client version: " ++ T.unpack clientVersion ++ ", using: " ++ T.unpack negotiatedVersion+              let capabilities = ServerCapabilities+                    { capabilityPrompts = Just $ PromptCapabilities { promptListChanged = Nothing }+                    , capabilityResources = Just $ ResourceCapabilities { resourceSubscribe = Nothing, resourceListChanged = Nothing }+                    , capabilityTools = Just $ ToolCapabilities { toolListChanged = Nothing }+                    , capabilityLogging = Nothing  -- Not supported yet+                    }+              let response = InitializeResponse+                    { initRespProtocolVersion = negotiatedVersion+                    , initRespCapabilities = capabilities+                    , initRespServerInfo = serverInfo+                    }+              return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle ping request+handlePing :: (MonadIO m) => JsonRpcRequest -> m JsonRpcResponse+handlePing req = return $ makeSuccessResponse (requestId req) (toJSON PongResponse)++-- | Handle prompts/list request+handlePromptsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handlePromptsList handlers req =+  case prompts handlers of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Prompts not supported"+      , errorData = Nothing+      }+    Just (listHandler, _) -> do+      promptsList <- listHandler+      let response = PromptsListResponse+            { promptsListPrompts = promptsList+            }+      return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle prompts/get request+handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handlePromptsGet handlers req =+  case prompts handlers of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Prompts not supported"+      , errorData = Nothing+      }+    Just (_, getHandler) -> do+      case requestParams req of+        Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+          { errorCode = -32602+          , errorMessage = "Missing parameters"+          , errorData = Nothing+          }+        Just params ->+          case fromJSON params of+            Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+              { errorCode = -32602+              , errorMessage = "Invalid parameters: " <> T.pack err+              , errorData = Nothing+              }+            Success getReq -> do+              let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (promptsGetArguments getReq)+              result <- getHandler (promptsGetName getReq) args+              case result of+                Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+                  { errorCode = errorCodeFromMcpError err+                  , errorMessage = errorMessageFromMcpError err+                  , errorData = Nothing+                  }+                Right content -> do+                  let response = PromptsGetResponse+                        { promptsGetDescription = Nothing+                        , promptsGetMessages = [PromptMessage RoleUser content]+                        }+                  return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle resources/list request+handleResourcesList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleResourcesList handlers req =+  case resources handlers of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Resources not supported"+      , errorData = Nothing+      }+    Just (listHandler, _) -> do+      resourcesList <- listHandler+      let response = ResourcesListResponse+            { resourcesListResources = resourcesList+            }+      return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle resources/read request+handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleResourcesRead handlers req =+  case resources handlers of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Resources not supported"+      , errorData = Nothing+      }+    Just (_, readHandler) -> do+      case requestParams req of+        Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+          { errorCode = -32602+          , errorMessage = "Missing parameters"+          , errorData = Nothing+          }+        Just params ->+          case fromJSON params of+            Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+              { errorCode = -32602+              , errorMessage = "Invalid parameters: " <> T.pack err+              , errorData = Nothing+              }+            Success readReq -> do+              result <- readHandler (resourcesReadUri readReq)+              case result of+                Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+                  { errorCode = errorCodeFromMcpError err+                  , errorMessage = errorMessageFromMcpError err+                  , errorData = Nothing+                  }+                Right resourceContent -> do+                  let response = ResourcesReadResponse+                        { resourcesReadContents = [resourceContent]+                        }+                  return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle tools/list request+handleToolsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleToolsList handlers req =+  case tools handlers of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Tools not supported"+      , errorData = Nothing+      }+    Just (listHandler, _) -> do+      toolsList <- listHandler+      let response = ToolsListResponse+            { toolsListTools = toolsList+            }+      return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle tools/call request+handleToolsCall :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleToolsCall handlers req =+  case tools handlers of+    Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+      { errorCode = -32601+      , errorMessage = "Tools not supported"+      , errorData = Nothing+      }+    Just (_, callHandler) -> do+      case requestParams req of+        Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+          { errorCode = -32602+          , errorMessage = "Missing parameters"+          , errorData = Nothing+          }+        Just params ->+          case fromJSON params of+            Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+              { errorCode = -32602+              , errorMessage = "Invalid parameters: " <> T.pack err+              , errorData = Nothing+              }+            Success callReq -> do+              let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (toolsCallArguments callReq)+              result <- callHandler (toolsCallName callReq) args+              case result of+                Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+                  { errorCode = errorCodeFromMcpError err+                  , errorMessage = errorMessageFromMcpError err+                  , errorData = Nothing+                  }+                Right content -> do+                  let response = ToolsCallResponse+                        { toolsCallContent = [content]+                        , toolsCallIsError = Nothing+                        }+                  return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Convert MCP error to JSON-RPC error code+errorCodeFromMcpError :: Error -> Int+errorCodeFromMcpError (InvalidPromptName _)     = -32602+errorCodeFromMcpError (MissingRequiredParams _) = -32602+errorCodeFromMcpError (ResourceNotFound _)      = -32602+errorCodeFromMcpError (InternalError _)         = -32603+errorCodeFromMcpError (UnknownTool _)           = -32602+errorCodeFromMcpError (InvalidRequest _)        = -32600+errorCodeFromMcpError (MethodNotFound _)        = -32601+errorCodeFromMcpError (InvalidParams _)         = -32602++-- | Convert MCP error to JSON-RPC error message+errorMessageFromMcpError :: Error -> Text+errorMessageFromMcpError (InvalidPromptName msg) = "Invalid prompt name: " <> msg+errorMessageFromMcpError (MissingRequiredParams msg) = "Missing required parameters: " <> msg+errorMessageFromMcpError (ResourceNotFound msg) = "Resource not found: " <> msg+errorMessageFromMcpError (InternalError msg) = "Internal error: " <> msg+errorMessageFromMcpError (UnknownTool msg) = "Unknown tool: " <> msg+errorMessageFromMcpError (InvalidRequest msg) = "Invalid request: " <> msg+errorMessageFromMcpError (MethodNotFound msg) = "Method not found: " <> msg+errorMessageFromMcpError (InvalidParams msg) = "Invalid parameters: " <> msg

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-}  module MCP.Server.Protocol@@ -8,7 +8,7 @@   , InitializedNotification(..)   , PingRequest(..)   , PongResponse(..)-  +     -- * Prompts Protocol   , PromptsListRequest(..)   , PromptsListResponse(..)@@ -16,42 +16,41 @@   , PromptsGetResponse(..)   , PromptMessage(..)   , MessageRole(..)-  +     -- * Resources Protocol   , ResourcesListRequest(..)   , ResourcesListResponse(..)   , ResourcesReadRequest(..)   , ResourcesReadResponse(..)-  +     -- * Tools Protocol   , ToolsListRequest(..)   , ToolsListResponse(..)   , ToolsCallRequest(..)   , ToolsCallResponse(..)-  +     -- * Common Types   , ListChangedNotification(..)-  +     -- * Protocol Functions   , protocolVersion   ) where -import Data.Text (Text)-import Data.Aeson-import Data.Map (Map)-import Network.URI (URI)-import GHC.Generics (Generic)-import MCP.Server.Types+import           Data.Aeson+import           Data.Map         (Map)+import           Data.Text        (Text)+import           GHC.Generics     (Generic)+import           MCP.Server.Types  protocolVersion :: Text-protocolVersion = "2024-11-05"+protocolVersion = "2025-03-26"   -- | Initialize request data InitializeRequest = InitializeRequest   { initProtocolVersion :: Text-  , initCapabilities :: Value-  , initClientInfo :: Value+  , initCapabilities    :: Value+  , initClientInfo      :: Value   } deriving (Show, Eq, Generic)  instance FromJSON InitializeRequest where@@ -63,8 +62,8 @@ -- | Initialize response data InitializeResponse = InitializeResponse   { initRespProtocolVersion :: Text-  , initRespCapabilities :: ServerCapabilities-  , initRespServerInfo :: McpServerInfo+  , initRespCapabilities    :: ServerCapabilities+  , initRespServerInfo      :: McpServerInfo   } deriving (Show, Eq, Generic)  instance ToJSON InitializeResponse where@@ -104,12 +103,12 @@   deriving (Show, Eq, Generic)  instance ToJSON MessageRole where-  toJSON RoleUser = "user"+  toJSON RoleUser      = "user"   toJSON RoleAssistant = "assistant"  -- | Prompt message data PromptMessage = PromptMessage-  { promptMessageRole :: MessageRole+  { promptMessageRole    :: MessageRole   , promptMessageContent :: Content   } deriving (Show, Eq, Generic) @@ -138,7 +137,7 @@  -- | Prompts get request data PromptsGetRequest = PromptsGetRequest-  { promptsGetName :: Text+  { promptsGetName      :: Text   , promptsGetArguments :: Maybe (Map Text Value)   } deriving (Show, Eq, Generic) @@ -150,7 +149,7 @@ -- | Prompts get response data PromptsGetResponse = PromptsGetResponse   { promptsGetDescription :: Maybe Text-  , promptsGetMessages :: [PromptMessage]+  , promptsGetMessages    :: [PromptMessage]   } deriving (Show, Eq, Generic)  instance ToJSON PromptsGetResponse where@@ -185,7 +184,7 @@     uriText <- o .: "uri"     case parseURI uriText of       Just uri -> return $ ResourcesReadRequest uri-      Nothing -> fail "Invalid URI"+      Nothing  -> fail "Invalid URI"  -- | Resources read response data ResourcesReadResponse = ResourcesReadResponse@@ -216,7 +215,7 @@  -- | Tools call request data ToolsCallRequest = ToolsCallRequest-  { toolsCallName :: Text+  { toolsCallName      :: Text   , toolsCallArguments :: Maybe (Map Text Value)   } deriving (Show, Eq, Generic) 

@@ -0,0 +1,212 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module MCP.Server.Transport.Http+  ( -- * HTTP Transport+    HttpTransport(..)+  , HttpConfig(..)+  , runMcpServerHttp+  , runMcpServerHttpWithConfig+  ) where++import           Control.Monad            (when)+import           Data.Aeson+import qualified Data.ByteString.Lazy     as BSL+import           Data.String              (IsString (fromString))+import           Data.Text                (Text)+import qualified Data.Text                as T+import qualified Data.Text.Encoding       as TE+import qualified Data.Vector              as V+import           Network.HTTP.Types+import qualified Network.Wai              as Wai+import qualified Network.Wai.Handler.Warp as Warp+import           System.IO                (hPutStrLn, stderr)++import           MCP.Server.Handlers+import           MCP.Server.JsonRpc+import           MCP.Server.Types++-- | HTTP transport configuration following MCP 2025-03-26 Streamable HTTP specification+data HttpConfig = HttpConfig+  { httpPort     :: Int      -- ^ Port to listen on+  , httpHost     :: String   -- ^ Host to bind to (default "localhost")+  , httpEndpoint :: String   -- ^ MCP endpoint path (default "/mcp")+  , httpVerbose  :: Bool     -- ^ Enable verbose logging (default False)+  } deriving (Show, Eq)++-- | Default HTTP configuration+defaultHttpConfig :: HttpConfig+defaultHttpConfig = HttpConfig+  { httpPort = 3000+  , httpHost = "localhost"+  , httpEndpoint = "/mcp"+  , httpVerbose = False+  }++-- | HTTP transport following MCP 2025-03-26 Streamable HTTP specification+data HttpTransport = HttpTransport HttpConfig+  deriving (Show, Eq)++-- Note: HTTP transport is constrained to IO only due to Warp requirements+-- For the generic interface, we'll use a more specific function++-- | Helper for conditional logging+logVerbose :: HttpConfig -> String -> IO ()+logVerbose config msg = when (httpVerbose config) $ hPutStrLn stderr msg++-- | Run an MCP server using HTTP transport with default config+runMcpServerHttp :: McpServerInfo -> McpServerHandlers IO -> IO ()+runMcpServerHttp = runMcpServerHttpWithConfig defaultHttpConfig++-- | Run an MCP server using HTTP transport with custom config+runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO ()+runMcpServerHttpWithConfig config serverInfo handlers = do+  let settings = Warp.setHost (fromString $ httpHost config) $+                 Warp.setPort (httpPort config) $+                 Warp.defaultSettings++  putStrLn $ "Starting MCP HTTP server on " ++ httpHost config ++ ":" ++ show (httpPort config) ++ httpEndpoint config+  Warp.runSettings settings (mcpApplication config serverInfo handlers)++-- | WAI Application for MCP over HTTP+mcpApplication :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Wai.Application+mcpApplication config serverInfo handlers req respond = do+  -- Log the request+  logVerbose config $ "HTTP " ++ show (Wai.requestMethod req) ++ " " ++ T.unpack (TE.decodeUtf8 $ Wai.rawPathInfo req)++  -- Check if this is our MCP endpoint+  if TE.decodeUtf8 (Wai.rawPathInfo req) == T.pack (httpEndpoint config)+    then handleMcpRequest config serverInfo handlers req respond+    else respond $ Wai.responseLBS status404 [("Content-Type", "text/plain")] "Not Found"++-- | Handle MCP requests according to Streamable HTTP specification+handleMcpRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleMcpRequest config serverInfo handlers req respond = do+  case Wai.requestMethod req of+    -- GET requests for endpoint discovery+    "GET" -> do+      let discoveryResponse = object+            [ "name" .= serverName serverInfo+            , "version" .= serverVersion serverInfo+            , "description" .= serverInstructions serverInfo+            , "protocolVersion" .= ("2025-03-26" :: Text)+            , "capabilities" .= object+                [ "tools" .= object []+                , "prompts" .= object []+                , "resources" .= object []+                ]+            ]+      logVerbose config $ "Sending server discovery response: " ++ show discoveryResponse+      respond $ Wai.responseLBS+        status200+        [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")]+        (encode discoveryResponse)++    -- POST requests for JSON-RPC messages+    "POST" -> do+      -- Read request body+      body <- Wai.strictRequestBody req+      logVerbose config $ "Received POST body (" ++ show (BSL.length body) ++ " bytes): " ++ take 200 (show body)+      handleJsonRpcRequest config serverInfo handlers body respond++    -- OPTIONS for CORS preflight+    "OPTIONS" -> respond $ Wai.responseLBS+      status200+      [ ("Access-Control-Allow-Origin", "*")+      , ("Access-Control-Allow-Methods", "GET, POST, OPTIONS")+      , ("Access-Control-Allow-Headers", "Content-Type")+      ]+      ""++    -- Unsupported methods+    _ -> respond $ Wai.responseLBS+      status405+      [("Content-Type", "text/plain"), ("Allow", "GET, POST, OPTIONS")]+      "Method Not Allowed"++-- | Handle JSON-RPC request from HTTP body (supports batching)+handleJsonRpcRequest :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> BSL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleJsonRpcRequest config serverInfo handlers body respond = do+  case eitherDecode body of+    Left err -> do+      hPutStrLn stderr $ "JSON parse error: " ++ err+      respond $ Wai.responseLBS+        status400+        [("Content-Type", "application/json")]+        (encode $ object ["error" .= ("Invalid JSON" :: Text)])++    Right jsonValue -> do+      -- Try to parse as batch first (array), then as single message+      case jsonValue of+        Array batch -> handleJsonRpcBatch config serverInfo handlers (V.toList batch) respond+        singleValue -> handleSingleJsonRpc config serverInfo handlers singleValue respond++-- | Handle a single JSON-RPC message+handleSingleJsonRpc :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Value -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleSingleJsonRpc config serverInfo handlers jsonValue respond = do+  case parseJsonRpcMessage jsonValue of+    Left err -> do+      hPutStrLn stderr $ "JSON-RPC parse error: " ++ err+      respond $ Wai.responseLBS+        status400+        [("Content-Type", "application/json")]+        (encode $ object ["error" .= ("Invalid JSON-RPC" :: Text)])++    Right message -> do+      logVerbose config $ "Processing HTTP message: " ++ show (getMessageSummary message)+      maybeResponse <- handleMcpMessage serverInfo handlers message++      case maybeResponse of+        Just responseMsg -> do+          let responseJson = encode $ encodeJsonRpcMessage responseMsg+          logVerbose config $ "Sending HTTP response for: " ++ show (getMessageSummary message)+          respond $ Wai.responseLBS+            status200+            [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")]+            responseJson++        Nothing -> do+          logVerbose config $ "No response needed for: " ++ show (getMessageSummary message)+          -- For notifications, return 200 with empty JSON object (per MCP spec)+          respond $ Wai.responseLBS +            status200 +            [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] +            "{}"++-- | Handle JSON-RPC batch request (MCP 2025-03-26 feature)+handleJsonRpcBatch :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> [Value] -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleJsonRpcBatch config serverInfo handlers batch respond = do+  logVerbose config $ "Processing JSON-RPC batch with " ++ show (length batch) ++ " messages"++  -- Process each message in the batch+  responses <- mapM (processBatchMessage config serverInfo handlers) batch++  -- Filter out Nothing responses (notifications)+  let validResponses = [r | Just r <- responses]++  case validResponses of+    [] -> do+      logVerbose config "Batch contained only notifications, returning empty JSON array"+      respond $ Wai.responseLBS +        status200 +        [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] +        "[]"+    _ -> do+      let responseJson = encode $ map encodeJsonRpcMessage validResponses+      logVerbose config $ "Sending batch response with " ++ show (length validResponses) ++ " responses"+      respond $ Wai.responseLBS+        status200+        [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")]+        responseJson++-- | Process a single message from a batch+processBatchMessage :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> Value -> IO (Maybe JsonRpcMessage)+processBatchMessage config serverInfo handlers jsonValue = do+  case parseJsonRpcMessage jsonValue of+    Left err -> do+      logVerbose config $ "Batch message parse error: " ++ err+      return Nothing -- Skip invalid messages in batch+    Right message -> do+      logVerbose config $ "Processing batch message: " ++ show (getMessageSummary message)+      handleMcpMessage serverInfo handlers message+

@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module MCP.Server.Transport.Stdio+  ( -- * STDIO Transport+    StdioTransport(..)+  , runMcpServerStdio+  ) where++import           Control.Monad          (when)+import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Data.Aeson+import qualified Data.ByteString.Lazy   as BSL+import qualified Data.Text              as T+import qualified Data.Text.Encoding     as TE+import qualified Data.Text.IO           as TIO+import           System.IO              (hFlush, hPutStrLn, stderr, stdout)++import           MCP.Server.Handlers+import           MCP.Server.JsonRpc+import           MCP.Server.Transport.Types+import           MCP.Server.Types++-- | STDIO transport configuration+data StdioTransport = StdioTransport+  deriving (Show, Eq)++instance McpTransport StdioTransport where+  runTransport StdioTransport serverInfo handlers = do+    runMcpServerStdio serverInfo handlers+    return $ TransportResult True Nothing+++-- | Run an MCP server using STDIO transport+runMcpServerStdio :: (MonadIO m) => McpServerInfo -> McpServerHandlers m -> m ()+runMcpServerStdio serverInfo handlers = do+  loop+  where+    loop = do+      input <- liftIO TIO.getLine+      when (not $ T.null $ T.strip input) $ do+        liftIO $ hPutStrLn stderr $ "Received request: " ++ T.unpack input+        case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of+          Left err -> liftIO $ hPutStrLn stderr $ "Parse error: " ++ err+          Right jsonValue -> do+            case parseJsonRpcMessage jsonValue of+              Left err -> liftIO $ hPutStrLn stderr $ "JSON-RPC parse error: " ++ err+              Right message -> do+                liftIO $ hPutStrLn stderr $ "Processing message: " ++ show (getMessageSummary message)+                response <- handleMcpMessage serverInfo handlers message+                case response of+                  Just responseMsg -> do+                    liftIO $ hPutStrLn stderr $ "Sending response for: " ++ show (getMessageSummary message)+                    let responseText = TE.decodeUtf8 $ BSL.toStrict $ encode $ encodeJsonRpcMessage responseMsg+                    liftIO $ TIO.putStrLn responseText+                    liftIO $ hFlush stdout+                  Nothing -> liftIO $ hPutStrLn stderr $ "No response needed for: " ++ show (getMessageSummary message)+        loop+

@@ -0,0 +1,33 @@+{-# LANGUAGE RankNTypes #-}++module MCP.Server.Transport.Types+  ( -- * Transport Class+    McpTransport(..)+  , TransportConfig(..)+  +    -- * Transport Result+  , TransportResult(..)+  ) where++import           Control.Monad.IO.Class (MonadIO)+import           MCP.Server.Types++-- | Result of transport operations+data TransportResult = TransportResult+  { transportSuccess :: Bool+  , transportError   :: Maybe String+  } deriving (Show, Eq)++-- | Configuration for different transport types+data TransportConfig+  = StdioConfig+  deriving (Show, Eq)++-- | Transport abstraction class+class McpTransport t where+  -- | Run the MCP server with this transport+  runTransport :: (MonadIO m) +               => t                      -- ^ Transport configuration+               -> McpServerInfo          -- ^ Server information+               -> McpServerHandlers m    -- ^ Message handlers+               -> m TransportResult      -- ^ Result of transport operation