mcp-server 0.1.0.11 → 0.1.0.12

raw patch · 12 files changed

+305/−96 lines, 12 filesdep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• README.md +2/−2
• app/Main.hs +8/−1
• examples/Complete/Main.hs +5/−1
• examples/HttpSimple/Main.hs +5/−1
• examples/Simple/Main.hs +6/−2
• mcp-server.cabal +3/−2
• src/MCP/Server.hs +16/−22
• src/MCP/Server/Transport/Http.hs +6/−17
• src/MCP/Server/Transport/Stdio.hs +5/−15
• src/MCP/Server/Transport/Types.hs +0/−33
• test/HspecMain.hs +2/−0
• test/Spec/UnicodeHandling.hs +247/−0

@@ -56,7 +56,7 @@  -- Derive handlers automatically main :: IO ()-main = runMcpServerStdIn serverInfo handlers+main = runMcpServerStdio serverInfo handlers   where     serverInfo = McpServerInfo       { serverName = "My MCP Server"@@ -132,7 +132,7 @@ -- ... implement your custom logic  main :: IO ()-main = runMcpServerStdIn serverInfo handlers+main = runMcpServerStdio serverInfo handlers   where     handlers = McpServerHandlers       { prompts = Just (promptListHandler, promptGetHandler)

@@ -2,5 +2,12 @@  module Main where +import System.IO (hSetEncoding, stderr, stdout, utf8)+ main :: IO ()-main = putStrLn "Hello, World!"+main = do+    -- Set UTF-8 encoding to handle Unicode characters properly+    hSetEncoding stdout utf8+    hSetEncoding stderr utf8+    +    putStrLn "Hello, World!"

@@ -5,6 +5,7 @@  import           MCP.Server import           MCP.Server.Derive+import           System.IO (hSetEncoding, stderr, stdout, utf8) import           Types  -- High-level handler functions@@ -37,11 +38,14 @@  main :: IO () main = do+    -- Set UTF-8 encoding to handle Unicode characters properly+    hSetEncoding stdout utf8+    hSetEncoding stderr utf8     -- Derive the handlers using Template Haskell     let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt)         resources = $(deriveResourceHandler ''MyResource 'handleResource)         tools = $(deriveToolHandler ''MyTool 'handleTool)-     in runMcpServerStdIn+     in runMcpServerStdio         McpServerInfo             { serverName = "Complete Example MCP Server"             , serverVersion = "0.3.0"

@@ -6,11 +6,15 @@ import           Data.IORef import           MCP.Server import           MCP.Server.Derive-import           System.IO         (hPutStrLn, stderr)+import           System.IO         (hPutStrLn, hSetEncoding, stderr, stdout, utf8) import           Types  main :: IO () main = do+    -- Set UTF-8 encoding to handle Unicode characters properly+    hSetEncoding stdout utf8+    hSetEncoding stderr utf8+         hPutStrLn stderr "Starting HTTP Simple MCP Server..."      -- Create a simple in-memory store

@@ -6,11 +6,15 @@ import           Data.IORef import           MCP.Server import           MCP.Server.Derive-import           System.IO         (hPutStrLn, stderr)+import           System.IO         (hPutStrLn, hSetEncoding, stderr, stdout, utf8) import           Types  main :: IO () main = do+    -- Set UTF-8 encoding to handle Unicode characters properly+    hSetEncoding stdout utf8+    hSetEncoding stderr utf8+         hPutStrLn stderr "Starting Simple MCP Server..."      -- Create a simple in-memory store@@ -30,7 +34,7 @@      -- Derive the tool handlers using Template Haskell with descriptions     let tools = $(deriveToolHandlerWithDescription ''SimpleTool 'handleTool simpleDescriptions)-     in runMcpServerStdIn+     in runMcpServerStdio         McpServerInfo             { serverName = "Simple Key-Value MCP Server"             , serverVersion = "1.0.0"

@@ -15,7 +15,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.1.0.11+version: 0.1.0.12 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.@@ -67,7 +67,6 @@     MCP.Server.JsonRpc     MCP.Server.Protocol     MCP.Server.Types-    MCP.Server.Transport.Types     MCP.Server.Transport.Stdio     MCP.Server.Transport.Http @@ -187,6 +186,7 @@     Spec.BasicDerivation     Spec.JSONConversion     Spec.SchemaValidation+    Spec.UnicodeHandling     TestData     TestTypes @@ -203,6 +203,7 @@     QuickCheck,     aeson,     base,+    bytestring,     containers,     hspec,     mcp-server,

@@ -3,13 +3,12 @@  module MCP.Server   ( -- * Server Runtime-    runMcpServerStdIn-  , runMcpServerWithTransport+    runMcpServerStdio+  , runMcpServerHttp+  , runMcpServerHttpWithConfig -    -- * Transport Support-  , module MCP.Server.Transport.Types-  , module MCP.Server.Transport.Stdio-  , module MCP.Server.Transport.Http+    -- * Transport Configuration+  , HttpConfig(..)      -- * Utility Functions   , jsonValueToText@@ -23,9 +22,8 @@ import           Data.Text              (Text) import qualified Data.Text              as T -import           MCP.Server.Transport.Types-import           MCP.Server.Transport.Stdio-import           MCP.Server.Transport.Http+import           MCP.Server.Transport.Stdio (transportRunStdio)+import           MCP.Server.Transport.Http (HttpConfig(..), transportRunHttp, defaultHttpConfig) import           MCP.Server.Types  -- | Convert JSON Value to Text representation suitable for handlers@@ -41,19 +39,15 @@ jsonValueToText Null = "" jsonValueToText v = T.pack $ show v --- | 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+-- | Run an MCP server using STDIO transport+runMcpServerStdio :: McpServerInfo -> McpServerHandlers IO -> IO ()+runMcpServerStdio serverInfo handlers = transportRunStdio serverInfo handlers +-- | Run an MCP server using HTTP transport with default configuration+runMcpServerHttp :: McpServerInfo -> McpServerHandlers IO -> IO ()+runMcpServerHttp serverInfo handlers = transportRunHttp defaultHttpConfig serverInfo handlers --- | Run an MCP server using stdin/stdout-runMcpServerStdIn :: McpServerInfo -> McpServerHandlers IO -> IO ()-runMcpServerStdIn serverInfo handlers = do-  _ <- runMcpServerWithTransport StdioTransport serverInfo handlers-  return ()+-- | Run an MCP server using HTTP transport with custom configuration+runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO ()+runMcpServerHttpWithConfig config serverInfo handlers = transportRunHttp config serverInfo handlers 

@@ -3,10 +3,9 @@  module MCP.Server.Transport.Http   ( -- * HTTP Transport-    HttpTransport(..)-  , HttpConfig(..)-  , runMcpServerHttp-  , runMcpServerHttpWithConfig+    HttpConfig(..)+  , transportRunHttp+  , defaultHttpConfig   ) where  import           Control.Monad            (when)@@ -43,24 +42,14 @@   , 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+-- | Transport-specific implementation for HTTP+transportRunHttp :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO ()+transportRunHttp config serverInfo handlers = do   let settings = Warp.setHost (fromString $ httpHost config) $                  Warp.setPort (httpPort config) $                  Warp.defaultSettings

@@ -3,8 +3,7 @@  module MCP.Server.Transport.Stdio   ( -- * STDIO Transport-    StdioTransport(..)-  , runMcpServerStdio+    transportRunStdio   ) where  import           Control.Monad          (when)@@ -18,22 +17,12 @@  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+-- | Transport-specific implementation for STDIO+transportRunStdio :: (MonadIO m) => McpServerInfo -> McpServerHandlers m -> m ()+transportRunStdio serverInfo handlers = do   loop   where     loop = do@@ -56,4 +45,5 @@                     liftIO $ hFlush stdout                   Nothing -> liftIO $ hPutStrLn stderr $ "No response needed for: " ++ show (getMessageSummary message)         loop+ 

@@ -1,33 +0,0 @@-{-# 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

@@ -7,6 +7,7 @@ import qualified Spec.BasicDerivation import qualified Spec.SchemaValidation import qualified Spec.AdvancedDerivation+import qualified Spec.UnicodeHandling  main :: IO () main = hspec $ do@@ -15,3 +16,4 @@     Spec.BasicDerivation.spec     Spec.SchemaValidation.spec     Spec.AdvancedDerivation.spec+    Spec.UnicodeHandling.spec

@@ -0,0 +1,247 @@+{-# LANGUAGE OverloadedStrings #-}++module Spec.UnicodeHandling (spec) where++import           Data.Aeson+import qualified Data.Aeson.KeyMap      as KM+import qualified Data.Text              as T+import qualified Data.Text.Encoding     as TE+import qualified Data.ByteString.Lazy   as BSL+import           MCP.Server.Protocol+import           MCP.Server.Types+import           System.IO              (hSetEncoding, stderr, stdout, utf8)+import           Test.Hspec++spec :: Spec  +spec = describe "Unicode Handling" $ do+  describe "Unicode in Content Types" $ do+    it "handles Unicode in ContentText" $ do+      -- Set UTF-8 encoding for this test+      hSetEncoding stdout utf8+      hSetEncoding stderr utf8+      let content = ContentText "Test with Unicode: √π∞≈∑"+      let json = toJSON content+      case json of+        Object obj -> case KM.lookup "text" obj of+          Just (String txt) -> "√π∞≈∑" `T.isInfixOf` txt `shouldBe` True+          _ -> expectationFailure "Expected String in text field"+        _ -> expectationFailure "Expected Object"++    it "handles Unicode in ResourceContent" $ do+      uri <- case parseURI "test://unicode" of+        Just u -> return u+        Nothing -> fail "Invalid URI"+      let resource = ResourceText uri "text/plain" "Unicode content: ∀x∈ℝ: √x²=|x|"+      let json = toJSON resource+      case json of+        Object obj -> case KM.lookup "text" obj of+          Just (String txt) -> "∀x∈ℝ: √x²=|x|" `T.isInfixOf` txt `shouldBe` True+          _ -> expectationFailure "Expected String in text field"+        _ -> expectationFailure "Expected Object"++    it "handles square root symbol specifically" $ do+      let content = ContentText "Square root: √16 = 4"+      let json = toJSON content+      case json of+        Object obj -> case KM.lookup "text" obj of+          Just (String txt) -> txt `shouldBe` "Square root: √16 = 4"+          _ -> expectationFailure "Expected String in text field"+        _ -> expectationFailure "Expected Object"++  describe "JSON Encoding/Decoding with Unicode" $ do+    it "properly encodes and decodes Unicode content" $ do+      let originalContent = ContentText "Mathematical symbols: ∀∃∈∉∪∩⊆⊇√∑∏∞≤≥≠≈π∅Ω∆∇"+      let encoded = encode originalContent+      let decoded = eitherDecode encoded+      case decoded of+        Right decodedContent -> decodedContent `shouldBe` originalContent+        Left err -> expectationFailure $ "Failed to decode: " ++ err++    it "handles Unicode in JSON-RPC messages" $ do+      let response = ToolsCallResponse +            { toolsCallContent = [ContentText "Result: √16 = 4, π ≈ 3.14159"]+            , toolsCallIsError = Nothing+            }+      let encoded = encode response+      -- Just verify the JSON can be encoded and contains Unicode+      BSL.length encoded `shouldSatisfy` (> 0)++  describe "UTF-8 Text Encoding" $ do+    it "properly handles UTF-8 byte sequences" $ do+      let unicodeText = "Unicode: √∞≈π"+      let utf8Bytes = TE.encodeUtf8 unicodeText+      let decodedText = TE.decodeUtf8 utf8Bytes+      decodedText `shouldBe` unicodeText++    it "handles multibyte Unicode characters" $ do+      let characters = ["√", "∞", "π", "∑", "∏", "∀", "∃", "∈", "∉"]+      mapM_ (\char -> do+        let encoded = TE.encodeUtf8 char+        let decoded = TE.decodeUtf8 encoded+        decoded `shouldBe` char+        ) characters++  describe "Protocol Messages with Unicode" $ do+    it "handles Unicode in tool responses" $ do+      let response = ToolsCallResponse +            { toolsCallContent = [ContentText "Mathematical result: √(π²+e²) ≈ 4.53"]+            , toolsCallIsError = Nothing+            }+      let json = toJSON response+      -- Verify the JSON can be encoded and contains Unicode+      let encoded = encode json+      BSL.length encoded `shouldSatisfy` (> 0)++    it "handles Unicode in prompt responses" $ do+      let message = PromptMessage RoleUser (ContentText "Formula: E=mc², √(x²+y²)")+      let response = PromptsGetResponse+            { promptsGetDescription = Just "Mathematical formulas with symbols: ∀∃"+            , promptsGetMessages = [message]+            }+      let json = toJSON response+      let encoded = encode json+      BSL.length encoded `shouldSatisfy` (> 0)++    it "handles Unicode in error messages" $ do+      let mcpError = InvalidParams "Invalid formula: expected √x not ∛x"+      let json = toJSON mcpError+      case json of+        Object obj -> case KM.lookup "message" obj of+          Just (String msg) -> "√" `T.isInfixOf` msg `shouldBe` True+          _ -> expectationFailure "Expected message field"+        _ -> expectationFailure "Expected Object"++  describe "Manual Handler Tests with Unicode" $ do+    it "tests Unicode content through manual prompt handler" $ do+      let promptHandler :: PromptName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content)+          promptHandler "unicode_test" args = do+            case lookup "formula" args of+              Just formula -> return $ Right $ ContentText $ "Formula result: " <> formula <> " → √solution"+              Nothing -> return $ Left $ MissingRequiredParams "formula"+          promptHandler name _ = return $ Left $ InvalidPromptName name++      result <- promptHandler "unicode_test" [("formula", "x² + y² = z²")]+      case result of+        Right (ContentText txt) -> do+          txt `shouldSatisfy` T.isInfixOf "√"+          txt `shouldSatisfy` T.isInfixOf "²"+        _ -> expectationFailure "Expected successful ContentText with Unicode"++    it "tests Unicode content through manual tool handler" $ do+      let toolHandler :: ToolName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content)+          toolHandler "calculate" args = do+            case lookup "expression" args of+              Just expr -> return $ Right $ ContentText $ "Calculation: " <> expr <> " = √result"+              Nothing -> return $ Left $ MissingRequiredParams "expression"+          toolHandler name _ = return $ Left $ UnknownTool name++      result <- toolHandler "calculate" [("expression", "∫₀^∞ e^(-x²) dx")]+      case result of+        Right (ContentText txt) -> do+          txt `shouldSatisfy` T.isInfixOf "√"+          txt `shouldSatisfy` T.isInfixOf "∫"+        _ -> expectationFailure "Expected successful ContentText with Unicode"++    it "tests Unicode content through manual resource handler" $ do+      let resourceHandler :: URI -> IO (Either Error ResourceContent)+          resourceHandler uri = do+            let uriStr = show uri+            if "unicode" `T.isInfixOf` T.pack uriStr+              then return $ Right $ ResourceText uri "text/plain" "Unicode symbols: ∀∃∈∉√∑∏∞≤≥≠≈π"+              else return $ Left $ ResourceNotFound $ T.pack uriStr++      uri <- case parseURI "resource://unicode_test" of+        Just u -> return u+        Nothing -> fail "Invalid URI"+      +      result <- resourceHandler uri+      case result of+        Right (ResourceText _ _ txt) -> do+          txt `shouldSatisfy` T.isInfixOf "∀∃∈∉"+          txt `shouldSatisfy` T.isInfixOf "√∑∏∞"+        _ -> expectationFailure "Expected successful ResourceText with Unicode"++  describe "Integration test simulating MCP workflow" $ do+    it "handles complete Unicode workflow without Template Haskell" $ do+      -- Create manual handlers with Unicode content+      let promptListHandler = return [+            PromptDefinition +              { promptDefinitionName = "math_formula"+              , promptDefinitionDescription = "Generate mathematical formulas with Unicode: ∀∃∈√"+              , promptDefinitionArguments = [ArgumentDefinition "formula" "Mathematical expression" True]+              }+            ]+      +      let promptGetHandler name args = case name of+            "math_formula" -> case lookup "formula" args of+              Just formula -> return $ Right $ ContentText $ "Formula: " <> formula <> " → √(solution)"+              Nothing -> return $ Left $ MissingRequiredParams "formula"+            _ -> return $ Left $ InvalidPromptName name++      let resourceListHandler = return [+            ResourceDefinition+              { resourceDefinitionURI = "resource://unicode_symbols"+              , resourceDefinitionName = "unicode_symbols"+              , resourceDefinitionDescription = Just "Unicode mathematical symbols: ∀∃∈∉√∑"+              , resourceDefinitionMimeType = Just "text/plain"+              }+            ]++      let resourceReadHandler uri = +            if show uri == "resource://unicode_symbols"+              then return $ Right $ ResourceText uri "text/plain" "Symbols: ∀∃∈∉∪∩⊆⊇√∑∏∞≤≥≠≈π∅"+              else return $ Left $ ResourceNotFound $ T.pack $ show uri++      let toolListHandler = return [+            ToolDefinition+              { toolDefinitionName = "calculate"+              , toolDefinitionDescription = "Calculate with Unicode symbols: √∑∏"+              , toolDefinitionInputSchema = InputSchemaDefinitionObject+                  { properties = [("expression", InputSchemaDefinitionProperty "string" "Mathematical expression")]+                  , required = ["expression"]+                  }+              }+            ]++      let toolCallHandler name args = case name of+            "calculate" -> case lookup "expression" args of+              Just expr -> return $ Right $ ContentText $ "Result: " <> expr <> " → √answer"+              Nothing -> return $ Left $ MissingRequiredParams "expression"+            _ -> return $ Left $ UnknownTool name++      let handlers = McpServerHandlers+            { prompts = Just (promptListHandler, promptGetHandler)+            , resources = Just (resourceListHandler, resourceReadHandler)+            , tools = Just (toolListHandler, toolCallHandler)+            }++      -- Test that all handlers work with Unicode+      promptList <- fst $ case prompts handlers of Just h -> h; Nothing -> error "No prompts"+      promptList `shouldSatisfy` (not . null)++      resourceList <- fst $ case resources handlers of Just h -> h; Nothing -> error "No resources"+      resourceList `shouldSatisfy` (not . null)++      toolList <- fst $ case tools handlers of Just h -> h; Nothing -> error "No tools"+      toolList `shouldSatisfy` (not . null)++      -- Test actual Unicode handling+      promptResult <- snd (case prompts handlers of Just h -> h; Nothing -> error "No prompts") "math_formula" [("formula", "√(x²+y²)")]+      case promptResult of+        Right (ContentText txt) -> txt `shouldSatisfy` T.isInfixOf "√"+        _ -> expectationFailure "Expected successful prompt result"++      uri <- case parseURI "resource://unicode_symbols" of+        Just u -> return u+        Nothing -> fail "Invalid URI"+      resourceResult <- snd (case resources handlers of Just h -> h; Nothing -> error "No resources") uri+      case resourceResult of+        Right (ResourceText _ _ txt) -> txt `shouldSatisfy` T.isInfixOf "∀∃∈∉"+        _ -> expectationFailure "Expected successful resource result"++      toolResult <- snd (case tools handlers of Just h -> h; Nothing -> error "No tools") "calculate" [("expression", "∫₀^∞ e^(-x²) dx = √π/2")]+      case toolResult of+        Right (ContentText txt) -> do+          txt `shouldSatisfy` T.isInfixOf "√"+          txt `shouldSatisfy` T.isInfixOf "∫"+        _ -> expectationFailure "Expected successful tool result"