mcp-server 0.1.0.0 → 0.1.0.1
raw patch · 4 files changed
+206/−124 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- examples/TemplateHaskell.hs +4/−0
- examples/Types.hs +1/−0
- mcp-server.cabal +1/−1
- src/MCP/Server/Derive.hs +200/−123
examples/TemplateHaskell.hs view
@@ -28,6 +28,10 @@ Just cat -> pure $ ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products" handleTool (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items" handleTool Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!"+handleTool (ComplexTool field1 field2 field3 field4 field5) = + pure $ ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <> + maybe "" (", " <>) field3 <> ", " <> field4 <> + maybe "" (", " <>) field5 main :: IO () main = do
examples/Types.hs view
@@ -21,4 +21,5 @@ = SearchForProduct { q :: Text, category :: Maybe Text } | AddToCart { sku :: Text } | Checkout+ | ComplexTool { field1 :: Text, field2 :: Text, field3 :: Maybe Text, field4 :: Text, field5 :: Maybe Text } deriving (Show, Eq)
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.0+version: 0.1.0.1 -- 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
@@ -14,165 +14,242 @@ import MCP.Server.Types +-- Helper function to convert Clause to Match+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 info <- reify typeName case info of- TyConI (DataD _ _ _ _ _constructors _) -> do- -- For now, return a basic working implementation+ TyConI (DataD _ _ _ _ constructors _) -> do+ -- Generate prompt definitions+ promptDefs <- sequence $ map mkPromptDef constructors+ + -- Generate list handler listHandlerExp <- [| \_cursor -> pure $ PaginatedResult- { paginatedItems =- [ PromptDefinition- { promptDefinitionName = "recipe"- , promptDefinitionDescription = "Generate a detailed recipe"- , promptDefinitionArguments =- [ ArgumentDefinition- { argumentDefinitionName = "idea"- , argumentDefinitionDescription = "Recipe idea"- , argumentDefinitionRequired = True- }- ]- }- , PromptDefinition- { promptDefinitionName = "shopping"- , promptDefinitionDescription = "Create a shopping list"- , promptDefinitionArguments =- [ ArgumentDefinition- { argumentDefinitionName = "description"- , argumentDefinitionDescription = "Shopping description"- , argumentDefinitionRequired = True- }- ]- }- ]+ { paginatedItems = $(return $ ListE promptDefs) , paginatedNextCursor = Nothing } |]-- getHandlerExp <- [| \name args -> case T.unpack name of- "recipe" -> case Map.lookup "idea" (Map.fromList args) of- Nothing -> pure $ Left $ MissingRequiredParams "field 'idea' is missing"- Just idea -> do- content <- $(varE handlerName) (Recipe idea)- pure $ Right content- "shopping" -> case Map.lookup "description" (Map.fromList args) of- Nothing -> pure $ Left $ MissingRequiredParams "field 'description' is missing"- Just desc -> do- content <- $(varE handlerName) (Shopping desc)- pure $ Right content- _ -> pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |]-+ + -- 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"))) + (map clauseToMatch cases ++ [defaultMatch])+ return $ TupE [Just listHandlerExp, Just getHandlerExp] _ -> fail $ "derivePromptHandler: " ++ show typeName ++ " is not a data type" +mkPromptDef :: Con -> Q Exp+mkPromptDef (NormalC name []) = do+ let promptName = T.toLower . T.pack . nameBase $ name+ [| PromptDefinition+ { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)+ , promptDefinitionDescription = $(litE $ stringL $ "Handle " ++ nameBase name)+ , promptDefinitionArguments = []+ } |]+mkPromptDef (RecC name fields) = do+ let promptName = T.toLower . T.pack . 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"++mkArgDef :: (Name, Bang, Type) -> Q Exp+mkArgDef (fieldName, _, fieldType) = do+ let isOptional = case fieldType of+ AppT (ConT n) _ -> nameBase n == "Maybe"+ _ -> False+ [| ArgumentDefinition+ { argumentDefinitionName = $(litE $ stringL $ nameBase fieldName)+ , argumentDefinitionDescription = $(litE $ stringL $ nameBase fieldName)+ , argumentDefinitionRequired = $(if isOptional then [| False |] else [| True |])+ } |]++mkPromptCase :: Name -> Con -> Q Clause+mkPromptCase handlerName (NormalC name []) = do+ let promptName = T.toLower . T.pack . nameBase $ name+ clause [litP $ stringL $ T.unpack promptName]+ (normalB [| do+ content <- $(varE handlerName) $(conE name)+ pure $ Right content |])+ []+mkPromptCase handlerName (RecC name fields) = do+ let promptName = T.toLower . T.pack . nameBase $ name+ body <- mkRecordCase name handlerName fields+ clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) []+mkPromptCase _ _ = fail "Unsupported constructor type"++mkRecordCase :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp+mkRecordCase conName handlerName fields = do+ case fields of+ [] -> [| do+ content <- $(varE handlerName) $(conE conName)+ pure $ Right content |]+ _ -> do+ -- Build nested case expressions for field validation+ buildNestedFieldValidation conName handlerName fields 0++-- Build nested case expressions for field validation, supporting any number of fields+buildNestedFieldValidation :: Name -> Name -> [(Name, Bang, Type)] -> Int -> Q Exp+buildNestedFieldValidation conName handlerName [] depth = do+ -- Base case: all fields validated, build constructor application+ let fieldVars = [mkName ("field" ++ show i) | i <- [0..depth-1]]+ let constructorApp = foldl AppE (ConE conName) (map VarE fieldVars)+ [| do+ content <- $(varE handlerName) $(return constructorApp)+ pure $ Right content |]++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 fieldVar = mkName ("field" ++ show depth)+ + continuation <- buildNestedFieldValidation conName handlerName remainingFields (depth + 1)+ + 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" |]+ -- | Derive resource handlers from a data type -- Usage: $(deriveResourceHandler ''MyResource 'handleResource) deriveResourceHandler :: Name -> Name -> Q Exp deriveResourceHandler typeName handlerName = do info <- reify typeName case info of- TyConI (DataD _ _ _ _ _constructors _) -> do+ TyConI (DataD _ _ _ _ constructors _) -> do+ -- Generate resource definitions+ resourceDefs <- sequence $ map mkResourceDef constructors+ listHandlerExp <- [| \_cursor -> pure $ PaginatedResult- { paginatedItems =- [ ResourceDefinition- { resourceDefinitionURI = "resource://productcategories"- , resourceDefinitionName = "productcategories"- , resourceDefinitionDescription = Just "Product categories"- , resourceDefinitionMimeType = Just "text/plain"- }- , ResourceDefinition- { resourceDefinitionURI = "resource://saleitems"- , resourceDefinitionName = "saleitems"- , resourceDefinitionDescription = Just "Sale items"- , resourceDefinitionMimeType = Just "text/plain"- }- , ResourceDefinition- { resourceDefinitionURI = "resource://headlinebannerad"- , resourceDefinitionName = "headlinebannerad"- , resourceDefinitionDescription = Just "Headline banner ad"- , resourceDefinitionMimeType = Just "text/plain"- }- ]+ { paginatedItems = $(return $ ListE resourceDefs) , paginatedNextCursor = Nothing } |] - readHandlerExp <- [| \uri -> case show uri of- "resource://productcategories" -> Right <$> $(varE handlerName) ProductCategories- "resource://saleitems" -> Right <$> $(varE handlerName) SaleItems- "resource://headlinebannerad" -> Right <$> $(varE handlerName) HeadlineBannerAd- unknown -> pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |]+ -- Generate read handler with cases+ 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"))) + (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just readHandlerExp] _ -> fail $ "deriveResourceHandler: " ++ show typeName ++ " is not a data type" +mkResourceDef :: Con -> Q Exp+mkResourceDef (NormalC name []) = do+ let resourceName = T.toLower . T.pack . nameBase $ name+ let resourceURI = "resource://" <> T.unpack resourceName+ [| ResourceDefinition+ { resourceDefinitionURI = $(litE $ stringL resourceURI)+ , resourceDefinitionName = $(litE $ stringL $ T.unpack resourceName)+ , resourceDefinitionDescription = Just $(litE $ stringL $ nameBase name)+ , resourceDefinitionMimeType = Just "text/plain"+ } |]+mkResourceDef _ = fail "Unsupported constructor type for resources"++mkResourceCase :: Name -> Con -> Q Clause+mkResourceCase handlerName (NormalC name []) = do+ let resourceName = T.toLower . T.pack . nameBase $ name+ let resourceURI = "resource://" <> T.unpack resourceName+ clause [litP $ stringL resourceURI]+ (normalB [| Right <$> $(varE handlerName) $(conE name) |])+ []+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 info <- reify typeName case info of- TyConI (DataD _ _ _ _ _constructors _) -> do+ TyConI (DataD _ _ _ _ constructors _) -> do+ -- Generate tool definitions+ toolDefs <- sequence $ map mkToolDef constructors+ listHandlerExp <- [| \_cursor -> pure $ PaginatedResult- { paginatedItems =- [ ToolDefinition- { toolDefinitionName = "searchforproduct"- , toolDefinitionDescription = "Search for products"- , toolDefinitionInputSchema = InputSchemaDefinitionObject- { properties =- [ ("q", InputSchemaDefinitionProperty- { propertyType = "string"- , propertyDescription = "Search query"- })- , ("category", InputSchemaDefinitionProperty- { propertyType = "string"- , propertyDescription = "Category filter"- })- ]- , required = ["q"]- }- }- , ToolDefinition- { toolDefinitionName = "addtocart"- , toolDefinitionDescription = "Add item to cart"- , toolDefinitionInputSchema = InputSchemaDefinitionObject- { properties =- [ ("sku", InputSchemaDefinitionProperty- { propertyType = "string"- , propertyDescription = "Product SKU"- })- ]- , required = ["sku"]- }- }- , ToolDefinition- { toolDefinitionName = "checkout"- , toolDefinitionDescription = "Complete checkout"- , toolDefinitionInputSchema = InputSchemaDefinitionObject- { properties = []- , required = []- }- }- ]+ { paginatedItems = $(return $ ListE toolDefs) , paginatedNextCursor = Nothing } |] - callHandlerExp <- [| \name args -> case T.unpack name of- "searchforproduct" -> case Map.lookup "q" (Map.fromList args) of- Nothing -> pure $ Left $ MissingRequiredParams "field 'q' is missing"- Just q -> do- let category = Map.lookup "category" (Map.fromList args)- content <- $(varE handlerName) (SearchForProduct q category)- pure $ Right content- "addtocart" -> case Map.lookup "sku" (Map.fromList args) of- Nothing -> pure $ Left $ MissingRequiredParams "field 'sku' is missing"- Just sku -> do- content <- $(varE handlerName) (AddToCart sku)- pure $ Right content- "checkout" -> do- content <- $(varE handlerName) Checkout- pure $ Right content- _ -> pure $ Left $ UnknownTool $ "Unknown tool: " <> name |]+ -- Generate call handler with cases+ 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"))) + (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just callHandlerExp] _ -> fail $ "deriveToolHandler: " ++ show typeName ++ " is not a data type"++mkToolDef :: Con -> Q Exp+mkToolDef (NormalC name []) = do+ let toolName = T.toLower . T.pack . 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.toLower . T.pack . 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"++mkProperty :: (Name, Bang, Type) -> Q Exp+mkProperty (fieldName, _, _) = do+ let fieldStr = nameBase fieldName+ [| ($(litE $ stringL fieldStr), InputSchemaDefinitionProperty+ { propertyType = "string"+ , propertyDescription = $(litE $ stringL fieldStr)+ }) |]++mkToolCase :: Name -> Con -> Q Clause+mkToolCase handlerName (NormalC name []) = do+ let toolName = T.toLower . T.pack . nameBase $ name+ clause [litP $ stringL $ T.unpack toolName]+ (normalB [| do+ content <- $(varE handlerName) $(conE name)+ pure $ Right content |])+ []+mkToolCase handlerName (RecC name fields) = do+ let toolName = T.toLower . T.pack . nameBase $ name+ body <- mkRecordCase name handlerName fields+ clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) []+mkToolCase _ _ = fail "Unsupported constructor type for tools"