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.8 +version: 0.1.0.9 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package. @@ -74,11 +74,11 @@ -- Other library packages from which modules are imported. build-depends: aeson >=2.0 && <3.0, - base ^>=4.20.0.0, + base >=4.20.0 && <4.22, bytestring >=0.10 && <0.13, containers >=0.6 && <0.8, network-uri >=2.6 && <2.8, - template-haskell >=2.16 && <2.23, + template-haskell >=2.16 && <2.24, text >=1.2 && <3.0, -- Directories containing source files. @@ -97,11 +97,11 @@ -- other-extensions: -- Other library packages from which modules are imported. build-depends: - base ^>=4.20.0.0, - containers >=0.6 && <0.8, + base, + containers, mcp-server, - network-uri >=2.6 && <2.8, - text >=1.2 && <3.0, + network-uri, + text, -- Directories containing source files. hs-source-dirs: app @@ -119,9 +119,9 @@ -- other-extensions: -- Other library packages from which modules are imported. build-depends: - base ^>=4.20.0.0, + base, mcp-server, - text >=1.2 && <3.0, + text, -- Directories containing source files. hs-source-dirs: examples/Simple @@ -139,9 +139,9 @@ -- other-extensions: -- Other library packages from which modules are imported. build-depends: - base ^>=4.20.0.0, + base, mcp-server, - text >=1.2 && <3.0, + text, -- Directories containing source files. hs-source-dirs: examples/Complete @@ -154,7 +154,14 @@ -- Base language which the package is written in. default-language: GHC2024 -- Modules included in this executable, other than Main. - other-modules: TestTypes + other-modules: + Spec.AdvancedDerivation + Spec.BasicDerivation + Spec.JSONConversion + Spec.SchemaValidation + TestData + TestTypes + -- LANGUAGE extensions used by modules in this package. -- other-extensions: -- The interface type and version of the test suite. @@ -162,14 +169,15 @@ -- Directories containing source files. hs-source-dirs: test -- The entrypoint to the test suite. - main-is: Main.hs + main-is: HspecMain.hs -- Test dependencies. build-depends: - QuickCheck >=2.14 && <2.16, - aeson >=2.0 && <3.0, - base ^>=4.20.0.0, - containers >=0.6 && <0.8, + QuickCheck, + aeson, + base, + containers, + hspec, mcp-server, - network-uri >=2.6 && <2.8, - template-haskell >=2.16 && <2.23, - text >=1.2 && <3.0, + network-uri, + template-haskell, + text, diff --git a/test/HspecMain.hs b/test/HspecMain.hs new file mode 100644 --- /dev/null +++ b/test/HspecMain.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Test.Hspec +import qualified Spec.JSONConversion +import qualified Spec.BasicDerivation +import qualified Spec.SchemaValidation +import qualified Spec.AdvancedDerivation + +main :: IO () +main = hspec $ do + describe "MCP Server" $ do + Spec.JSONConversion.spec + Spec.BasicDerivation.spec + Spec.SchemaValidation.spec + Spec.AdvancedDerivation.spec diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,470 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main (main) where - -import Data.Aeson (Value(..), toJSON) -import Data.Text (Text) -import qualified Data.Text as T -import MCP.Server -import MCP.Server.Derive -import Network.URI (parseURI) -import Test.QuickCheck -import TestTypes -import Text.Read (readMaybe) - --- ============================================================================= --- JSON Type Conversion Tests --- ============================================================================= - --- Test conversion from JSON Value to Text and back -prop_intRoundTrip :: Int -> Bool -prop_intRoundTrip i = - let jsonVal = toJSON i - textVal = jsonValueToText jsonVal - parsed = case readMaybe (T.unpack textVal) of - Just result -> result - Nothing -> error $ "Failed to parse Int from: " <> T.unpack textVal - in parsed == i - -prop_boolRoundTrip :: Bool -> Bool -prop_boolRoundTrip b = - let jsonVal = toJSON b - textVal = jsonValueToText jsonVal - parsed = case T.toLower textVal of - "true" -> True - "false" -> False - _ -> error $ "Failed to parse Bool from: " <> T.unpack textVal - in parsed == b - -prop_textRoundTrip :: Text -> Bool -prop_textRoundTrip t = - let jsonVal = toJSON t - textVal = jsonValueToText jsonVal - in textVal == t - --- Test the specific conversion functions we use in the derivation -testIntConversion :: IO Bool -testIntConversion = do - let testCases = [0, 42, -17, 999999] :: [Int] - results <- mapM (\i -> do - let jsonVal = toJSON i - textVal = jsonValueToText jsonVal - parsed = case readMaybe (T.unpack textVal) of - Just result -> result - Nothing -> error $ "Failed to parse: " <> T.unpack textVal - return (parsed == (i :: Int)) - ) testCases - return (all id results) - -testBoolConversion :: IO Bool -testBoolConversion = do - let testCases = [True, False] - results <- mapM (\b -> do - let jsonVal = toJSON b - textVal = jsonValueToText jsonVal - parsed = case T.toLower textVal of - "true" -> True - "false" -> False - _ -> error $ "Failed to parse: " <> T.unpack textVal - return (parsed == b) - ) testCases - return (all id results) - -testTextConversion :: IO Bool -testTextConversion = do - let testCases = ["hello", "world", "", "123", "true", "false"] - results <- mapM (\t -> do - let jsonVal = toJSON t - textVal = jsonValueToText jsonVal - return (textVal == t) - ) testCases - return (all id results) - --- Test JSON Value to Text conversion specifically -testJsonValueToText :: IO Bool -testJsonValueToText = do - let tests = - [ (Number 42, "42") -- Whole numbers become integers - , (Number 42.5, "42.5") -- Decimals stay as decimals - , (String "hello", "hello") - , (Bool True, "true") - , (Bool False, "false") - , (Null, "") - ] - - let results = map (\(input, expected) -> jsonValueToText input == expected) tests - return (all id results) - -runJsonTypesTests :: IO Bool -runJsonTypesTests = do - putStrLn "\n=== JSON Type Conversion Tests ===" - - -- QuickCheck property tests - putStr "Testing Int round-trip property: " - quickCheck prop_intRoundTrip - - putStr "Testing Bool round-trip property: " - quickCheck prop_boolRoundTrip - - -- Manual conversion tests - putStr "Testing Int conversion: " - intResult <- testIntConversion - putStrLn $ if intResult then "PASS" else "FAIL" - - putStr "Testing Bool conversion: " - boolResult <- testBoolConversion - putStrLn $ if boolResult then "PASS" else "FAIL" - - putStr "Testing Text conversion: " - textResult <- testTextConversion - putStrLn $ if textResult then "PASS" else "FAIL" - - putStr "Testing jsonValueToText function: " - jsonResult <- testJsonValueToText - putStrLn $ if jsonResult then "PASS" else "FAIL" - - let allPassed = intResult && boolResult && textResult && jsonResult - putStrLn $ "JSON Types result: " ++ if allPassed then "PASS" else "FAIL" - return allPassed - --- ============================================================================= --- End-to-End Derivation Tests --- ============================================================================= - --- Generate handlers using Template Haskell (importing types from TestTypes module) -testPromptHandlers :: (PromptListHandler IO, PromptGetHandler IO) -testPromptHandlers = $(derivePromptHandler ''TestPrompt 'handleTestPrompt) - -testResourceHandlers :: (ResourceListHandler IO, ResourceReadHandler IO) -testResourceHandlers = $(deriveResourceHandler ''TestResource 'handleTestResource) - -testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) -testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) - --- Test handlers with custom descriptions -testToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) -testToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''TestTool 'handleTestTool testDescriptions) - --- Test case for separate parameter types approach (should fail with current implementation) -testSeparateParamsToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) -testSeparateParamsToolHandlers = $(deriveToolHandler ''SeparateParamsTool 'handleSeparateParamsTool) - --- Test case for recursive parameter types -testRecursiveToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) -testRecursiveToolHandlers = $(deriveToolHandler ''RecursiveTool 'handleRecursiveTool) - --- Test case for separate parameter types with descriptions -testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) -testSeparateParamsToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''SeparateParamsTool 'handleSeparateParamsTool separateParamsDescriptions) - --- Test case for recursive parameter types with descriptions -testRecursiveToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) -testRecursiveToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''RecursiveTool 'handleRecursiveTool separateParamsDescriptions) - --- End-to-end test functions -testPromptDerivation :: IO Bool -testPromptDerivation = do - let (_, getHandler) = testPromptHandlers - - -- Test simple prompt - result1 <- getHandler "simple_prompt" [("message", "hello")] - let test1 = case result1 of - Right (ContentText content) -> content == "Simple prompt: hello" - _ -> False - - -- Test complex prompt with multiple types - result2 <- getHandler "complex_prompt" [("title", "urgent task"), ("priority", "5"), ("urgent", "true")] - let test2 = case result2 of - Right (ContentText content) -> content == "Complex prompt: urgent task (priority=5, urgent=True)" - _ -> False - - -- Test optional prompt with missing optional field - result3 <- getHandler "optional_prompt" [("required", "test")] - let test3 = case result3 of - Right (ContentText content) -> content == "Optional prompt: test" - _ -> False - - -- Test optional prompt with optional field present - result4 <- getHandler "optional_prompt" [("required", "test"), ("optional", "42")] - let test4 = case result4 of - Right (ContentText content) -> content == "Optional prompt: test optional=42" - _ -> False - - return (test1 && test2 && test3 && test4) - -testSeparateParamsDerivation :: IO Bool -testSeparateParamsDerivation = do - putStrLn "Testing separate parameter types derivation..." - - -- Test the separate parameter types approach - let (listHandler, callHandler) = testSeparateParamsToolHandlers - - -- First test that tool definitions are generated correctly - toolDefs <- listHandler - let getValueDef = filter (\def -> toolDefinitionName def == "get_value") toolDefs - let setValueDef = filter (\def -> toolDefinitionName def == "set_value") toolDefs - - let schemaTest = case (getValueDef, setValueDef) of - ([getDef], [setDef]) -> - let getProps = case toolDefinitionInputSchema getDef of - InputSchemaDefinitionObject props _ -> map fst props - setProps = case toolDefinitionInputSchema setDef of - InputSchemaDefinitionObject props _ -> map fst props - in "_gvpKey" `elem` getProps && "_svpKey" `elem` setProps && "_svpValue" `elem` setProps - _ -> False - - putStrLn $ " Schema generation: " ++ (if schemaTest then "PASS" else "FAIL") - - -- Test GetValue with separate params - result1 <- callHandler "get_value" [("_gvpKey", "mykey")] - let test1 = case result1 of - Right (ContentText content) -> content == "Getting value for key: mykey" - _ -> False - - putStrLn $ " GetValue execution: " ++ (if test1 then "PASS" else "FAIL") - - -- Test SetValue with separate params - result2 <- callHandler "set_value" [("_svpKey", "mykey"), ("_svpValue", "myvalue")] - let test2 = case result2 of - Right (ContentText content) -> content == "Setting mykey = myvalue" - _ -> False - - putStrLn $ " SetValue execution: " ++ (if test2 then "PASS" else "FAIL") - - -- Test recursive parameter types - let (recursiveListHandler, recursiveCallHandler) = testRecursiveToolHandlers - recursiveToolDefs <- recursiveListHandler - let processDataDef = filter (\def -> toolDefinitionName def == "process_data") recursiveToolDefs - - let recursiveSchemaTest = case processDataDef of - [def] -> case toolDefinitionInputSchema def of - InputSchemaDefinitionObject props _ -> - let propNames = map fst props - in "_ipName" `elem` propNames && "_ipAge" `elem` propNames - _ -> False - - putStrLn $ " Recursive schema generation: " ++ (if recursiveSchemaTest then "PASS" else "FAIL") - - -- Test recursive execution - result3 <- recursiveCallHandler "process_data" [("_ipName", "Alice"), ("_ipAge", "30")] - let test3 = case result3 of - Right (ContentText content) -> content == "Processing data for Alice (age 30)" - _ -> False - - putStrLn $ " Recursive execution: " ++ (if test3 then "PASS" else "FAIL") - - -- Test descriptions with separate parameter types - let (descListHandler, _) = testSeparateParamsToolHandlersWithDescriptions - descToolDefs <- descListHandler - let getValueDefWithDesc = filter (\def -> toolDefinitionName def == "get_value") descToolDefs - let setValueDefWithDesc = filter (\def -> toolDefinitionName def == "set_value") descToolDefs - - let descriptionTest = case (getValueDefWithDesc, setValueDefWithDesc) of - ([getDef], [setDef]) -> - let getDefDescCorrect = toolDefinitionDescription getDef == "Retrieves a value from the key-value store" - setDefDescCorrect = toolDefinitionDescription setDef == "Sets a value in the key-value store" - getFieldDescsCorrect = case toolDefinitionInputSchema getDef of - InputSchemaDefinitionObject props _ -> - case lookup "_gvpKey" props of - Just prop -> propertyDescription prop == "The key to retrieve the value for" - Nothing -> False - setFieldDescsCorrect = case toolDefinitionInputSchema setDef of - InputSchemaDefinitionObject props _ -> - let keyDesc = case lookup "_svpKey" props of - Just prop -> propertyDescription prop == "The key to set the value for" - Nothing -> False - valueDesc = case lookup "_svpValue" props of - Just prop -> propertyDescription prop == "The value to store" - Nothing -> False - in keyDesc && valueDesc - in getDefDescCorrect && setDefDescCorrect && getFieldDescsCorrect && setFieldDescsCorrect - _ -> False - - putStrLn $ " Description support: " ++ (if descriptionTest then "PASS" else "FAIL") - - -- Test recursive descriptions - let (recursiveDescListHandler, _) = testRecursiveToolHandlersWithDescriptions - recursiveDescToolDefs <- recursiveDescListHandler - let processDataDefWithDesc = filter (\def -> toolDefinitionName def == "process_data") recursiveDescToolDefs - - let recursiveDescTest = case processDataDefWithDesc of - [procDef] -> - let procDefDescCorrect = toolDefinitionDescription procDef == "Processes user data with age validation" - procFieldDescsCorrect = case toolDefinitionInputSchema procDef of - InputSchemaDefinitionObject props _ -> - let nameDesc = case lookup "_ipName" props of - Just prop -> propertyDescription prop == "The person's full name" - Nothing -> False - ageDesc = case lookup "_ipAge" props of - Just prop -> propertyDescription prop == "The person's age in years" - Nothing -> False - in nameDesc && ageDesc - in procDefDescCorrect && procFieldDescsCorrect - _ -> False - - putStrLn $ " Recursive description support: " ++ (if recursiveDescTest then "PASS" else "FAIL") - - return (schemaTest && test1 && test2 && recursiveSchemaTest && test3 && descriptionTest && recursiveDescTest) - -testResourceDerivation :: IO Bool -testResourceDerivation = do - let (_, readHandler) = testResourceHandlers - - -- Test simple resource - case parseURI "resource://config_file" of - Just uri1 -> do - result1 <- readHandler uri1 - let test1 = case result1 of - Right (ContentText content) -> T.isInfixOf "Config file contents" content - _ -> False - - -- Test parameterized resource (this would need to match actual schema) - case parseURI "resource://database_connection" of - Just uri2 -> do - result2 <- readHandler uri2 - let test2 = case result2 of - Right (ContentText content) -> T.isInfixOf "Database at" content - _ -> False - return (test1 && test2) - Nothing -> return False - Nothing -> return False - -testToolDerivation :: IO Bool -testToolDerivation = do - let (_, callHandler) = testToolHandlers - - -- Test simple tool - result1 <- callHandler "echo" [("text", "hello world")] - let test1 = case result1 of - Right (ContentText content) -> content == "Echo: hello world" - _ -> False - - -- Test tool with multiple typed parameters - result2 <- callHandler "calculate" [("operation", "add"), ("x", "10"), ("y", "5")] - let test2 = case result2 of - Right (ContentText content) -> content == "15" - _ -> False - - -- Test tool with boolean parameter - result3 <- callHandler "toggle" [("flag", "true")] - let test3 = case result3 of - Right (ContentText content) -> content == "Flag is now: False" - _ -> False - - -- Test tool with optional parameters - result4 <- callHandler "search" [("query", "test"), ("limit", "10")] - let test4 = case result4 of - Right (ContentText content) -> T.isInfixOf "Search results for 'test'" content && T.isInfixOf "(limit=10)" content - _ -> False - - return (test1 && test2 && test3 && test4) - -testCustomDescriptions :: IO Bool -testCustomDescriptions = do - let (toolListHandler, _) = testToolHandlersWithDescriptions - - toolDefs <- toolListHandler - - -- Find the Echo tool definition and check its description - let echoDef = filter (\def -> toolDefinitionName def == "echo") toolDefs - let echoDescTest = case echoDef of - [def] -> toolDefinitionDescription def == "Echoes the input text back to the user" - _ -> False - - -- Find the Calculate tool definition and check its description and field descriptions - let calculateDef = filter (\def -> toolDefinitionName def == "calculate") toolDefs - let calculateTest = case calculateDef of - [def] -> - let correctToolDesc = toolDefinitionDescription def == "Performs mathematical calculations" - correctFieldDescs = case toolDefinitionInputSchema def of - InputSchemaDefinitionObject props _ -> - let textDesc = case lookup "text" props of - Just prop -> propertyDescription prop == "The text to echo back" - Nothing -> True -- text field doesn't exist in Calculate, that's fine - operationDesc = case lookup "operation" props of - Just prop -> propertyDescription prop == "The mathematical operation to perform" - Nothing -> False - xDesc = case lookup "x" props of - Just prop -> propertyDescription prop == "The first number" - Nothing -> False - yDesc = case lookup "y" props of - Just prop -> propertyDescription prop == "The second number" - Nothing -> False - in operationDesc && xDesc && yDesc - in correctToolDesc && correctFieldDescs - _ -> False - - return (echoDescTest && calculateTest) - -testSchemaGeneration :: IO Bool -testSchemaGeneration = do - let (toolListHandler, _) = testToolHandlers - - toolDefs <- toolListHandler - - -- Find the Calculate tool definition - let calculateDef = filter (\def -> toolDefinitionName def == "calculate") toolDefs - case calculateDef of - [def] -> case toolDefinitionInputSchema def of - InputSchemaDefinitionObject props required -> - let hasXInt = case lookup "x" props of - Just prop -> propertyType prop == "integer" - Nothing -> False - hasYInt = case lookup "y" props of - Just prop -> propertyType prop == "integer" - Nothing -> False - hasOpString = case lookup "operation" props of - Just prop -> propertyType prop == "string" - Nothing -> False - hasRequiredFields = all (`elem` required) ["operation", "x", "y"] - in return (hasXInt && hasYInt && hasOpString && hasRequiredFields) - _ -> return False - -runEndToEndTests :: IO Bool -runEndToEndTests = do - putStrLn "\n=== End-to-End Derivation Tests ===" - - putStr "Testing prompt derivation: " - promptResult <- testPromptDerivation - putStrLn $ if promptResult then "PASS" else "FAIL" - - putStr "Testing resource derivation: " - resourceResult <- testResourceDerivation - putStrLn $ if resourceResult then "PASS" else "FAIL" - - putStr "Testing tool derivation: " - toolResult <- testToolDerivation - putStrLn $ if toolResult then "PASS" else "FAIL" - - putStr "Testing schema generation: " - schemaResult <- testSchemaGeneration - putStrLn $ if schemaResult then "PASS" else "FAIL" - - putStr "Testing custom descriptions: " - descriptionResult <- testCustomDescriptions - putStrLn $ if descriptionResult then "PASS" else "FAIL" - - putStr "Testing separate parameter types: " - separateParamsResult <- testSeparateParamsDerivation - putStrLn $ if separateParamsResult then "PASS" else "FAIL" - - let allPassed = promptResult && resourceResult && toolResult && schemaResult && descriptionResult && separateParamsResult - putStrLn $ "End-to-End result: " ++ if allPassed then "PASS" else "FAIL" - return allPassed - --- ============================================================================= --- Main Test Runner --- ============================================================================= - -main :: IO () -main = do - putStrLn "MCP Server Test Suite" - putStrLn "====================" - - jsonResult <- runJsonTypesTests - endToEndResult <- runEndToEndTests - - let overallResult = jsonResult && endToEndResult - putStrLn $ "\n====================" - putStrLn $ "Overall result: " ++ if overallResult then "ALL TESTS PASSED" else "SOME TESTS FAILED" diff --git a/test/Spec/AdvancedDerivation.hs b/test/Spec/AdvancedDerivation.hs new file mode 100644 --- /dev/null +++ b/test/Spec/AdvancedDerivation.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Spec.AdvancedDerivation (spec) where + +import Control.Monad (forM_) +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestTypes +import TestData + +-- Generate advanced handlers for separate parameter types +testSeparateParamsToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testSeparateParamsToolHandlers = $(deriveToolHandler ''SeparateParamsTool 'handleSeparateParamsTool) + +testRecursiveToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testRecursiveToolHandlers = $(deriveToolHandler ''RecursiveTool 'handleRecursiveTool) + +testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testSeparateParamsToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''SeparateParamsTool 'handleSeparateParamsTool separateParamsDescriptions) + +testRecursiveToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testRecursiveToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''RecursiveTool 'handleRecursiveTool separateParamsDescriptions) + +-- Helper functions for advanced testing +findToolByName :: Text -> [ToolDefinition] -> ToolDefinition +findToolByName 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 + +assertSchemaHasProperties :: [Text] -> ToolDefinition -> IO () +assertSchemaHasProperties expectedProps toolDef = do + case toolDefinitionInputSchema toolDef of + 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 + result <- handler toolName args + case result of + Right (ContentText content) -> content `shouldBe` expectedContent + other -> expectationFailure $ "Expected ContentText but got: " ++ show other + +assertToolHasDescription :: Text -> Text -> ToolDefinition -> IO () +assertToolHasDescription toolName expectedDesc toolDef = do + toolDefinitionName toolDef `shouldBe` toolName + toolDefinitionDescription toolDef `shouldBe` expectedDesc + +assertPropertyHasDescription :: Text -> Text -> ToolDefinition -> IO () +assertPropertyHasDescription propName expectedDesc toolDef = do + case toolDefinitionInputSchema toolDef of + 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 + let setValueDef = findToolByName "set_value" toolDefs + assertSchemaHasProperties ["_svpKey", "_svpValue"] setValueDef + + forM_ separateParamsTestCases $ \testCase -> + it (T.unpack $ sepTestDescription testCase) $ do + let (_, callHandler) = testSeparateParamsToolHandlers + assertToolCallResult callHandler (sepToolName testCase) (sepArgs testCase) (sepExpectedResult testCase) + + describe "Recursive Parameter Types" $ do + 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 + assertToolCallResult callHandler (recToolName testCase) (recArgs testCase) (recExpectedResult testCase) + + describe "Custom Descriptions with Separate Parameters" $ do + 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 + + describe "Recursive Tool Descriptions" $ do + 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 new file mode 100644 --- /dev/null +++ b/test/Spec/BasicDerivation.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Spec.BasicDerivation (spec) where + +import Control.Monad (forM_) +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Derive +import Network.URI (parseURI) +import Test.Hspec +import TestTypes +import TestData + +-- Generate handlers using Template Haskell +testPromptHandlers :: (PromptListHandler IO, PromptGetHandler IO) +testPromptHandlers = $(derivePromptHandler ''TestPrompt 'handleTestPrompt) + +testResourceHandlers :: (ResourceListHandler IO, ResourceReadHandler IO) +testResourceHandlers = $(deriveResourceHandler ''TestResource 'handleTestResource) + +testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) + +-- Helper functions for common test patterns +shouldReturnContentText :: IO (Either Error Content) -> Text -> IO () +shouldReturnContentText action expected = do + result <- action + case result of + Right (ContentText content) -> content `shouldBe` expected + other -> expectationFailure $ "Expected ContentText '" ++ T.unpack expected ++ "' but got: " ++ show other + +shouldContainText :: IO (Either Error Content) -> Text -> IO () +shouldContainText action expectedSubstring = do + result <- action + case result of + 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 = + shouldReturnContentText (handler name args) expected + +testResourceCall :: ResourceReadHandler IO -> String -> Text -> IO () +testResourceCall handler uriString expected = do + case parseURI uriString of + Just uri -> shouldReturnContentText (handler uri) expected + Nothing -> expectationFailure $ "Failed to parse URI: " ++ uriString + +testToolCall :: ToolCallHandler IO -> Text -> [(Text, Text)] -> Text -> IO () +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) $ + 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 $ resourceUri testCase) of + Just uri -> + if useSubstringMatch testCase + then shouldContainText (readHandler uri) (resourceExpectedContent testCase) + else testResourceCall readHandler (T.unpack $ resourceUri testCase) (resourceExpectedContent testCase) + Nothing -> expectationFailure $ "Failed to parse URI: " ++ T.unpack (resourceUri testCase) + + describe "Tool derivation" $ do + let (_, callHandler) = testToolHandlers + + forM_ toolTestCases $ \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 new file mode 100644 --- /dev/null +++ b/test/Spec/JSONConversion.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Spec.JSONConversion (spec) where + +import Data.Aeson (Value(..), toJSON) +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import Test.Hspec +import Test.QuickCheck +import Text.Read (readMaybe) + +-- Arbitrary instance for Text (needed for QuickCheck) +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + +spec :: Spec +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 text correctly" $ property prop_textRoundTrip + + describe "Manual conversion tests" $ do + it "converts integers manually" testIntConversion + it "converts booleans manually" testBoolConversion + +-- Fixed property-based tests (no more 'error' usage) +prop_intRoundTrip :: Int -> Bool +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 = + let jsonVal = toJSON b + textVal = jsonValueToText jsonVal + parsed = case T.toLower textVal of + "true" -> Just True + "false" -> Just False + _ -> Nothing + in parsed == Just b + +prop_textRoundTrip :: Text -> Bool +prop_textRoundTrip t = + let jsonVal = toJSON t + textVal = jsonValueToText jsonVal + in textVal == t + +-- Manual test functions converted to Hspec style +testIntConversion :: IO () +testIntConversion = do + let testCases = [0, 42, -17, 999999] :: [Int] + results <- mapM testSingleInt testCases + all id results `shouldBe` True + where + testSingleInt i = do + let jsonVal = toJSON i + textVal = jsonValueToText jsonVal + case readMaybe (T.unpack textVal) of + Just parsed -> return (parsed == i) + Nothing -> do + expectationFailure $ "Failed to parse Int from: " <> T.unpack textVal + return False + +testBoolConversion :: IO () +testBoolConversion = do + let testCases = [True, False] + results <- mapM testSingleBool testCases + all id results `shouldBe` True + where + testSingleBool b = do + let jsonVal = toJSON b + textVal = jsonValueToText jsonVal + expected = if b then "true" else "false" + case T.toLower textVal of + result | result == expected -> return True + result -> do + expectationFailure $ "Expected " <> T.unpack expected <> " but got " <> T.unpack result + return False diff --git a/test/Spec/SchemaValidation.hs b/test/Spec/SchemaValidation.hs new file mode 100644 --- /dev/null +++ b/test/Spec/SchemaValidation.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Spec.SchemaValidation (spec) where + +import Control.Monad (forM_) +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestTypes +import TestData + +-- Generate handlers for testing +testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) + +testToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''TestTool 'handleTestTool testDescriptions) + +-- Helper functions for schema validation +findTool :: Text -> [ToolDefinition] -> ToolDefinition +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 = + case toolDefinitionInputSchema toolDef of + 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 + toolDefs `shouldSatisfy` any (\def -> toolDefinitionName def == toolName) + +assertHasProperty :: Text -> Text -> ToolDefinition -> IO () +assertHasProperty propertyName expectedType toolDef = do + let prop = getProperty propertyName toolDef + propertyType prop `shouldBe` expectedType + +assertPropertyDescription :: Text -> ToolDefinition -> Text -> IO () +assertPropertyDescription propertyName toolDef expectedDesc = do + let prop = getProperty propertyName toolDef + propertyDescription prop `shouldBe` expectedDesc + +assertRequiredFields :: [Text] -> ToolDefinition -> IO () +assertRequiredFields expectedFields toolDef = do + case toolDefinitionInputSchema toolDef of + InputSchemaDefinitionObject _ required -> + all (`elem` required) expectedFields `shouldBe` True + other -> expectationFailure $ "Expected InputSchemaDefinitionObject but got: " ++ show other + +assertToolDescription :: ToolDefinition -> Text -> IO () +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 + + describe "Custom Descriptions" $ do + 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 "y" calculateDef "The second number" diff --git a/test/TestData.hs b/test/TestData.hs new file mode 100644 --- /dev/null +++ b/test/TestData.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestData + ( -- * Prompt Test Data + promptTestCases + , PromptTestCase(..) + + -- * Resource Test Data + , resourceTestCases + , ResourceTestCase(..) + + -- * Tool Test Data + , toolTestCases + , ToolTestCase(..) + + -- * Schema Test Data + , schemaTestCases + , SchemaTestCase(..) + + -- * Advanced Derivation Test Data + , separateParamsTestCases + , recursiveParamsTestCases + , SeparateParamsTestCase(..) + , RecursiveParamsTestCase(..) + ) where + +import Data.Text (Text) + +-- | Test case for prompt derivation +data PromptTestCase = PromptTestCase + { promptName :: Text + , promptArgs :: [(Text, Text)] + , expectedResult :: Text + , testDescription :: Text + } deriving (Show, Eq) + +-- | Test case for resource derivation +data ResourceTestCase = ResourceTestCase + { resourceUri :: Text + , resourceExpectedContent :: Text + , useSubstringMatch :: Bool -- True for substring match, False for exact match + , resourceTestDescription :: Text + } deriving (Show, Eq) + +-- | Test case for tool derivation +data ToolTestCase = ToolTestCase + { toolName :: Text + , toolArgs :: [(Text, Text)] + , toolExpectedResult :: Text + , toolTestDescription :: Text + } deriving (Show, Eq) + +-- | Test case for schema validation +data SchemaTestCase = SchemaTestCase + { schemaToolName :: Text + , expectedProperties :: [(Text, Text)] -- (property name, expected type) + , requiredFields :: [Text] + , schemaTestDescription :: Text + } deriving (Show, Eq) + +-- | Test case for separate parameter types +data SeparateParamsTestCase = SeparateParamsTestCase + { sepToolName :: Text + , sepArgs :: [(Text, Text)] + , sepExpectedResult :: Text + , sepExpectedProperties :: [Text] + , sepTestDescription :: Text + } deriving (Show, Eq) + +-- | Test case for recursive parameter types +data RecursiveParamsTestCase = RecursiveParamsTestCase + { recToolName :: Text + , recArgs :: [(Text, Text)] + , recExpectedResult :: Text + , recExpectedProperties :: [Text] + , recTestDescription :: Text + } deriving (Show, Eq) + +-- | Prompt test cases +promptTestCases :: [PromptTestCase] +promptTestCases = + [ PromptTestCase + { promptName = "simple_prompt" + , promptArgs = [("message", "hello")] + , expectedResult = "Simple prompt: hello" + , testDescription = "handles simple prompts correctly" + } + , PromptTestCase + { promptName = "complex_prompt" + , promptArgs = [("title", "urgent task"), ("priority", "5"), ("urgent", "true")] + , expectedResult = "Complex prompt: urgent task (priority=5, urgent=True)" + , testDescription = "handles complex prompts with multiple types" + } + , PromptTestCase + { promptName = "optional_prompt" + , promptArgs = [("required", "test")] + , expectedResult = "Optional prompt: test" + , testDescription = "handles optional prompts with missing optional field" + } + , PromptTestCase + { promptName = "optional_prompt" + , promptArgs = [("required", "test"), ("optional", "42")] + , expectedResult = "Optional prompt: test optional=42" + , testDescription = "handles optional prompts with optional field present" + } + ] + +-- | Resource test cases +resourceTestCases :: [ResourceTestCase] +resourceTestCases = + [ ResourceTestCase + { resourceUri = "resource://config_file" + , resourceExpectedContent = "Config file contents" + , useSubstringMatch = True + , resourceTestDescription = "handles simple resources correctly" + } + , ResourceTestCase + { resourceUri = "resource://database_connection" + , resourceExpectedContent = "Database at localhost:5432" + , useSubstringMatch = False + , resourceTestDescription = "handles parameterized resources correctly" + } + ] + +-- | Tool test cases +toolTestCases :: [ToolTestCase] +toolTestCases = + [ ToolTestCase + { toolName = "calculate" + , toolArgs = [("operation", "add"), ("x", "10"), ("y", "5")] + , toolExpectedResult = "15" + , toolTestDescription = "handles simple tool calls correctly" + } + , ToolTestCase + { toolName = "calculate" + , toolArgs = [("operation", "multiply"), ("x", "7"), ("y", "6")] + , toolExpectedResult = "42" + , toolTestDescription = "handles tool calls with different operations" + } + ] + +-- | Schema test cases +schemaTestCases :: [SchemaTestCase] +schemaTestCases = + [ SchemaTestCase + { schemaToolName = "calculate" + , expectedProperties = [("x", "integer"), ("y", "integer"), ("operation", "string")] + , requiredFields = ["operation", "x", "y"] + , schemaTestDescription = "generates correct schema for Calculate tool" + } + , SchemaTestCase + { schemaToolName = "echo" + , expectedProperties = [("text", "string")] + , requiredFields = ["text"] + , schemaTestDescription = "generates correct schema for Echo tool" + } + ] + +-- | Separate parameter types test cases +separateParamsTestCases :: [SeparateParamsTestCase] +separateParamsTestCases = + [ SeparateParamsTestCase + { sepToolName = "get_value" + , sepArgs = [("_gvpKey", "mykey")] + , sepExpectedResult = "Getting value for key: mykey" + , sepExpectedProperties = ["_gvpKey"] + , sepTestDescription = "executes GetValue with separate parameters correctly" + } + , SeparateParamsTestCase + { sepToolName = "set_value" + , sepArgs = [("_svpKey", "mykey"), ("_svpValue", "myvalue")] + , sepExpectedResult = "Setting mykey = myvalue" + , sepExpectedProperties = ["_svpKey", "_svpValue"] + , sepTestDescription = "executes SetValue with separate parameters correctly" + } + ] + +-- | Recursive parameter types test cases +recursiveParamsTestCases :: [RecursiveParamsTestCase] +recursiveParamsTestCases = + [ RecursiveParamsTestCase + { recToolName = "process_data" + , recArgs = [("_ipName", "Alice"), ("_ipAge", "30")] + , recExpectedResult = "Processing data for Alice (age 30)" + , recExpectedProperties = ["_ipName", "_ipAge"] + , recTestDescription = "executes recursive parameter tools correctly" + } + ]