mcp-server 0.1.0.4 → 0.1.0.5
raw patch · 6 files changed
+202/−80 lines, 6 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ MCP.Server.Derive: derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
+ MCP.Server.Derive: deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
+ MCP.Server.Derive: deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
Files
- examples/Simple/Main.hs +2/−2
- examples/Simple/Types.hs +8/−0
- mcp-server.cabal +1/−1
- src/MCP/Server/Derive.hs +133/−76
- test/Main.hs +47/−1
- test/TestTypes.hs +11/−0
examples/Simple/Main.hs view
@@ -32,8 +32,8 @@ hPutStrLn stderr "Using Template Haskell derivation for tools" hPutStrLn stderr "Ready for JSON-RPC communication" - -- Derive the tool handlers using Template Haskell- let tools = $(deriveToolHandler ''SimpleTool 'handleTool)+ -- Derive the tool handlers using Template Haskell with descriptions+ let tools = $(deriveToolHandlerWithDescription ''SimpleTool 'handleTool simpleDescriptions) in runMcpServerStdIn McpServerInfo { serverName = "Simple Key-Value MCP Server"
examples/Simple/Types.hs view
@@ -8,3 +8,11 @@ = GetValue { key :: Text } | SetValue { key :: Text, value :: Text } deriving (Show, Eq)++simpleDescriptions :: [(String, String)]+simpleDescriptions =+ [ ("GetValue", "Retrieve the value associated with the given key")+ , ("SetValue", "Set the value for the given key")+ , ("key", "The key to look up or set")+ , ("value", "The value to store")+ ]
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.4+version: 0.1.0.5 -- 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
@@ -4,8 +4,11 @@ module MCP.Server.Derive ( -- * Template Haskell Derivation derivePromptHandler+ , derivePromptHandlerWithDescription , deriveResourceHandler+ , deriveResourceHandlerWithDescription , deriveToolHandler+ , deriveToolHandlerWithDescription ) where import qualified Data.Map as Map@@ -30,15 +33,15 @@ clauseToMatch :: Clause -> Match clauseToMatch (Clause ps b ds) = Match (case ps of [p] -> p; _ -> TupP ps) b ds --- | Derive prompt handlers from a data type--- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt)-derivePromptHandler :: Name -> Name -> Q Exp-derivePromptHandler typeName handlerName = do+-- | Derive prompt handlers from a data type with custom descriptions+-- Usage: $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")])+derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp+derivePromptHandlerWithDescription typeName handlerName descriptions = do info <- reify typeName case info of TyConI (DataD _ _ _ _ constructors _) -> do -- Generate prompt definitions- promptDefs <- sequence $ map mkPromptDef constructors+ promptDefs <- sequence $ map (mkPromptDefWithDescription descriptions) constructors -- Generate list handler listHandlerExp <- [| \_cursor -> pure $ PaginatedResult@@ -56,34 +59,55 @@ (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just getHandlerExp]- _ -> fail $ "derivePromptHandler: " ++ show typeName ++ " is not a data type"+ _ -> fail $ "derivePromptHandlerWithDescription: " ++ show typeName ++ " is not a data type" -mkPromptDef :: Con -> Q Exp-mkPromptDef (NormalC name []) = do- let promptName = T.pack . toSnakeCase . nameBase $ name- [| PromptDefinition- { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)- , promptDefinitionDescription = $(litE $ stringL $ "Handle " ++ nameBase name)- , promptDefinitionArguments = []- } |]-mkPromptDef (RecC name fields) = do- let promptName = T.pack . toSnakeCase . nameBase $ name- args <- sequence $ map mkArgDef fields- [| PromptDefinition- { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)- , promptDefinitionDescription = $(litE $ stringL $ "Handle " ++ nameBase name)- , promptDefinitionArguments = $(return $ ListE args)- } |]-mkPromptDef _ = fail "Unsupported constructor type"+-- | Derive prompt handlers from a data type+-- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt)+derivePromptHandler :: Name -> Name -> Q Exp+derivePromptHandler typeName handlerName = + derivePromptHandlerWithDescription typeName handlerName [] -mkArgDef :: (Name, Bang, Type) -> Q Exp-mkArgDef (fieldName, _, fieldType) = do+mkPromptDefWithDescription :: [(String, String)] -> Con -> Q Exp+mkPromptDefWithDescription descriptions con = + case con of+ NormalC name [] -> do+ let promptName = T.pack . toSnakeCase . nameBase $ name+ let constructorName = nameBase name+ let description = case lookup constructorName descriptions of+ Just desc -> desc+ Nothing -> "Handle " ++ constructorName+ [| PromptDefinition+ { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)+ , promptDefinitionDescription = $(litE $ stringL description)+ , promptDefinitionArguments = []+ } |]+ RecC name fields -> do+ 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 <- sequence $ map (mkArgDef descriptions) fields+ [| PromptDefinition+ { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)+ , promptDefinitionDescription = $(litE $ stringL description)+ , promptDefinitionArguments = $(return $ ListE args)+ } |]+ _ -> fail "Unsupported constructor type"+++mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp+mkArgDef descriptions (fieldName, _, fieldType) = do let isOptional = case fieldType of AppT (ConT n) _ -> nameBase n == "Maybe" _ -> False+ let fieldNameStr = nameBase fieldName+ let description = case lookup fieldNameStr descriptions of+ Just desc -> desc+ Nothing -> fieldNameStr [| ArgumentDefinition- { argumentDefinitionName = $(litE $ stringL $ nameBase fieldName)- , argumentDefinitionDescription = $(litE $ stringL $ nameBase fieldName)+ { argumentDefinitionName = $(litE $ stringL fieldNameStr)+ , argumentDefinitionDescription = $(litE $ stringL description) , argumentDefinitionRequired = $(if isOptional then [| False |] else [| True |]) } |] @@ -173,15 +197,15 @@ $(return continuation) Nothing -> pure $ Left $ MissingRequiredParams $ "field '" <> $(litE $ stringL fieldStr) <> "' is missing" |] --- | Derive resource handlers from a data type--- Usage: $(deriveResourceHandler ''MyResource 'handleResource)-deriveResourceHandler :: Name -> Name -> Q Exp-deriveResourceHandler typeName handlerName = do+-- | Derive resource handlers from a data type with custom descriptions+-- Usage: $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")])+deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp+deriveResourceHandlerWithDescription typeName handlerName descriptions = do info <- reify typeName case info of TyConI (DataD _ _ _ _ constructors _) -> do -- Generate resource definitions- resourceDefs <- sequence $ map mkResourceDef constructors+ resourceDefs <- sequence $ map (mkResourceDefWithDescription descriptions) constructors listHandlerExp <- [| \_cursor -> pure $ PaginatedResult { paginatedItems = $(return $ ListE resourceDefs)@@ -198,20 +222,33 @@ (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just readHandlerExp]- _ -> fail $ "deriveResourceHandler: " ++ show typeName ++ " is not a data type"+ _ -> fail $ "deriveResourceHandlerWithDescription: " ++ show typeName ++ " is not a data type" -mkResourceDef :: Con -> Q Exp-mkResourceDef (NormalC name []) = do+-- | Derive resource handlers from a data type+-- Usage: $(deriveResourceHandler ''MyResource 'handleResource)+deriveResourceHandler :: Name -> Name -> Q Exp+deriveResourceHandler typeName handlerName = + deriveResourceHandlerWithDescription typeName handlerName []++mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp+mkResourceDefWithDescription descriptions (NormalC name []) = do let resourceName = T.pack . toSnakeCase . nameBase $ name let resourceURI = "resource://" <> T.unpack resourceName+ let constructorName = nameBase name+ let description = case lookup constructorName descriptions of+ Just desc -> Just desc+ Nothing -> Just constructorName [| ResourceDefinition { resourceDefinitionURI = $(litE $ stringL resourceURI) , resourceDefinitionName = $(litE $ stringL $ T.unpack resourceName)- , resourceDefinitionDescription = Just $(litE $ stringL $ nameBase name)+ , resourceDefinitionDescription = $(case description of+ Just desc -> [| Just $(litE $ stringL desc) |]+ Nothing -> [| Nothing |]) , resourceDefinitionMimeType = Just "text/plain" } |]-mkResourceDef _ = fail "Unsupported constructor type for resources"+mkResourceDefWithDescription _ _ = fail "Unsupported constructor type for resources" + mkResourceCase :: Name -> Con -> Q Clause mkResourceCase handlerName (NormalC name []) = do let resourceName = T.pack . toSnakeCase . nameBase $ name@@ -221,15 +258,15 @@ [] mkResourceCase _ _ = fail "Unsupported constructor type for resources" --- | Derive tool handlers from a data type--- Usage: $(deriveToolHandler ''MyTool 'handleTool)-deriveToolHandler :: Name -> Name -> Q Exp-deriveToolHandler typeName handlerName = do+-- | Derive tool handlers from a data type with custom descriptions+-- Usage: $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")])+deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp+deriveToolHandlerWithDescription typeName handlerName descriptions = do info <- reify typeName case info of TyConI (DataD _ _ _ _ constructors _) -> do -- Generate tool definitions- toolDefs <- sequence $ map mkToolDef constructors+ toolDefs <- sequence $ map (mkToolDefWithDescription descriptions) constructors listHandlerExp <- [| \_cursor -> pure $ PaginatedResult { paginatedItems = $(return $ ListE toolDefs)@@ -246,42 +283,62 @@ (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just callHandlerExp]- _ -> fail $ "deriveToolHandler: " ++ show typeName ++ " is not a data type"+ _ -> fail $ "deriveToolHandlerWithDescription: " ++ show typeName ++ " is not a data type" -mkToolDef :: Con -> Q Exp-mkToolDef (NormalC name []) = do- let toolName = T.pack . toSnakeCase . nameBase $ name- [| ToolDefinition- { toolDefinitionName = $(litE $ stringL $ T.unpack toolName)- , toolDefinitionDescription = $(litE $ stringL $ nameBase name)- , toolDefinitionInputSchema = InputSchemaDefinitionObject- { properties = []- , required = []- }- } |]-mkToolDef (RecC name fields) = do- let toolName = T.pack . toSnakeCase . nameBase $ name- props <- sequence $ map mkProperty 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 $ nameBase name)- , toolDefinitionInputSchema = InputSchemaDefinitionObject- { properties = $(return $ ListE props)- , required = $(return $ ListE $ map (LitE . StringL) required)- }- } |]-mkToolDef _ = fail "Unsupported constructor type for tools"+-- | Derive tool handlers from a data type+-- Usage: $(deriveToolHandler ''MyTool 'handleTool)+deriveToolHandler :: Name -> Name -> Q Exp+deriveToolHandler typeName handlerName = + deriveToolHandlerWithDescription typeName handlerName [] -mkProperty :: (Name, Bang, Type) -> Q Exp-mkProperty (fieldName, _, fieldType) = do+mkToolDefWithDescription :: [(String, String)] -> Con -> Q Exp+mkToolDefWithDescription descriptions con = + case con of+ NormalC name [] -> do+ let toolName = T.pack . toSnakeCase . nameBase $ name+ let constructorName = nameBase name+ let description = case lookup constructorName descriptions of+ Just desc -> desc+ Nothing -> constructorName+ [| ToolDefinition+ { toolDefinitionName = $(litE $ stringL $ T.unpack toolName)+ , toolDefinitionDescription = $(litE $ stringL description)+ , toolDefinitionInputSchema = InputSchemaDefinitionObject+ { properties = []+ , required = []+ }+ } |]+ RecC name fields -> do+ let toolName = T.pack . toSnakeCase . nameBase $ name+ let constructorName = nameBase name+ let description = case lookup constructorName descriptions of+ Just desc -> desc+ Nothing -> constructorName+ 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"+++mkProperty :: [(String, String)] -> (Name, Bang, Type) -> Q Exp+mkProperty descriptions (fieldName, _, fieldType) = do let fieldStr = nameBase fieldName+ let description = case lookup fieldStr descriptions of+ Just desc -> desc+ Nothing -> fieldStr let jsonType = case fieldType of ConT n | nameBase n == "Int" -> "integer" ConT n | nameBase n == "Integer" -> "integer"@@ -299,7 +356,7 @@ _ -> "string" [| ($(litE $ stringL fieldStr), InputSchemaDefinitionProperty { propertyType = $(litE $ stringL jsonType)- , propertyDescription = $(litE $ stringL fieldStr)+ , propertyDescription = $(litE $ stringL description) }) |] mkToolCase :: Name -> Con -> Q Clause
test/Main.hs view
@@ -142,6 +142,10 @@ testToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) testToolHandlers = $(deriveToolHandler ''TestTool 'handleTestTool) +-- Test handlers with custom descriptions+testToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO)+testToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''TestTool 'handleTestTool testDescriptions)+ -- End-to-end test functions testPromptDerivation :: IO Bool testPromptDerivation = do@@ -226,6 +230,44 @@ return (test1 && test2 && test3 && test4) +testCustomDescriptions :: IO Bool+testCustomDescriptions = do+ let (toolListHandler, _) = testToolHandlersWithDescriptions+ + paginatedResult <- toolListHandler Nothing+ let toolDefs = paginatedItems paginatedResult+ + -- 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@@ -271,7 +313,11 @@ schemaResult <- testSchemaGeneration putStrLn $ if schemaResult then "PASS" else "FAIL" - let allPassed = promptResult && resourceResult && toolResult && schemaResult+ putStr "Testing custom descriptions: "+ descriptionResult <- testCustomDescriptions+ putStrLn $ if descriptionResult then "PASS" else "FAIL"+ + let allPassed = promptResult && resourceResult && toolResult && schemaResult && descriptionResult putStrLn $ "End-to-End result: " ++ if allPassed then "PASS" else "FAIL" return allPassed
test/TestTypes.hs view
@@ -59,3 +59,14 @@ pure $ ContentText $ "Search results for '" <> query <> "'" <> maybe "" ((" (limit=" <>) . (<> ")") . T.pack . show) limit <> maybe "" ((" (case-sensitive=" <>) . (<> ")") . T.pack . show) caseSens++-- Test descriptions for custom description functionality+testDescriptions :: [(String, String)]+testDescriptions = + [ ("Echo", "Echoes the input text back to the user")+ , ("Calculate", "Performs mathematical calculations")+ , ("text", "The text to echo back")+ , ("operation", "The mathematical operation to perform")+ , ("x", "The first number")+ , ("y", "The second number")+ ]