mcp-server 0.1.0.16 → 0.1.0.17
raw patch · 16 files changed
+228/−148 lines, 16 filesdep −vectordep ~aesondep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies removed: vector
Dependency ranges changed: aeson, base, containers, http-types, network-uri, template-haskell, text, wai, warp
API changes (from Hackage documentation)
Files
- app/Main.hs +0/−7
- mcp-server.cabal +11/−33
- src/MCP/Server.hs +1/−3
- src/MCP/Server/Derive.hs +8/−8
- src/MCP/Server/Handlers.hs +12/−9
- src/MCP/Server/JsonRpc.hs +2/−2
- src/MCP/Server/Transport/Http.hs +4/−6
- src/MCP/Server/Transport/Stdio.hs +1/−2
- test/HspecMain.hs +2/−0
- test/Spec/AdvancedDerivation.hs +18/−20
- test/Spec/BasicDerivation.hs +11/−12
- test/Spec/JSONConversion.hs +5/−5
- test/Spec/ProtocolVersionNegotiation.hs +114/−0
- test/Spec/SchemaValidation.hs +16/−18
- test/TestData.hs +7/−7
- test/TestTypes.hs +16/−16
− app/Main.hs
@@ -1,7 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--main :: IO ()-main = do- putStrLn "Hello, World!"
mcp-server.cabal view
@@ -15,7 +15,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.16+version: 0.1.0.17 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.@@ -54,7 +54,9 @@ location: https://github.com/drshade/haskell-mcp-server.git common warnings- ghc-options: -Wall+ ghc-options:+ -Wall+ -Wunused-packages library -- Import common warning flags.@@ -76,45 +78,22 @@ -- other-extensions: -- Other library packages from which modules are imported. build-depends:- aeson >=2.0 && <3.0,- base >=4.20.0 && <4.22,+ aeson >=2 && <3,+ base >=4.20 && <4.23, bytestring >=0.10 && <0.13, containers >=0.6 && <0.9,- http-types >=0.12 && <1.0,+ http-types >=0.12 && <1, network-uri >=2.6 && <2.8, template-haskell >=2.16 && <2.25,- text >=1.2 && <3.0,- vector >=0.12 && <1.0,- wai >=3.2 && <4.0,- warp >=3.3 && <4.0,+ text >=1.2 && <3,+ wai >=3.2 && <4,+ warp >=3.3 && <4, -- Directories containing source files. hs-source-dirs: src -- Base language which the package is written in. default-language: GHC2024 -executable haskell-mcp-server- -- 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:- -- LANGUAGE extensions used by modules in this package.- -- other-extensions:- -- Other library packages from which modules are imported.- build-depends:- base,- containers,- mcp-server,- network-uri,- text,-- -- Directories containing source files.- hs-source-dirs: app- -- Base language which the package is written in.- default-language: GHC2024- executable simple-example -- Import common warning flags. import: warnings@@ -185,6 +164,7 @@ Spec.AdvancedDerivation Spec.BasicDerivation Spec.JSONConversion+ Spec.ProtocolVersionNegotiation Spec.SchemaValidation Spec.UnicodeHandling TestData@@ -204,9 +184,7 @@ aeson, base, bytestring,- containers, hspec, mcp-server, network-uri,- template-haskell, text,
src/MCP/Server.hs view
@@ -17,7 +17,6 @@ , module MCP.Server.Types ) where -import Control.Monad.IO.Class (MonadIO) import Data.Aeson import Data.Text (Text) import qualified Data.Text as T@@ -29,7 +28,7 @@ -- | Convert JSON Value to Text representation suitable for handlers jsonValueToText :: Value -> Text jsonValueToText (String t) = t-jsonValueToText (Number n) = +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)@@ -50,4 +49,3 @@ -- | Run an MCP server using HTTP transport with custom configuration runMcpServerHttpWithConfig :: HttpConfig -> McpServerInfo -> McpServerHandlers IO -> IO () runMcpServerHttpWithConfig config serverInfo handlers = transportRunHttp config serverInfo handlers-
src/MCP/Server/Derive.hs view
@@ -61,11 +61,11 @@ -- | Derive prompt handlers from a data type -- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt) derivePromptHandler :: Name -> Name -> Q Exp-derivePromptHandler typeName handlerName = +derivePromptHandler typeName handlerName = derivePromptHandlerWithDescription typeName handlerName [] mkPromptDefWithDescription :: [(String, String)] -> Con -> Q Exp-mkPromptDefWithDescription descriptions con = +mkPromptDefWithDescription descriptions con = case con of NormalC name [] -> do let promptName = T.pack . toSnakeCase . nameBase $ name@@ -171,7 +171,7 @@ [| do content <- $(varE handlerName') $(return outerConstructorApp) pure $ Right content |]- + buildNestedFieldValidationWithConstructor outerConName handlerName' paramType' ((fieldName, _, fieldType):remainingFields) depth = do let fieldStr = nameBase fieldName let (isOptional, innerType) = case fieldType of@@ -231,9 +231,9 @@ ConT typeName -> do info <- reify typeName case info of- TyConI (DataD _ _ _ _ [RecC _ fields] _) -> + TyConI (DataD _ _ _ _ [RecC _ fields] _) -> return fields- TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> + TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> extractFieldsFromParamType innerType _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType@@ -354,7 +354,7 @@ -- | Derive resource handlers from a data type -- Usage: $(deriveResourceHandler ''MyResource 'handleResource) deriveResourceHandler :: Name -> Name -> Q Exp-deriveResourceHandler typeName handlerName = +deriveResourceHandler typeName handlerName = deriveResourceHandlerWithDescription typeName handlerName [] mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp@@ -413,11 +413,11 @@ -- | Derive tool handlers from a data type -- Usage: $(deriveToolHandler ''MyTool 'handleTool) deriveToolHandler :: Name -> Name -> Q Exp-deriveToolHandler typeName handlerName = +deriveToolHandler typeName handlerName = deriveToolHandlerWithDescription typeName handlerName [] mkToolDefWithDescription :: [(String, String)] -> Con -> Q Exp-mkToolDefWithDescription descriptions con = +mkToolDefWithDescription descriptions con = case con of NormalC name [] -> do let toolName = T.pack . toSnakeCase . nameBase $ name
src/MCP/Server/Handlers.hs view
@@ -5,7 +5,7 @@ ( -- * Core Message Handling handleMcpMessage , jsonValueToText- + -- * Individual Request Handlers , handleInitialize , handlePing@@ -15,11 +15,11 @@ , handleResourcesRead , handleToolsList , handleToolsCall- + -- * Protocol Support , validateProtocolVersion , getMessageSummary- + -- * Error Conversion , errorCodeFromMcpError , errorMessageFromMcpError@@ -39,7 +39,7 @@ -- | Convert JSON Value to Text representation suitable for handlers jsonValueToText :: Value -> Text jsonValueToText (String t) = t-jsonValueToText (Number n) = +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)@@ -51,18 +51,21 @@ -- | Extract a brief summary of a JSON-RPC message for logging getMessageSummary :: JsonRpcMessage -> String-getMessageSummary (JsonRpcMessageRequest req) = +getMessageSummary (JsonRpcMessageRequest req) = "Request[" ++ show (requestId req) ++ "] " ++ T.unpack (requestMethod req)-getMessageSummary (JsonRpcMessageNotification notif) = +getMessageSummary (JsonRpcMessageNotification notif) = "Notification " ++ T.unpack (notificationMethod notif)-getMessageSummary (JsonRpcMessageResponse resp) = +getMessageSummary (JsonRpcMessageResponse resp) = "Response[" ++ show (responseId resp) ++ "]" -- | Validate protocol version and return negotiated version+-- Per MCP spec: "If the server supports the requested protocol version,+-- it MUST respond with the same version. Otherwise, the server MUST respond+-- with another protocol version it supports." validateProtocolVersion :: Text -> Either Text Text validateProtocolVersion clientVersion- | clientVersion == protocolVersion = Right protocolVersion -- Exact match (2025-06-18)- | otherwise = Left $ "Unsupported protocol version: " <> clientVersion <> ". Server only supports: 2025-06-18"+ | clientVersion == protocolVersion = Right protocolVersion -- Exact match+ | otherwise = Right protocolVersion -- Negotiate: return server's supported version -- | Handle an MCP message and return a response if needed handleMcpMessage :: (MonadIO m)
src/MCP/Server/JsonRpc.hs view
@@ -9,7 +9,7 @@ , JsonRpcNotification(..) , JsonRpcMessage(..) , RequestId(..)- + -- * JSON-RPC Functions , makeSuccessResponse , makeErrorResponse@@ -95,7 +95,7 @@ toJSON resp = object $ [ "jsonrpc" .= responseJsonrpc resp , "id" .= responseId resp- ] ++ + ] ++ maybe [] (\r -> ["result" .= r]) (responseResult resp) ++ maybe [] (\e -> ["error" .= e]) (responseError resp)
src/MCP/Server/Transport/Http.hs view
@@ -78,7 +78,7 @@ status400 [("Content-Type", "application/json")] (encode $ object ["error" .= ("Missing required MCP-Protocol-Version header" :: Text)])- Just headerValue -> + Just headerValue -> if TE.decodeUtf8 headerValue /= "2025-06-18" then do logVerbose config $ "Request rejected: Invalid protocol version: " ++ show headerValue respond $ Wai.responseLBS@@ -168,9 +168,7 @@ 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", "*")] + respond $ Wai.responseLBS+ status200+ [("Content-Type", "application/json"), ("Access-Control-Allow-Origin", "*")] "{}"--
src/MCP/Server/Transport/Stdio.hs view
@@ -13,7 +13,7 @@ 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 System.IO (hFlush, stderr, stdout) import MCP.Server.Handlers import MCP.Server.JsonRpc@@ -52,4 +52,3 @@ liftIO $ hFlush stdout Nothing -> liftIO $ TIO.hPutStrLn stderr $ "No response needed for: " <> T.pack (show (getMessageSummary message)) loop-
test/HspecMain.hs view
@@ -8,6 +8,7 @@ import qualified Spec.SchemaValidation import qualified Spec.AdvancedDerivation import qualified Spec.UnicodeHandling+import qualified Spec.ProtocolVersionNegotiation main :: IO () main = hspec $ do@@ -17,3 +18,4 @@ Spec.SchemaValidation.spec Spec.AdvancedDerivation.spec Spec.UnicodeHandling.spec+ Spec.ProtocolVersionNegotiation.spec
test/Spec/AdvancedDerivation.hs view
@@ -27,7 +27,7 @@ -- Helper functions for advanced testing findToolByName :: Text -> [ToolDefinition] -> ToolDefinition-findToolByName toolName toolDefs = +findToolByName toolName toolDefs = case filter (\def -> toolDefinitionName def == toolName) toolDefs of [def] -> def [] -> error $ "Tool not found: " ++ T.unpack toolName@@ -36,10 +36,9 @@ assertSchemaHasProperties :: [Text] -> ToolDefinition -> IO () assertSchemaHasProperties expectedProps toolDef = do case toolDefinitionInputSchema toolDef of- InputSchemaDefinitionObject props _ -> + InputSchemaDefinitionObject props _ -> let propNames = map fst props in all (`elem` propNames) expectedProps `shouldBe` True- other -> expectationFailure $ "Expected InputSchemaDefinitionObject but got: " ++ show other assertToolCallResult :: (ToolCallHandler IO) -> Text -> [(Text, Text)] -> Text -> IO () assertToolCallResult handler toolName args expectedContent = do@@ -56,28 +55,27 @@ assertPropertyHasDescription :: Text -> Text -> ToolDefinition -> IO () assertPropertyHasDescription propName expectedDesc toolDef = do case toolDefinitionInputSchema toolDef of- InputSchemaDefinitionObject props _ -> + InputSchemaDefinitionObject props _ -> case lookup propName props of Just prop -> propertyDescription prop `shouldBe` expectedDesc Nothing -> expectationFailure $ "Property not found: " ++ T.unpack propName- other -> expectationFailure $ "Expected InputSchemaDefinitionObject but got: " ++ show other spec :: Spec spec = describe "Advanced Template Haskell Derivation" $ do- + describe "Separate Parameter Types" $ do it "generates correct schema for separate parameter tools" $ do let (listHandler, _) = testSeparateParamsToolHandlers toolDefs <- listHandler- + -- Test GetValue tool schema let getValueDef = findToolByName "get_value" toolDefs assertSchemaHasProperties ["_gvpKey"] getValueDef- - -- Test SetValue tool schema ++ -- Test SetValue tool schema let setValueDef = findToolByName "set_value" toolDefs assertSchemaHasProperties ["_svpKey", "_svpValue"] setValueDef- + forM_ separateParamsTestCases $ \testCase -> it (T.unpack $ sepTestDescription testCase) $ do let (_, callHandler) = testSeparateParamsToolHandlers@@ -87,10 +85,10 @@ it "generates correct schema for recursive parameter tools" $ do let (listHandler, _) = testRecursiveToolHandlers toolDefs <- listHandler- + let processDataDef = findToolByName "process_data" toolDefs assertSchemaHasProperties ["_ipName", "_ipAge"] processDataDef- + forM_ recursiveParamsTestCases $ \testCase -> it (T.unpack $ recTestDescription testCase) $ do let (_, callHandler) = testRecursiveToolHandlers@@ -100,20 +98,20 @@ it "applies correct tool descriptions for separate parameter tools" $ do let (listHandler, _) = testSeparateParamsToolHandlersWithDescriptions toolDefs <- listHandler- + let getValueDef = findToolByName "get_value" toolDefs assertToolHasDescription "get_value" "Retrieves a value from the key-value store" getValueDef- + let setValueDef = findToolByName "set_value" toolDefs assertToolHasDescription "set_value" "Sets a value in the key-value store" setValueDef- + it "applies correct field descriptions for separate parameter tools" $ do let (listHandler, _) = testSeparateParamsToolHandlersWithDescriptions toolDefs <- listHandler- + let getValueDef = findToolByName "get_value" toolDefs assertPropertyHasDescription "_gvpKey" "The key to retrieve the value for" getValueDef- + let setValueDef = findToolByName "set_value" toolDefs assertPropertyHasDescription "_svpKey" "The key to set the value for" setValueDef assertPropertyHasDescription "_svpValue" "The value to store" setValueDef@@ -122,14 +120,14 @@ it "applies correct descriptions for recursive parameter tools" $ do let (listHandler, _) = testRecursiveToolHandlersWithDescriptions toolDefs <- listHandler- + let processDataDef = findToolByName "process_data" toolDefs assertToolHasDescription "process_data" "Processes user data with age validation" processDataDef- + it "applies correct field descriptions for recursive parameters" $ do let (listHandler, _) = testRecursiveToolHandlersWithDescriptions toolDefs <- listHandler- + let processDataDef = findToolByName "process_data" toolDefs assertPropertyHasDescription "_ipName" "The person's full name" processDataDef assertPropertyHasDescription "_ipAge" "The person's age in years" processDataDef
test/Spec/BasicDerivation.hs view
@@ -8,7 +8,6 @@ import qualified Data.Text as T import MCP.Server import MCP.Server.Derive-import Network.URI (parseURI) import Test.Hspec import TestTypes import TestData@@ -35,12 +34,12 @@ shouldContainText action expectedSubstring = do result <- action case result of- Right (ContentText content) -> + Right (ContentText content) -> T.isInfixOf expectedSubstring content `shouldBe` True other -> expectationFailure $ "Expected ContentText containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other testPromptCall :: PromptGetHandler IO -> Text -> [(Text, Text)] -> Text -> IO ()-testPromptCall handler name args expected = +testPromptCall handler name args expected = shouldReturnContentText (handler name args) expected testResourceCall :: ResourceReadHandler IO -> String -> Text -> IO ()@@ -55,31 +54,31 @@ Nothing -> expectationFailure $ "Failed to parse URI: " ++ uriString testToolCall :: ToolCallHandler IO -> Text -> [(Text, Text)] -> Text -> IO ()-testToolCall handler name args expected = +testToolCall handler name args expected = shouldReturnContentText (handler name args) expected spec :: Spec spec = describe "Basic Template Haskell Derivation" $ do- + describe "Prompt derivation" $ do let (_, getHandler) = testPromptHandlers- + forM_ promptTestCases $ \testCase ->- it (T.unpack $ testDescription testCase) $ + it (T.unpack $ testDescription testCase) $ testPromptCall getHandler (promptName testCase) (promptArgs testCase) (expectedResult testCase) describe "Resource derivation" $ do let (_, readHandler) = testResourceHandlers- + forM_ resourceTestCases $ \testCase -> it (T.unpack $ resourceTestDescription testCase) $ do case parseURI (T.unpack $ TestData.resourceUri testCase) of- Just uri -> + Just uri -> if useSubstringMatch testCase then do result <- readHandler uri case result of- Right (ResourceText _ _ content) -> + Right (ResourceText _ _ content) -> T.isInfixOf (resourceExpectedContent testCase) content `shouldBe` True Right (ResourceBlob _ _ _) -> expectationFailure "Expected ResourceText but got ResourceBlob" Left err -> expectationFailure $ "Expected success but got error: " ++ show err@@ -88,7 +87,7 @@ describe "Tool derivation" $ do let (_, callHandler) = testToolHandlers- + forM_ toolTestCases $ \testCase ->- it (T.unpack $ toolTestDescription testCase) $ + it (T.unpack $ toolTestDescription testCase) $ testToolCall callHandler (toolName testCase) (toolArgs testCase) (toolExpectedResult testCase)
test/Spec/JSONConversion.hs view
@@ -2,7 +2,7 @@ module Spec.JSONConversion (spec) where -import Data.Aeson (Value(..), toJSON)+import Data.Aeson (toJSON) import Data.Text (Text) import qualified Data.Text as T import MCP.Server@@ -18,7 +18,7 @@ spec = describe "JSON Type Conversion" $ do describe "Property-based tests" $ do it "round-trips integers correctly" $ property prop_intRoundTrip- it "round-trips booleans correctly" $ property prop_boolRoundTrip + it "round-trips booleans correctly" $ property prop_boolRoundTrip it "round-trips text correctly" $ property prop_textRoundTrip describe "Manual conversion tests" $ do@@ -27,14 +27,14 @@ -- Fixed property-based tests (no more 'error' usage) prop_intRoundTrip :: Int -> Bool-prop_intRoundTrip i = +prop_intRoundTrip i = let jsonVal = toJSON i textVal = jsonValueToText jsonVal parsed = readMaybe (T.unpack textVal) in parsed == Just i prop_boolRoundTrip :: Bool -> Bool-prop_boolRoundTrip b = +prop_boolRoundTrip b = let jsonVal = toJSON b textVal = jsonValueToText jsonVal parsed = case T.toLower textVal of@@ -44,7 +44,7 @@ in parsed == Just b prop_textRoundTrip :: Text -> Bool-prop_textRoundTrip t = +prop_textRoundTrip t = let jsonVal = toJSON t textVal = jsonValueToText jsonVal in textVal == t
+ test/Spec/ProtocolVersionNegotiation.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}++module Spec.ProtocolVersionNegotiation (spec) where++import Data.Aeson (Value(..), object, (.=))+import qualified Data.Aeson.KeyMap as KM+import Test.Hspec++import MCP.Server.Handlers (handleInitialize)+import MCP.Server.JsonRpc (JsonRpcRequest(..), RequestId(..), JsonRpcResponse(..), JsonRpcError(..))+import MCP.Server.Types (McpServerInfo(..))++-- | Test that server performs proper version negotiation according to MCP spec+--+-- From the spec: "If the server supports the requested protocol version,+-- it MUST respond with the same version. Otherwise, the server MUST respond+-- with another protocol version it supports."+--+-- This means if a client sends protocolVersion "2025-11-25" and the server+-- only supports "2025-06-18", the server should respond with:+-- {+-- "jsonrpc": "2.0",+-- "id": 0,+-- "result": {+-- "protocolVersion": "2025-06-18",+-- ...+-- }+-- }+--+-- NOT with an error like: {"jsonrpc":"2.0","id":0,"error":{"code":-32602,...}}+spec :: Spec+spec = describe "Protocol Version Negotiation" $ do+ let testServerInfo = McpServerInfo+ { serverName = "Test Server"+ , serverVersion = "1.0.0"+ , serverInstructions = "Test server for version negotiation"+ }++ it "Server should respond with supported version when client requests unsupported version" $ do+ -- Create an initialize request with a newer protocol version+ -- that the library doesn't support+ let params = object+ [ "protocolVersion" .= String "2025-11-25" -- Newer than library supports+ , "capabilities" .= object []+ , "clientInfo" .= object+ [ "name" .= String "test-client"+ , "version" .= String "1.0.0"+ ]+ ]+ request = JsonRpcRequest+ { requestJsonrpc = "2.0"+ , requestId = RequestIdNumber 0+ , requestMethod = "initialize"+ , requestParams = Just params+ }++ -- Call handleInitialize directly (it runs in IO monad)+ response <- handleInitialize testServerInfo request++ -- Check if it's an error response+ case responseError response of+ Just err -> do+ -- This is the bug! Server returned an error instead of negotiating+ expectationFailure $+ "Server returned error instead of negotiating version. " +++ "Per MCP spec, server MUST respond with a supported version, " +++ "not an error. Error was: " ++ show (errorMessage err)+ Nothing -> do+ -- Good! Now verify the result has protocolVersion+ case responseResult response of+ Nothing -> expectationFailure "Response has no result"+ Just (Object result) -> do+ case KM.lookup "protocolVersion" result of+ Just (String version) -> do+ -- The server should have responded with its supported version+ -- We expect "2025-06-18" based on the library+ version `shouldBe` "2025-06-18"+ Just other -> expectationFailure $ "protocolVersion is not a string: " ++ show other+ Nothing -> expectationFailure "Response missing protocolVersion"+ Just other -> expectationFailure $ "Result is not an object: " ++ show other++ it "Server should respond with same version when client requests supported version" $ do+ -- This test verifies the happy path: client requests "2025-06-18"+ -- and server responds with "2025-06-18"+ let params = object+ [ "protocolVersion" .= String "2025-06-18" -- Library's supported version+ , "capabilities" .= object []+ , "clientInfo" .= object+ [ "name" .= String "test-client"+ , "version" .= String "1.0.0"+ ]+ ]+ request = JsonRpcRequest+ { requestJsonrpc = "2.0"+ , requestId = RequestIdNumber 0+ , requestMethod = "initialize"+ , requestParams = Just params+ }++ response <- handleInitialize testServerInfo request++ -- Check it's not an error+ case responseError response of+ Just err -> expectationFailure $ "Unexpected error: " ++ show (errorMessage err)+ Nothing -> do+ -- Verify protocolVersion matches+ case responseResult response of+ Nothing -> expectationFailure "Response has no result"+ Just (Object result) -> do+ case KM.lookup "protocolVersion" result of+ Just (String version) -> version `shouldBe` "2025-06-18"+ Just other -> expectationFailure $ "protocolVersion is not a string: " ++ show other+ Nothing -> expectationFailure "Response missing protocolVersion"+ Just other -> expectationFailure $ "Result is not an object: " ++ show other
test/Spec/SchemaValidation.hs view
@@ -21,20 +21,19 @@ -- Helper functions for schema validation findTool :: Text -> [ToolDefinition] -> ToolDefinition-findTool toolName toolDefs = +findTool toolName toolDefs = case filter (\def -> toolDefinitionName def == toolName) toolDefs of [def] -> def [] -> error $ "Tool not found: " ++ T.unpack toolName _ -> error $ "Multiple tools found with name: " ++ T.unpack toolName getProperty :: Text -> ToolDefinition -> InputSchemaDefinitionProperty-getProperty propertyName toolDef = +getProperty propertyName toolDef = case toolDefinitionInputSchema toolDef of- InputSchemaDefinitionObject props _ -> + InputSchemaDefinitionObject props _ -> case lookup propertyName props of Just prop -> prop Nothing -> error $ "Property not found: " ++ T.unpack propertyName- other -> error $ "Expected InputSchemaDefinitionObject but got: " ++ show other assertToolExists :: Text -> [ToolDefinition] -> IO () assertToolExists toolName toolDefs = do@@ -53,31 +52,30 @@ assertRequiredFields :: [Text] -> ToolDefinition -> IO () assertRequiredFields expectedFields toolDef = do case toolDefinitionInputSchema toolDef of- InputSchemaDefinitionObject _ required -> + InputSchemaDefinitionObject _ required -> all (`elem` required) expectedFields `shouldBe` True- other -> expectationFailure $ "Expected InputSchemaDefinitionObject but got: " ++ show other assertToolDescription :: ToolDefinition -> Text -> IO ()-assertToolDescription toolDef expectedDesc = +assertToolDescription toolDef expectedDesc = toolDefinitionDescription toolDef `shouldBe` expectedDesc spec :: Spec spec = describe "Schema Validation and Custom Descriptions" $ do- + describe "Schema Generation" $ do let (listHandler, _) = testToolHandlers- + forM_ schemaTestCases $ \testCase -> do it (T.unpack $ schemaTestDescription testCase) $ do toolDefs <- listHandler- + assertToolExists (schemaToolName testCase) toolDefs let toolDef = findTool (schemaToolName testCase) toolDefs- + -- Validate property types forM_ (expectedProperties testCase) $ \(propName, expectedType) -> assertHasProperty propName expectedType toolDef- + -- Validate required fields assertRequiredFields (requiredFields testCase) toolDef @@ -85,22 +83,22 @@ it "applies correct tool descriptions" $ do let (listHandler, _) = testToolHandlersWithDescriptions toolDefs <- listHandler- + assertToolExists "echo" toolDefs let echoDef = findTool "echo" toolDefs assertToolDescription echoDef "Echoes the input text back to the user"- + assertToolExists "calculate" toolDefs let calculateDef = findTool "calculate" toolDefs assertToolDescription calculateDef "Performs mathematical calculations"- + it "applies correct field descriptions for Calculate tool" $ do let (listHandler, _) = testToolHandlersWithDescriptions toolDefs <- listHandler- + assertToolExists "calculate" toolDefs let calculateDef = findTool "calculate" toolDefs- + assertPropertyDescription "operation" calculateDef "The mathematical operation to perform"- assertPropertyDescription "x" calculateDef "The first number" + assertPropertyDescription "x" calculateDef "The first number" assertPropertyDescription "y" calculateDef "The second number"
test/TestData.hs view
@@ -1,22 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} -module TestData +module TestData ( -- * Prompt Test Data promptTestCases , PromptTestCase(..)- - -- * Resource Test Data ++ -- * Resource Test Data , resourceTestCases , ResourceTestCase(..)- + -- * Tool Test Data , toolTestCases , ToolTestCase(..)- + -- * Schema Test Data , schemaTestCases , SchemaTestCase(..)- + -- * Advanced Derivation Test Data , separateParamsTestCases , recursiveParamsTestCases@@ -34,7 +34,7 @@ , testDescription :: Text } deriving (Show, Eq) --- | Test case for resource derivation +-- | Test case for resource derivation data ResourceTestCase = ResourceTestCase { resourceUri :: Text , resourceExpectedContent :: Text
test/TestTypes.hs view
@@ -4,7 +4,7 @@ import Data.Text (Text) import qualified Data.Text as T-import MCP.Server (Content(..), ResourceContent(..), parseURI)+import MCP.Server (Content(..), ResourceContent(..)) import Network.URI (URI) -- Test data types for end-to-end testing@@ -48,53 +48,53 @@ -- Handler functions handleTestPrompt :: TestPrompt -> IO Content-handleTestPrompt (SimplePrompt msg) = +handleTestPrompt (SimplePrompt msg) = pure $ ContentText $ "Simple prompt: " <> msg-handleTestPrompt (ComplexPrompt title prio urgent) = +handleTestPrompt (ComplexPrompt title prio urgent) = pure $ ContentText $ "Complex prompt: " <> title <> " (priority=" <> T.pack (show prio) <> ", urgent=" <> T.pack (show urgent) <> ")"-handleTestPrompt (OptionalPrompt req opt) = +handleTestPrompt (OptionalPrompt req opt) = pure $ ContentText $ "Optional prompt: " <> req <> maybe "" ((" optional=" <>) . T.pack . show) opt handleTestResource :: URI -> TestResource -> IO ResourceContent-handleTestResource uri ConfigFile = +handleTestResource uri ConfigFile = pure $ ResourceText uri "text/plain" "Config file contents: debug=true, timeout=30"-handleTestResource uri DatabaseConnection = +handleTestResource uri DatabaseConnection = pure $ ResourceText uri "text/plain" "Database at localhost:5432"-handleTestResource uri UserProfile = +handleTestResource uri UserProfile = pure $ ResourceText uri "text/plain" "User profile for ID 123" handleTestTool :: TestTool -> IO Content-handleTestTool (Echo text) = +handleTestTool (Echo text) = pure $ ContentText $ "Echo: " <> text-handleTestTool (Calculate op x y) = +handleTestTool (Calculate op x y) = let result = case op of "add" -> x + y "multiply" -> x * y "subtract" -> x - y _ -> 0 in pure $ ContentText $ T.pack (show result)-handleTestTool (Toggle flag) = +handleTestTool (Toggle flag) = pure $ ContentText $ "Flag is now: " <> T.pack (show (not flag))-handleTestTool (Search query limit caseSens) = +handleTestTool (Search query limit caseSens) = pure $ ContentText $ "Search results for '" <> query <> "'" <> maybe "" ((" (limit=" <>) . (<> ")") . T.pack . show) limit <> maybe "" ((" (case-sensitive=" <>) . (<> ")") . T.pack . show) caseSens -- Handler for separate params tool handleSeparateParamsTool :: SeparateParamsTool -> IO Content-handleSeparateParamsTool (GetValue (GetValueParams key)) = +handleSeparateParamsTool (GetValue (GetValueParams key)) = pure $ ContentText $ "Getting value for key: " <> key-handleSeparateParamsTool (SetValue (SetValueParams key value)) = +handleSeparateParamsTool (SetValue (SetValueParams key value)) = pure $ ContentText $ "Setting " <> key <> " = " <> value -- Handler for recursive tool handleRecursiveTool :: RecursiveTool -> IO Content-handleRecursiveTool (ProcessData (MiddleParams (InnerParams name age))) = +handleRecursiveTool (ProcessData (MiddleParams (InnerParams name age))) = pure $ ContentText $ "Processing data for " <> name <> " (age " <> T.pack (show age) <> ")" -- Test descriptions for custom description functionality testDescriptions :: [(String, String)]-testDescriptions = +testDescriptions = [ ("Echo", "Echoes the input text back to the user") , ("Calculate", "Performs mathematical calculations") , ("text", "The text to echo back")@@ -105,7 +105,7 @@ -- Test descriptions for separate parameter types separateParamsDescriptions :: [(String, String)]-separateParamsDescriptions = +separateParamsDescriptions = [ ("GetValue", "Retrieves a value from the key-value store") , ("SetValue", "Sets a value in the key-value store") , ("_gvpKey", "The key to retrieve the value for")