mcp-server 0.1.0.7 → 0.1.0.8
raw patch · 7 files changed
+370/−16 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- README.md +27/−0
- examples/Complete/Main.hs +2/−7
- examples/Simple/Main.hs +3/−7
- mcp-server.cabal +1/−1
- src/MCP/Server/Derive.hs +158/−0
- test/Main.hs +135/−1
- test/TestTypes.hs +44/−0
README.md view
@@ -70,6 +70,33 @@ } ``` +### Nestable data types++You can also nest your data types, but MUST always end in a record with named fields:++```haskell+-- Using fields, but prefixing with the Type name, because maybe the user wants to use Lenses+data GetValueParams = GetValueParams { _gvpKey :: Text }+data SetValueParams = SetValueParams { _svpKey :: Text, _svpValue :: Text }++data SimpleTool+ = GetValue GetValueParams+ | SetValue SetValueParams+ deriving (Show, Eq)+```++Which is probably nicer for using things like Lenses etc. However we do not support positional (and unnamed) parameters such as:++```haskell+-- Positional arguments+data SimpleTool+ = GetValue Int+ | SetValue Int Text+ deriving (Show, Eq)+```++Because we don't want to be generating names when returning details in MCP definitions.+ ## Custom Descriptions You can provide custom descriptions for constructors and fields using the `*WithDescription` variants:
examples/Complete/Main.hs view
@@ -5,7 +5,6 @@ import MCP.Server import MCP.Server.Derive-import System.IO (hPutStrLn, stderr) import Types -- High-level handler functions@@ -35,19 +34,15 @@ main :: IO () main = do- hPutStrLn stderr "Starting Template Haskell MCP Server..."- hPutStrLn stderr "Using automatic Template Haskell derivation!"- hPutStrLn stderr "Ready for JSON-RPC communication"- -- Derive the handlers using Template Haskell let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt) resources = $(deriveResourceHandler ''MyResource 'handleResource) tools = $(deriveToolHandler ''MyTool 'handleTool) in runMcpServerStdIn McpServerInfo- { serverName = "Template Haskell MCP Server"+ { serverName = "Complete Example MCP Server" , serverVersion = "0.3.0"- , serverInstructions = "MCP server using Template Haskell for automatic handler derivation"+ , serverInstructions = "An example MCP server that handles prompts, resources, and tools." } McpServerHandlers { prompts = Just prompts
examples/Simple/Main.hs view
@@ -4,7 +4,6 @@ module Main where import Data.IORef-import Data.Text (Text) import MCP.Server import MCP.Server.Derive import System.IO (hPutStrLn, stderr)@@ -29,9 +28,6 @@ writeIORef store newPairs pure $ ContentText $ "Set '" <> k <> "' to '" <> v <> "'" - hPutStrLn stderr "Using Template Haskell derivation for tools"- hPutStrLn stderr "Ready for JSON-RPC communication"- -- Derive the tool handlers using Template Haskell with descriptions let tools = $(deriveToolHandlerWithDescription ''SimpleTool 'handleTool simpleDescriptions) in runMcpServerStdIn@@ -41,7 +37,7 @@ , serverInstructions = "A simple key-value store with GetValue and SetValue tools" } McpServerHandlers- { prompts = Nothing- , resources = Nothing- , tools = Just tools+ { prompts = Nothing -- No prompts in this example+ , resources = Nothing -- No resources in this example+ , tools = Just tools -- Only tools in this example }
mcp-server.cabal view
@@ -15,7 +15,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.7+version: 0.1.0.8 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.
src/MCP/Server/Derive.hs view
@@ -90,8 +90,36 @@ , promptDefinitionDescription = $(litE $ stringL description) , promptDefinitionArguments = $(return $ ListE args) } |]+ NormalC name [(_bang, paramType)] -> do+ -- Handle separate parameter types approach+ let promptName = T.pack . toSnakeCase . nameBase $ name+ let constructorName = nameBase name+ let description = case lookup constructorName descriptions of+ Just desc -> desc+ Nothing -> "Handle " ++ constructorName+ args <- extractFieldsFromType descriptions paramType+ [| PromptDefinition+ { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)+ , promptDefinitionDescription = $(litE $ stringL description)+ , promptDefinitionArguments = $(return $ ListE args)+ } |] _ -> fail "Unsupported constructor type" +-- Extract field definitions from a parameter type recursively+extractFieldsFromType :: [(String, String)] -> Type -> Q [Exp]+extractFieldsFromType descriptions paramType = do+ case paramType of+ ConT typeName -> do+ info <- reify typeName+ case info of+ TyConI (DataD _ _ _ _ [RecC _ fields] _) -> do+ -- Parameter type is a record with fields+ sequence $ map (mkArgDef descriptions) fields+ TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> do+ -- Parameter type has a single parameter - recurse+ extractFieldsFromType descriptions 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 mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp mkArgDef descriptions (fieldName, _, fieldType) = do@@ -120,8 +148,110 @@ let promptName = T.pack . toSnakeCase . nameBase $ name body <- mkRecordCase name handlerName fields clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) []+mkPromptCase handlerName (NormalC name [(_bang, paramType)]) = do+ let promptName = T.pack . toSnakeCase . nameBase $ name+ body <- mkSeparateParamsCase name handlerName paramType+ clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) [] mkPromptCase _ _ = fail "Unsupported constructor type" +mkSeparateParamsCase :: Name -> Name -> Type -> Q Exp+mkSeparateParamsCase conName handlerName paramType = do+ fields <- extractFieldsFromParamType paramType+ buildNestedFieldValidationWithConstructor conName handlerName paramType fields 0+ where+ buildNestedFieldValidationWithConstructor :: Name -> Name -> Type -> [(Name, Bang, Type)] -> Int -> Q Exp+ buildNestedFieldValidationWithConstructor outerConName handlerName' paramType' [] depth = do+ -- Base case: all fields validated, build parameter constructor hierarchy and outer constructor+ let fieldVars = [mkName ("field" ++ show i) | i <- [0..depth-1]]+ paramConstructorApp <- buildParameterConstructor paramType' fieldVars+ let outerConstructorApp = AppE (ConE outerConName) paramConstructorApp+ [| 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+ AppT (ConT n) inner | nameBase n == "Maybe" -> (True, inner)+ other -> (False, other)+ let fieldVar = mkName ("field" ++ show depth)++ continuation <- buildNestedFieldValidationWithConstructor outerConName handlerName' paramType' 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+ 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" |]++-- Extract field information from parameter type+extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)]+extractFieldsFromParamType paramType = do+ case paramType of+ ConT typeName -> do+ info <- reify typeName+ case info of+ TyConI (DataD _ _ _ _ [RecC _ fields] _) -> + return fields+ 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++-- Build the parameter constructor application recursively+buildParameterConstructor :: Type -> [Name] -> Q Exp+buildParameterConstructor paramType fieldVars = do+ case paramType of+ ConT typeName -> do+ info <- reify typeName+ case info of+ TyConI (DataD _ _ _ _ [RecC conName _] _) -> do+ -- Record constructor - apply all field variables+ return $ foldl AppE (ConE conName) (map VarE fieldVars)+ TyConI (DataD _ _ _ _ [NormalC conName [(_bang, innerType)]] _) -> do+ -- Single parameter constructor - recurse and wrap+ innerConstructor <- buildParameterConstructor innerType fieldVars+ return $ AppE (ConE conName) innerConstructor+ _ -> 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+ mkRecordCase :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp mkRecordCase conName handlerName fields = do case fields of@@ -321,6 +451,30 @@ , required = $(return $ ListE $ map (LitE . StringL) required) } } |]+ NormalC name [(_bang, paramType)] -> do+ -- Handle separate parameter types approach for tools+ let toolName = T.pack . toSnakeCase . nameBase $ name+ let constructorName = nameBase name+ let description = case lookup constructorName descriptions of+ Just desc -> desc+ Nothing -> constructorName+ fields <- extractFieldsFromParamType paramType+ props <- sequence $ map (mkProperty descriptions) fields+ requiredFields <- return $ map (\(fieldName, _, fieldType) ->+ let isOptional = case fieldType of+ AppT (ConT n) _ -> nameBase n == "Maybe"+ _ -> False+ in if isOptional then Nothing else Just (nameBase fieldName)+ ) fields+ let required = [f | Just f <- requiredFields]+ [| ToolDefinition+ { toolDefinitionName = $(litE $ stringL $ T.unpack toolName)+ , toolDefinitionDescription = $(litE $ stringL description)+ , toolDefinitionInputSchema = InputSchemaDefinitionObject+ { properties = $(return $ ListE props)+ , required = $(return $ ListE $ map (LitE . StringL) required)+ }+ } |] _ -> fail "Unsupported constructor type for tools" @@ -361,5 +515,9 @@ mkToolCase handlerName (RecC name fields) = do let toolName = T.pack . toSnakeCase . nameBase $ name body <- mkRecordCase name handlerName fields+ clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) []+mkToolCase handlerName (NormalC name [(_bang, paramType)]) = do+ let toolName = T.pack . toSnakeCase . nameBase $ name+ body <- mkSeparateParamsCase name handlerName paramType clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) [] mkToolCase _ _ = fail "Unsupported constructor type for tools"
test/Main.hs view
@@ -146,6 +146,22 @@ 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@@ -177,6 +193,120 @@ 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@@ -315,7 +445,11 @@ descriptionResult <- testCustomDescriptions putStrLn $ if descriptionResult then "PASS" else "FAIL" - let allPassed = promptResult && resourceResult && toolResult && schemaResult && descriptionResult+ 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
test/TestTypes.hs view
@@ -26,6 +26,25 @@ | Search { query :: Text, limit :: Maybe Int, caseSensitive :: Maybe Bool } deriving (Show, Eq) +-- Test separate parameter types approach (should fail with current implementation)+data GetValueParams = GetValueParams { _gvpKey :: Text }+ deriving (Show, Eq)+data SetValueParams = SetValueParams { _svpKey :: Text, _svpValue :: Text }+ deriving (Show, Eq)++data SeparateParamsTool+ = GetValue GetValueParams+ | SetValue SetValueParams+ deriving (Show, Eq)++-- Test recursive parameter types+data InnerParams = InnerParams { _ipName :: Text, _ipAge :: Int }+ deriving (Show, Eq)+data MiddleParams = MiddleParams InnerParams+ deriving (Show, Eq)+data RecursiveTool = ProcessData MiddleParams+ deriving (Show, Eq)+ -- Handler functions handleTestPrompt :: TestPrompt -> IO Content handleTestPrompt (SimplePrompt msg) = @@ -60,6 +79,18 @@ 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)) = + pure $ ContentText $ "Getting value for key: " <> key+handleSeparateParamsTool (SetValue (SetValueParams key value)) = + pure $ ContentText $ "Setting " <> key <> " = " <> value++-- Handler for recursive tool+handleRecursiveTool :: RecursiveTool -> IO Content+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 = @@ -69,4 +100,17 @@ , ("operation", "The mathematical operation to perform") , ("x", "The first number") , ("y", "The second number")+ ]++-- Test descriptions for separate parameter types+separateParamsDescriptions :: [(String, String)]+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")+ , ("_svpKey", "The key to set the value for")+ , ("_svpValue", "The value to store")+ , ("ProcessData", "Processes user data with age validation")+ , ("_ipName", "The person's full name")+ , ("_ipAge", "The person's age in years") ]