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.1 +version: 0.1.0.2 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package. @@ -157,7 +157,7 @@ -- Base language which the package is written in. default-language: GHC2024 -- Modules included in this executable, other than Main. - -- other-modules: + other-modules: TestTypes -- LANGUAGE extensions used by modules in this package. -- other-extensions: -- The interface type and version of the test suite. @@ -168,5 +168,11 @@ main-is: Main.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, mcp-server, + network-uri >=2.6 && <2.8, + template-haskell >=2.16 && <2.23, + text >=1.2 && <3.0, diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -7,6 +7,9 @@ , runMcpServerStdIn , handleMcpMessage + -- * Utility Functions + , jsonValueToText + -- * Re-exports , module MCP.Server.Types ) where @@ -26,6 +29,19 @@ import MCP.Server.Protocol import MCP.Server.Types +-- | Convert JSON Value to Text representation suitable for handlers +jsonValueToText :: Value -> Text +jsonValueToText (String t) = t +jsonValueToText (Number n) = + -- Check if it's a whole number, if so format as integer + if fromInteger (round n) == n + then T.pack $ show (round n :: Integer) + else T.pack $ show n +jsonValueToText (Bool True) = "true" +jsonValueToText (Bool False) = "false" +jsonValueToText Null = "" +jsonValueToText v = T.pack $ show v + -- | Extract a brief summary of a JSON-RPC message for logging getMessageSummary :: JsonRpcMessage -> String getMessageSummary (JsonRpcMessageRequest req) = @@ -207,7 +223,7 @@ , errorData = Nothing } Success getReq -> do - let args = maybe [] (map (\(k, v) -> (k, T.pack $ show v)) . Map.toList) (promptsGetArguments getReq) + let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (promptsGetArguments getReq) result <- getHandler (promptsGetName getReq) args case result of Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError @@ -327,7 +343,7 @@ , errorData = Nothing } Success callReq -> do - let args = maybe [] (map (\(k, v) -> (k, T.pack $ show v)) . Map.toList) (toolsCallArguments callReq) + let args = maybe [] (map (\(k, v) -> (k, jsonValueToText v)) . Map.toList) (toolsCallArguments callReq) result <- callHandler (toolsCallName callReq) args case result of Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError 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 @@ -11,6 +11,7 @@ import qualified Data.Map as Map import qualified Data.Text as T import Language.Haskell.TH +import Text.Read (readMaybe) import MCP.Server.Types @@ -27,22 +28,22 @@ TyConI (DataD _ _ _ _ constructors _) -> do -- Generate prompt definitions promptDefs <- sequence $ map mkPromptDef constructors - + -- Generate list handler listHandlerExp <- [| \_cursor -> pure $ PaginatedResult { paginatedItems = $(return $ ListE promptDefs) , paginatedNextCursor = Nothing } |] - + -- Generate get handler with cases cases <- sequence $ map (mkPromptCase handlerName) constructors defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |] let defaultMatch = Match WildP (NormalB defaultCase) [] - + getHandlerExp <- return $ LamE [VarP (mkName "name"), VarP (mkName "args")] $ - CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name"))) + CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name"))) (map clauseToMatch cases ++ [defaultMatch]) - + return $ TupE [Just listHandlerExp, Just getHandlerExp] _ -> fail $ "derivePromptHandler: " ++ show typeName ++ " is not a data type" @@ -68,7 +69,7 @@ mkArgDef (fieldName, _, fieldType) = do let isOptional = case fieldType of AppT (ConT n) _ -> nameBase n == "Maybe" - _ -> False + _ -> False [| ArgumentDefinition { argumentDefinitionName = $(litE $ stringL $ nameBase fieldName) , argumentDefinitionDescription = $(litE $ stringL $ nameBase fieldName) @@ -111,20 +112,55 @@ buildNestedFieldValidation conName handlerName ((fieldName, _, fieldType):remainingFields) depth = do let fieldStr = nameBase fieldName - let isOptional = case fieldType of - AppT (ConT n) _ -> nameBase n == "Maybe" - _ -> False + let (isOptional, innerType) = case fieldType of + AppT (ConT n) inner | nameBase n == "Maybe" -> (True, inner) + other -> (False, other) let fieldVar = mkName ("field" ++ show depth) - + continuation <- buildNestedFieldValidation conName handlerName remainingFields (depth + 1) - + + -- Generate conversion expression based on type + let convertExpr rawVar = case innerType of + ConT n | nameBase n == "Int" -> + [| case readMaybe (T.unpack $(varE rawVar)) of + Just parsed -> parsed + Nothing -> error $ "Failed to parse Int from: " <> T.unpack $(varE rawVar) |] + ConT n | nameBase n == "Integer" -> + [| case readMaybe (T.unpack $(varE rawVar)) of + Just parsed -> parsed + Nothing -> error $ "Failed to parse Integer from: " <> T.unpack $(varE rawVar) |] + ConT n | nameBase n == "Double" -> + [| case readMaybe (T.unpack $(varE rawVar)) of + Just parsed -> parsed + Nothing -> error $ "Failed to parse Double from: " <> T.unpack $(varE rawVar) |] + ConT n | nameBase n == "Float" -> + [| case readMaybe (T.unpack $(varE rawVar)) of + Just parsed -> parsed + Nothing -> error $ "Failed to parse Float from: " <> T.unpack $(varE rawVar) |] + ConT n | nameBase n == "Bool" -> + [| case T.toLower $(varE rawVar) of + "true" -> True + "false" -> False + _ -> error $ "Failed to parse Bool from: " <> T.unpack $(varE rawVar) |] + _ -> varE rawVar -- Text or other types, use as-is + if isOptional - then [| do - let $(varP fieldVar) = Map.lookup $(litE $ stringL fieldStr) (Map.fromList args) - $(return continuation) |] - else [| case Map.lookup $(litE $ stringL fieldStr) (Map.fromList args) of - Just $(varP fieldVar) -> $(return continuation) - Nothing -> pure $ Left $ MissingRequiredParams $ "field '" <> $(litE $ stringL fieldStr) <> "' is missing" |] + then do + rawFieldVar <- newName ("raw" ++ show depth) + convertedExpr <- convertExpr rawFieldVar + [| do + let $(varP fieldVar) = case Map.lookup $(litE $ stringL fieldStr) (Map.fromList args) of + Nothing -> Nothing + Just $(varP rawFieldVar) -> Just $(return convertedExpr) + $(return continuation) |] + else do + rawFieldVar <- newName ("raw" ++ show depth) + convertedExpr <- convertExpr rawFieldVar + [| case Map.lookup $(litE $ stringL fieldStr) (Map.fromList args) of + Just $(varP rawFieldVar) -> do + let $(varP fieldVar) = $(return convertedExpr) + $(return continuation) + Nothing -> pure $ Left $ MissingRequiredParams $ "field '" <> $(litE $ stringL fieldStr) <> "' is missing" |] -- | Derive resource handlers from a data type -- Usage: $(deriveResourceHandler ''MyResource 'handleResource) @@ -135,7 +171,7 @@ TyConI (DataD _ _ _ _ constructors _) -> do -- Generate resource definitions resourceDefs <- sequence $ map mkResourceDef constructors - + listHandlerExp <- [| \_cursor -> pure $ PaginatedResult { paginatedItems = $(return $ ListE resourceDefs) , paginatedNextCursor = Nothing @@ -145,9 +181,9 @@ cases <- sequence $ map (mkResourceCase handlerName) constructors defaultCase <- [| pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |] let defaultMatch = Match (VarP (mkName "unknown")) (NormalB defaultCase) [] - + readHandlerExp <- return $ LamE [VarP (mkName "uri")] $ - CaseE (AppE (VarE 'show) (VarE (mkName "uri"))) + CaseE (AppE (VarE 'show) (VarE (mkName "uri"))) (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just readHandlerExp] @@ -183,7 +219,7 @@ TyConI (DataD _ _ _ _ constructors _) -> do -- Generate tool definitions toolDefs <- sequence $ map mkToolDef constructors - + listHandlerExp <- [| \_cursor -> pure $ PaginatedResult { paginatedItems = $(return $ ListE toolDefs) , paginatedNextCursor = Nothing @@ -193,9 +229,9 @@ cases <- sequence $ map (mkToolCase handlerName) constructors defaultCase <- [| pure $ Left $ UnknownTool $ "Unknown tool: " <> name |] let defaultMatch = Match WildP (NormalB defaultCase) [] - + callHandlerExp <- return $ LamE [VarP (mkName "name"), VarP (mkName "args")] $ - CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name"))) + CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name"))) (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just callHandlerExp] @@ -218,7 +254,7 @@ requiredFields <- return $ map (\(fieldName, _, fieldType) -> let isOptional = case fieldType of AppT (ConT n) _ -> nameBase n == "Maybe" - _ -> False + _ -> False in if isOptional then Nothing else Just (nameBase fieldName) ) fields let required = [f | Just f <- requiredFields] @@ -233,10 +269,25 @@ mkToolDef _ = fail "Unsupported constructor type for tools" mkProperty :: (Name, Bang, Type) -> Q Exp -mkProperty (fieldName, _, _) = do +mkProperty (fieldName, _, fieldType) = do let fieldStr = nameBase fieldName + let jsonType = case fieldType of + ConT n | nameBase n == "Int" -> "integer" + ConT n | nameBase n == "Integer" -> "integer" + ConT n | nameBase n == "Double" -> "number" + ConT n | nameBase n == "Float" -> "number" + ConT n | nameBase n == "Bool" -> "boolean" + AppT (ConT maybeType) innerType | nameBase maybeType == "Maybe" -> + case innerType of + ConT n | nameBase n == "Int" -> "integer" + ConT n | nameBase n == "Integer" -> "integer" + ConT n | nameBase n == "Double" -> "number" + ConT n | nameBase n == "Float" -> "number" + ConT n | nameBase n == "Bool" -> "boolean" + _ -> "string" + _ -> "string" [| ($(litE $ stringL fieldStr), InputSchemaDefinitionProperty - { propertyType = "string" + { propertyType = $(litE $ stringL jsonType) , propertyDescription = $(litE $ stringL fieldStr) }) |] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,292 @@ +{-# 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) + +-- End-to-end test functions +testPromptDerivation :: IO Bool +testPromptDerivation = do + let (_, getHandler) = testPromptHandlers + + -- Test simple prompt + result1 <- getHandler "simpleprompt" [("message", "hello")] + let test1 = case result1 of + Right (ContentText content) -> content == "Simple prompt: hello" + _ -> False + + -- Test complex prompt with multiple types + result2 <- getHandler "complexprompt" [("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 "optionalprompt" [("required", "test")] + let test3 = case result3 of + Right (ContentText content) -> content == "Optional prompt: test" + _ -> False + + -- Test optional prompt with optional field present + result4 <- getHandler "optionalprompt" [("required", "test"), ("optional", "42")] + let test4 = case result4 of + Right (ContentText content) -> content == "Optional prompt: test optional=42" + _ -> False + + return (test1 && test2 && test3 && test4) + +testResourceDerivation :: IO Bool +testResourceDerivation = do + let (_, readHandler) = testResourceHandlers + + -- Test simple resource + case parseURI "resource://configfile" 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://databaseconnection" 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) + +testSchemaGeneration :: IO Bool +testSchemaGeneration = do + let (toolListHandler, _) = testToolHandlers + + paginatedResult <- toolListHandler Nothing + let toolDefs = paginatedItems paginatedResult + + -- 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" + + let allPassed = promptResult && resourceResult && toolResult && schemaResult + putStrLn $ "End-to-End result: " ++ if allPassed then "PASS" else "FAIL" + return allPassed + +-- ============================================================================= +-- Main Test Runner +-- ============================================================================= + main :: IO () -main = putStrLn "Test suite not yet implemented." +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/TestTypes.hs b/test/TestTypes.hs new file mode 100644 --- /dev/null +++ b/test/TestTypes.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestTypes where + +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server (Content(..)) + +-- Test data types for end-to-end testing +data TestPrompt + = SimplePrompt { message :: Text } + | ComplexPrompt { title :: Text, priority :: Int, urgent :: Bool } + | OptionalPrompt { required :: Text, optional :: Maybe Int } + deriving (Show, Eq) + +data TestResource + = ConfigFile + | DatabaseConnection + | UserProfile + deriving (Show, Eq) + +data TestTool + = Echo { text :: Text } + | Calculate { operation :: Text, x :: Int, y :: Int } + | Toggle { flag :: Bool } + | Search { query :: Text, limit :: Maybe Int, caseSensitive :: Maybe Bool } + deriving (Show, Eq) + +-- Handler functions +handleTestPrompt :: TestPrompt -> IO Content +handleTestPrompt (SimplePrompt msg) = + pure $ ContentText $ "Simple prompt: " <> msg +handleTestPrompt (ComplexPrompt title prio urgent) = + pure $ ContentText $ "Complex prompt: " <> title <> " (priority=" <> T.pack (show prio) <> ", urgent=" <> T.pack (show urgent) <> ")" +handleTestPrompt (OptionalPrompt req opt) = + pure $ ContentText $ "Optional prompt: " <> req <> maybe "" ((" optional=" <>) . T.pack . show) opt + +handleTestResource :: TestResource -> IO Content +handleTestResource ConfigFile = + pure $ ContentText "Config file contents: debug=true, timeout=30" +handleTestResource DatabaseConnection = + pure $ ContentText "Database at localhost:5432" +handleTestResource UserProfile = + pure $ ContentText "User profile for ID 123" + +handleTestTool :: TestTool -> IO Content +handleTestTool (Echo text) = + pure $ ContentText $ "Echo: " <> text +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) = + pure $ ContentText $ "Flag is now: " <> T.pack (show (not flag)) +handleTestTool (Search query limit caseSens) = + pure $ ContentText $ "Search results for '" <> query <> "'" <> + maybe "" ((" (limit=" <>) . (<> ")") . T.pack . show) limit <> + maybe "" ((" (case-sensitive=" <>) . (<> ")") . T.pack . show) caseSens