diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/examples/HttpSimple/Main.hs b/examples/HttpSimple/Main.hs new file mode 100644 --- /dev/null +++ b/examples/HttpSimple/Main.hs @@ -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 + } diff --git a/examples/HttpSimple/Types.hs b/examples/HttpSimple/Types.hs new file mode 100644 --- /dev/null +++ b/examples/HttpSimple/Types.hs @@ -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") + ] diff --git a/mcp-server.cabal b/mcp-server.cabal --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -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 diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -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 diff --git a/src/MCP/Server/Handlers.hs b/src/MCP/Server/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Handlers.hs @@ -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 diff --git a/src/MCP/Server/Protocol.hs b/src/MCP/Server/Protocol.hs --- a/src/MCP/Server/Protocol.hs +++ b/src/MCP/Server/Protocol.hs @@ -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) diff --git a/src/MCP/Server/Transport/Http.hs b/src/MCP/Server/Transport/Http.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Transport/Http.hs @@ -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 + diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Transport/Stdio.hs @@ -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 + diff --git a/src/MCP/Server/Transport/Types.hs b/src/MCP/Server/Transport/Types.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Transport/Types.hs @@ -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