diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -main :: IO () -main = do - putStrLn "Hello, World!" 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.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, diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -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 - diff --git a/src/MCP/Server/Derive.hs b/src/MCP/Server/Derive.hs --- a/src/MCP/Server/Derive.hs +++ b/src/MCP/Server/Derive.hs @@ -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 diff --git a/src/MCP/Server/Handlers.hs b/src/MCP/Server/Handlers.hs --- a/src/MCP/Server/Handlers.hs +++ b/src/MCP/Server/Handlers.hs @@ -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) diff --git a/src/MCP/Server/JsonRpc.hs b/src/MCP/Server/JsonRpc.hs --- a/src/MCP/Server/JsonRpc.hs +++ b/src/MCP/Server/JsonRpc.hs @@ -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) diff --git a/src/MCP/Server/Transport/Http.hs b/src/MCP/Server/Transport/Http.hs --- a/src/MCP/Server/Transport/Http.hs +++ b/src/MCP/Server/Transport/Http.hs @@ -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", "*")] "{}" - - diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs --- a/src/MCP/Server/Transport/Stdio.hs +++ b/src/MCP/Server/Transport/Stdio.hs @@ -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 - diff --git a/test/HspecMain.hs b/test/HspecMain.hs --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -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 diff --git a/test/Spec/AdvancedDerivation.hs b/test/Spec/AdvancedDerivation.hs --- a/test/Spec/AdvancedDerivation.hs +++ b/test/Spec/AdvancedDerivation.hs @@ -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 diff --git a/test/Spec/BasicDerivation.hs b/test/Spec/BasicDerivation.hs --- a/test/Spec/BasicDerivation.hs +++ b/test/Spec/BasicDerivation.hs @@ -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) diff --git a/test/Spec/JSONConversion.hs b/test/Spec/JSONConversion.hs --- a/test/Spec/JSONConversion.hs +++ b/test/Spec/JSONConversion.hs @@ -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 diff --git a/test/Spec/ProtocolVersionNegotiation.hs b/test/Spec/ProtocolVersionNegotiation.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ProtocolVersionNegotiation.hs @@ -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 diff --git a/test/Spec/SchemaValidation.hs b/test/Spec/SchemaValidation.hs --- a/test/Spec/SchemaValidation.hs +++ b/test/Spec/SchemaValidation.hs @@ -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" diff --git a/test/TestData.hs b/test/TestData.hs --- a/test/TestData.hs +++ b/test/TestData.hs @@ -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 diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -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")