diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,12 @@ # Revision history for mcp-server -## Unreleased +## 0.1.0.19 - ??? + +* Improve handler code generated by TemplateHaskell functions in `MCP.Server.Derive`: + * Don't repeat `Map.fromList` for each argument in map lookup + * Properly handle argument parse errors (Return `InvalidParams` error instead of crashing mcp server with `error`) + +## 0.1.0.18 - 2026-02-09 * Switch default-language to GHC2021 to support broader range of GHC versions (9.6 - 9.12) 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.18 +version: 0.1.0.19 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package. @@ -45,8 +45,10 @@ extra-doc-files: CHANGELOG.md README.md - -tested-with: ghc ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 +tested-with: GHC == 9.6.7 + || == 9.8.4 + || == 9.10.3 + || == 9.12.2 -- Extra source files to be distributed with the package, such as examples, or a tutorial module. -- extra-source-files: SPEC.md @@ -56,9 +58,7 @@ location: https://github.com/drshade/haskell-mcp-server.git common warnings - ghc-options: - -Wall - -Wunused-packages + ghc-options: -Wall -Wunused-packages library -- Import common warning flags. @@ -74,6 +74,9 @@ MCP.Server.Transport.Stdio MCP.Server.Types + other-modules: + MCP.Server.Derive.Internal + -- Modules included in this library but not exported. -- other-modules: -- LANGUAGE extensions used by modules in this package. @@ -168,6 +171,7 @@ Spec.JSONConversion Spec.ProtocolVersionNegotiation Spec.SchemaValidation + Spec.ToolCallParsing Spec.UnicodeHandling TestData TestTypes 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 @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +-- | Template Haskell utilities for deriving MCP handlers from data types. module MCP.Server.Derive ( -- * Template Haskell Derivation derivePromptHandler @@ -12,14 +13,22 @@ ) where import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import qualified Data.Text as T import Language.Haskell.TH -import Text.Read (readMaybe) import qualified Data.Char as Char +import MCP.Server.Derive.Internal import MCP.Server.Types +------------------------------------------------------------------------------- +-- Small helpers +------------------------------------------------------------------------------- + -- Helper function to convert PascalCase/camelCase to snake_case +-- +-- >>> toSnakeCase "GetValue" +-- "get_value" toSnakeCase :: String -> String toSnakeCase [] = [] toSnakeCase (x:xs) = Char.toLower x : go xs @@ -29,84 +38,111 @@ | Char.isUpper c = '_' : Char.toLower c : go cs | otherwise = c : go cs +-- Snake-cased name from a TH Name +snakeName :: Name -> String +snakeName = toSnakeCase . nameBase + +-- Check if a type is Maybe, and unwrap it +unwrapMaybe :: Type -> (Bool, Type) +unwrapMaybe (AppT (ConT n) inner) | nameBase n == "Maybe" = (True, inner) +unwrapMaybe other = (False, other) + +-- Look up description with a default +descriptionFor :: [(String, String)] -> String -> String -> String +descriptionFor descriptions key fallback = + fromMaybe fallback (lookup key descriptions) + +-- Map a Haskell type to its JSON schema type string +jsonTypeFor :: Type -> String +jsonTypeFor (ConT n) + | nameBase n == "Int" = "integer" + | nameBase n == "Integer" = "integer" + | nameBase n == "Double" = "number" + | nameBase n == "Float" = "number" + | nameBase n == "Bool" = "boolean" +jsonTypeFor _ = "string" + -- 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 with custom descriptions --- Usage: $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")]) +-- Get fields from a constructor: [] for nullary, record fields for RecC, +-- extracted fields for single-param NormalC +getConFields :: Con -> Q [(Name, Bang, Type)] +getConFields (NormalC _ []) = pure [] +getConFields (RecC _ fields) = pure fields +getConFields (NormalC _ [(_bang, paramType)]) = extractFieldsFromParamType paramType +getConFields _ = fail "Unsupported constructor type" + +-- Get the constructor name from a Con +conName :: Con -> Name +conName (NormalC n _) = n +conName (RecC n _) = n +conName (InfixC _ n _) = n +conName (ForallC _ _ c) = conName c +conName (GadtC (n:_) _ _) = n +conName (RecGadtC (n:_) _ _) = n +conName _ = error "conName: empty GADT constructor list" + +-- Compute required field names (non-Maybe fields) +requiredFieldNames :: [(Name, Bang, Type)] -> [String] +requiredFieldNames fields = + [ nameBase fn | (fn, _, ft) <- fields, not (fst (unwrapMaybe ft)) ] + +------------------------------------------------------------------------------- +-- Prompt derivation +------------------------------------------------------------------------------- + +-- | 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 (mkPromptDefWithDescription descriptions) constructors + promptDefs <- traverse (mkPromptDefWithDescription descriptions) constructors -- Generate list handler listHandlerExp <- [| pure $(return $ ListE promptDefs) |] -- Generate get handler with cases - cases <- sequence $ map (mkPromptCase handlerName) constructors + cases <- traverse (mkDispatchCase 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]) + let getHandlerExp = 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 $ "derivePromptHandlerWithDescription: " ++ show typeName ++ " is not a data type" --- | Derive prompt handlers from a data type --- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt) +-- | Derive prompt handlers from a data type. +-- Usage: +-- +-- > $(derivePromptHandler ''MyPrompt 'handlePrompt) derivePromptHandler :: Name -> Name -> Q Exp derivePromptHandler typeName handlerName = derivePromptHandlerWithDescription typeName handlerName [] 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 = [] - , promptDefinitionTitle = Nothing -- 2025-06-18: New title field - } |] - 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) - , promptDefinitionTitle = Nothing -- 2025-06-18: New title field - } |] - 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) - , promptDefinitionTitle = Nothing -- 2025-06-18: New title field - } |] - _ -> fail "Unsupported constructor type" +mkPromptDefWithDescription descriptions con = do + let name = conName con + let sname = snakeName name + let description = descriptionFor descriptions (nameBase name) ("Handle " ++ nameBase name) + args <- case con of + NormalC _ [] -> pure [] + RecC _ fields -> traverse (mkArgDef descriptions) fields + NormalC _ [(_bang, paramType)] -> extractFieldsFromType descriptions paramType + _ -> fail "Unsupported constructor type" + [| PromptDefinition + { promptDefinitionName = $(litE $ stringL sname) + , promptDefinitionDescription = $(litE $ stringL description) + , promptDefinitionArguments = $(return $ ListE args) + , promptDefinitionTitle = Nothing + } |] -- Extract field definitions from a parameter type recursively extractFieldsFromType :: [(String, String)] -> Type -> Q [Exp] @@ -115,10 +151,10 @@ ConT typeName -> do info <- reify typeName case info of - TyConI (DataD _ _ _ _ [RecC _ fields] _) -> do + TyConI (DataD _ _ _ _ [RecC _ fields] _) -> -- Parameter type is a record with fields - sequence $ map (mkArgDef descriptions) fields - TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> do + traverse (mkArgDef descriptions) fields + TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> -- Parameter type has a single parameter - recurse extractFieldsFromType descriptions innerType _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" @@ -126,104 +162,104 @@ 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 isOptional = fst (unwrapMaybe fieldType) let fieldNameStr = nameBase fieldName - let description = case lookup fieldNameStr descriptions of - Just desc -> desc - Nothing -> fieldNameStr + let description = descriptionFor descriptions fieldNameStr fieldNameStr [| ArgumentDefinition { argumentDefinitionName = $(litE $ stringL fieldNameStr) , argumentDefinitionDescription = $(litE $ stringL description) , argumentDefinitionRequired = $(if isOptional then [| False |] else [| True |]) } |] -mkPromptCase :: Name -> Con -> Q Clause -mkPromptCase handlerName (NormalC name []) = do - let promptName = T.pack . toSnakeCase . 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.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" +------------------------------------------------------------------------------- +-- Dispatch case generation (shared by prompt and tool) +------------------------------------------------------------------------------- -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 +mkDispatchCase :: Name -> Con -> Q Clause +mkDispatchCase handlerName con = do + let name = conName con + let sname = snakeName name + body <- case con of + NormalC _ [] -> [| do - content <- $(varE handlerName') $(return outerConstructorApp) + content <- $(varE handlerName) $(conE name) pure $ Right content |] + RecC _ fields -> + mkRecordCase name handlerName fields + NormalC _ [(_bang, paramType)] -> + mkSeparateParamsCase name handlerName paramType + _ -> fail "Unsupported constructor type" + clause [litP $ stringL sname] (normalB (return body)) [] - 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) +------------------------------------------------------------------------------- +-- Field validation +------------------------------------------------------------------------------- - continuation <- buildNestedFieldValidationWithConstructor outerConName handlerName' paramType' remainingFields (depth + 1) +mkSeparateParamsCase :: Name -> Name -> Type -> Q Exp +mkSeparateParamsCase outerConName handlerName paramType = do + fields <- extractFieldsFromParamType paramType + let argMapName = mkName "argMap" + let mkBaseExp fieldVars = do + paramConstructorApp <- buildParameterConstructor paramType fieldVars + let outerConstructorApp = AppE (ConE outerConName) paramConstructorApp + [| do + content <- $(varE handlerName) $(return outerConstructorApp) + pure $ Right content |] + inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0 + [| let $(varP argMapName) = Map.fromList args in $(return inner) |] - -- 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 +mkRecordCase :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp +mkRecordCase recConName handlerName fields = do + case fields of + [] -> [| do + content <- $(varE handlerName) $(conE recConName) + pure $ Right content |] + _ -> do + let argMapName = mkName "argMap" + let mkBaseExp fieldVars = do + let constructorApp = foldl AppE (ConE recConName) (map VarE fieldVars) + [| do + content <- $(varE handlerName) $(return constructorApp) + pure $ Right content |] + inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0 + [| let $(varP argMapName) = Map.fromList args in $(return inner) |] - 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" |] +-- Build nested case expressions for field validation, supporting any number of fields. +-- The mkBaseExp callback receives field variable names and builds the final expression. +buildFieldValidation :: Name -> Name -> ([Name] -> Q Exp) -> [(Name, Bang, Type)] -> Int -> Q Exp +buildFieldValidation _argMap _handlerName mkBaseExp [] depth = do + let fieldVars = [mkName ("field" ++ show i) | i <- [0..depth-1]] + mkBaseExp fieldVars +buildFieldValidation argMap handlerName mkBaseExp ((fieldName, _, fieldType):remainingFields) depth = do + let fieldStr = nameBase fieldName + let (isOptional, innerType) = unwrapMaybe fieldType + let fieldVar = mkName ("field" ++ show depth) + + continuation <- buildFieldValidation argMap handlerName mkBaseExp remainingFields (depth + 1) + + let parseFunc = mkParseFunc innerType + + let fieldPrefix = litE $ stringL $ "field '" <> fieldStr <> "': " + + if isOptional + then do + [| case Map.lookup $(litE $ stringL fieldStr) $(varE argMap) of + Nothing -> do + let $(varP fieldVar) = Nothing + $(return continuation) + Just raw -> case $(parseFunc) raw of + Left err -> pure $ Left $ InvalidParams ($fieldPrefix <> err) + Right parsed -> do + let $(varP fieldVar) = Just parsed + $(return continuation) |] + else do + [| case Map.lookup $(litE $ stringL fieldStr) $(varE argMap) of + Just raw -> case $(parseFunc) raw of + Left err -> pure $ Left $ InvalidParams ($fieldPrefix <> err) + Right $(varP fieldVar) -> $(return continuation) + Nothing -> pure $ Left $ MissingRequiredParams $(litE $ stringL $ "field '" <> fieldStr <> "' is missing") |] + -- Extract field information from parameter type extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)] extractFieldsFromParamType paramType = do @@ -245,121 +281,66 @@ ConT typeName -> do info <- reify typeName case info of - TyConI (DataD _ _ _ _ [RecC conName _] _) -> do + TyConI (DataD _ _ _ _ [RecC cn _] _) -> -- Record constructor - apply all field variables - return $ foldl AppE (ConE conName) (map VarE fieldVars) - TyConI (DataD _ _ _ _ [NormalC conName [(_bang, innerType)]] _) -> do + return $ foldl AppE (ConE cn) (map VarE fieldVars) + TyConI (DataD _ _ _ _ [NormalC cn [(_bang, innerType)]] _) -> do -- Single parameter constructor - recurse and wrap innerConstructor <- buildParameterConstructor innerType fieldVars - return $ AppE (ConE conName) innerConstructor + return $ AppE (ConE cn) 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 - [] -> [| 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, 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 +-- Select the appropriate parse helper for a given type +mkParseFunc :: Type -> Q Exp +mkParseFunc innerType = case innerType of + ConT n | nameBase n == "Int" -> [| parseInt |] + ConT n | nameBase n == "Integer" -> [| parseInteger |] + ConT n | nameBase n == "Double" -> [| parseDouble |] + ConT n | nameBase n == "Float" -> [| parseFloat |] + ConT n | nameBase n == "Bool" -> [| parseBool |] + _ -> [| parseText |] - 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" |] +------------------------------------------------------------------------------- +-- Resource derivation +------------------------------------------------------------------------------- --- | Derive resource handlers from a data type with custom descriptions --- Usage: $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")]) +-- | 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 (mkResourceDefWithDescription descriptions) constructors - + resourceDefs <- traverse (mkResourceDefWithDescription descriptions) constructors listHandlerExp <- [| pure $(return $ ListE resourceDefs) |] -- Generate read handler with cases - cases <- sequence $ map (mkResourceCase handlerName) constructors + cases <- traverse (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]) + let readHandlerExp = LamE [VarP (mkName "uri")] $ + CaseE (AppE (VarE 'show) (VarE (mkName "uri"))) + (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just readHandlerExp] _ -> fail $ "deriveResourceHandlerWithDescription: " ++ show typeName ++ " is not a data type" --- | Derive resource handlers from a data type --- Usage: $(deriveResourceHandler ''MyResource 'handleResource) +-- | 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 resourceName = T.pack . snakeName $ name let resourceURI = "resource://" <> T.unpack resourceName let constructorName = nameBase name let description = case lookup constructorName descriptions of @@ -379,152 +360,75 @@ mkResourceCase :: Name -> Con -> Q Clause mkResourceCase handlerName (NormalC name []) = do - let resourceName = T.pack . toSnakeCase . nameBase $ name + let resourceName = T.pack . snakeName $ name let resourceURI = "resource://" <> T.unpack resourceName clause [litP $ stringL resourceURI] - (normalB [| $(varE handlerName) $(varE (mkName "uri")) $(conE name) >>= pure . Right |]) + (normalB [| Right <$> $(varE handlerName) $(varE (mkName "uri")) $(conE name) |]) [] mkResourceCase _ _ = fail "Unsupported constructor type for resources" --- | Derive tool handlers from a data type with custom descriptions --- Usage: $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")]) +------------------------------------------------------------------------------- +-- Tool derivation +------------------------------------------------------------------------------- + +-- | 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 (mkToolDefWithDescription descriptions) constructors + toolDefs <- traverse (mkToolDefWithDescription descriptions) constructors listHandlerExp <- [| pure $(return $ ListE toolDefs) |] -- Generate call handler with cases - cases <- sequence $ map (mkToolCase handlerName) constructors + cases <- traverse (mkDispatchCase 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]) + let callHandlerExp = 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 $ "deriveToolHandlerWithDescription: " ++ show typeName ++ " is not a data type" --- | Derive tool handlers from a data type --- Usage: $(deriveToolHandler ''MyTool 'handleTool) +-- | Derive tool handlers from a data type. +-- Usage: +-- +-- > $(deriveToolHandler ''MyTool 'handleTool) deriveToolHandler :: Name -> Name -> Q Exp deriveToolHandler typeName handlerName = deriveToolHandlerWithDescription typeName handlerName [] 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 = [] - } - , toolDefinitionTitle = Nothing -- 2025-06-18: New title field - } |] - 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) - } - , toolDefinitionTitle = Nothing -- 2025-06-18: New title field - } |] - 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) - } - , toolDefinitionTitle = Nothing -- 2025-06-18: New title field - } |] - _ -> fail "Unsupported constructor type for tools" - +mkToolDefWithDescription descriptions con = do + let name = conName con + let sname = snakeName name + let description = descriptionFor descriptions (nameBase name) (nameBase name) + fields <- getConFields con + props <- traverse (mkProperty descriptions) fields + let required = requiredFieldNames fields + [| ToolDefinition + { toolDefinitionName = $(litE $ stringL sname) + , toolDefinitionDescription = $(litE $ stringL description) + , toolDefinitionInputSchema = InputSchemaDefinitionObject + { properties = $(return $ ListE props) + , required = $(return $ ListE $ map (LitE . StringL) required) + } + , toolDefinitionTitle = Nothing + } |] 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" - 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" + let description = descriptionFor descriptions fieldStr fieldStr + let (_, innerType) = unwrapMaybe fieldType + let jsonType = jsonTypeFor innerType [| ($(litE $ stringL fieldStr), InputSchemaDefinitionProperty { propertyType = $(litE $ stringL jsonType) , propertyDescription = $(litE $ stringL description) }) |] - -mkToolCase :: Name -> Con -> Q Clause -mkToolCase handlerName (NormalC name []) = do - let toolName = T.pack . toSnakeCase . 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.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" diff --git a/src/MCP/Server/Derive/Internal.hs b/src/MCP/Server/Derive/Internal.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server/Derive/Internal.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MCP.Server.Derive.Internal + ( parseText + , parseInt + , parseInteger + , parseDouble + , parseFloat + , parseBool + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Text.Read (readMaybe) + +parseText :: Text -> Either Text Text +parseText = Right + +parseInt :: Text -> Either Text Int +parseInt t = case readMaybe (T.unpack t) of + Just v -> Right v + Nothing -> Left $ "Failed to parse Int from: " <> t + +parseInteger :: Text -> Either Text Integer +parseInteger t = case readMaybe (T.unpack t) of + Just v -> Right v + Nothing -> Left $ "Failed to parse Integer from: " <> t + +parseDouble :: Text -> Either Text Double +parseDouble t = case readMaybe (T.unpack t) of + Just v -> Right v + Nothing -> Left $ "Failed to parse Double from: " <> t + +parseFloat :: Text -> Either Text Float +parseFloat t = case readMaybe (T.unpack t) of + Just v -> Right v + Nothing -> Left $ "Failed to parse Float from: " <> t + +parseBool :: Text -> Either Text Bool +parseBool t = case T.toLower t of + "true" -> Right True + "false" -> Right False + _ -> Left $ "Failed to parse Bool from: " <> t diff --git a/test/HspecMain.hs b/test/HspecMain.hs --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -9,6 +9,7 @@ import qualified Spec.AdvancedDerivation import qualified Spec.UnicodeHandling import qualified Spec.ProtocolVersionNegotiation +import qualified Spec.ToolCallParsing main :: IO () main = hspec $ do @@ -19,3 +20,4 @@ Spec.AdvancedDerivation.spec Spec.UnicodeHandling.spec Spec.ProtocolVersionNegotiation.spec + Spec.ToolCallParsing.spec diff --git a/test/Spec/ToolCallParsing.hs b/test/Spec/ToolCallParsing.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ToolCallParsing.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Spec.ToolCallParsing (spec) where + +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestTypes + +allTypesHandlers :: (ToolListHandler IO, ToolCallHandler IO) +allTypesHandlers = $(deriveToolHandler ''AllTypesTool 'handleAllTypesTool) + +callTool :: Text -> [(Text, Text)] -> IO (Either Error Content) +callTool = snd allTypesHandlers + +shouldBeRight :: IO (Either Error Content) -> Text -> IO () +shouldBeRight 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 + +shouldBeInvalidParams :: IO (Either Error Content) -> Text -> IO () +shouldBeInvalidParams action expectedSubstring = do + result <- action + case result of + Left (InvalidParams msg) -> + T.isInfixOf expectedSubstring msg `shouldBe` True + other -> expectationFailure $ "Expected InvalidParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other + +shouldBeMissingParams :: IO (Either Error Content) -> Text -> IO () +shouldBeMissingParams action expectedSubstring = do + result <- action + case result of + Left (MissingRequiredParams msg) -> + T.isInfixOf expectedSubstring msg `shouldBe` True + other -> expectationFailure $ "Expected MissingRequiredParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other + +spec :: Spec +spec = describe "Tool call parsing" $ do + + describe "Required fields — successful parse" $ do + it "parses all required field types" $ + shouldBeRight + (callTool "required_fields" + [ ("rfText", "hello") + , ("rfInt", "42") + , ("rfInteger", "100") + , ("rfDouble", "3.14") + , ("rfFloat", "2.5") + , ("rfBool", "true") + ]) + "text=hello, int=42, integer=100, double=3.14, float=2.5, bool=True" + + describe "Optional fields — present, successful parse" $ do + it "parses all optional field types when present" $ + shouldBeRight + (callTool "optional_fields" + [ ("ofText", "world") + , ("ofInt", "7") + , ("ofInteger", "999") + , ("ofDouble", "1.5") + , ("ofFloat", "0.5") + , ("ofBool", "false") + ]) + "text=world, int=7, integer=999, double=1.5, float=0.5, bool=False" + + describe "Optional fields — missing" $ do + it "handles all optional fields omitted" $ + shouldBeRight + (callTool "optional_fields" []) + "text=Nothing, int=Nothing, integer=Nothing, double=Nothing, float=Nothing, bool=Nothing" + + describe "Required fields — parse failure" $ do + it "fails to parse Int from non-numeric string" $ + shouldBeInvalidParams + (callTool "required_fields" + [ ("rfText", "hello"), ("rfInt", "not_a_number"), ("rfInteger", "1") + , ("rfDouble", "1.0"), ("rfFloat", "1.0"), ("rfBool", "true") + ]) + "field 'rfInt': Failed to parse Int from: not_a_number" + + it "fails to parse Integer from non-numeric string" $ + shouldBeInvalidParams + (callTool "required_fields" + [ ("rfText", "hello"), ("rfInt", "1"), ("rfInteger", "nope") + , ("rfDouble", "1.0"), ("rfFloat", "1.0"), ("rfBool", "true") + ]) + "field 'rfInteger': Failed to parse Integer from: nope" + + it "fails to parse Double from non-numeric string" $ + shouldBeInvalidParams + (callTool "required_fields" + [ ("rfText", "hello"), ("rfInt", "1"), ("rfInteger", "1") + , ("rfDouble", "abc"), ("rfFloat", "1.0"), ("rfBool", "true") + ]) + "field 'rfDouble': Failed to parse Double from: abc" + + it "fails to parse Float from non-numeric string" $ + shouldBeInvalidParams + (callTool "required_fields" + [ ("rfText", "hello"), ("rfInt", "1"), ("rfInteger", "1") + , ("rfDouble", "1.0"), ("rfFloat", "xyz"), ("rfBool", "true") + ]) + "field 'rfFloat': Failed to parse Float from: xyz" + + it "fails to parse Bool from invalid string" $ + shouldBeInvalidParams + (callTool "required_fields" + [ ("rfText", "hello"), ("rfInt", "1"), ("rfInteger", "1") + , ("rfDouble", "1.0"), ("rfFloat", "1.0"), ("rfBool", "maybe") + ]) + "field 'rfBool': Failed to parse Bool from: maybe" + + describe "Optional fields — parse failure" $ do + it "fails to parse optional Int from invalid value" $ + shouldBeInvalidParams + (callTool "optional_fields" [("ofInt", "bad")]) + "field 'ofInt': Failed to parse Int from: bad" + + it "fails to parse optional Integer from invalid value" $ + shouldBeInvalidParams + (callTool "optional_fields" [("ofInteger", "bad")]) + "field 'ofInteger': Failed to parse Integer from: bad" + + it "fails to parse optional Double from invalid value" $ + shouldBeInvalidParams + (callTool "optional_fields" [("ofDouble", "bad")]) + "field 'ofDouble': Failed to parse Double from: bad" + + it "fails to parse optional Float from invalid value" $ + shouldBeInvalidParams + (callTool "optional_fields" [("ofFloat", "bad")]) + "field 'ofFloat': Failed to parse Float from: bad" + + it "fails to parse optional Bool from invalid value" $ + shouldBeInvalidParams + (callTool "optional_fields" [("ofBool", "bad")]) + "field 'ofBool': Failed to parse Bool from: bad" + + describe "Missing required field" $ do + it "reports missing required field" $ + shouldBeMissingParams + (callTool "required_fields" [("rfText", "hello")]) + "is missing" diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -92,6 +92,46 @@ handleRecursiveTool (ProcessData (MiddleParams (InnerParams name age))) = pure $ ContentText $ "Processing data for " <> name <> " (age " <> T.pack (show age) <> ")" +-- Type covering all parseable field types for exhaustive parsing tests +data AllTypesTool + = RequiredFields + { rfText :: Text + , rfInt :: Int + , rfInteger :: Integer + , rfDouble :: Double + , rfFloat :: Float + , rfBool :: Bool + } + | OptionalFields + { ofText :: Maybe Text + , ofInt :: Maybe Int + , ofInteger :: Maybe Integer + , ofDouble :: Maybe Double + , ofFloat :: Maybe Float + , ofBool :: Maybe Bool + } + deriving (Show, Eq) + +handleAllTypesTool :: AllTypesTool -> IO Content +handleAllTypesTool (RequiredFields t i ig d f b) = + pure $ ContentText $ T.intercalate ", " + [ "text=" <> t + , "int=" <> T.pack (show i) + , "integer=" <> T.pack (show ig) + , "double=" <> T.pack (show d) + , "float=" <> T.pack (show f) + , "bool=" <> T.pack (show b) + ] +handleAllTypesTool (OptionalFields t i ig d f b) = + pure $ ContentText $ T.intercalate ", " + [ "text=" <> maybe "Nothing" id t + , "int=" <> maybe "Nothing" (T.pack . show) i + , "integer=" <> maybe "Nothing" (T.pack . show) ig + , "double=" <> maybe "Nothing" (T.pack . show) d + , "float=" <> maybe "Nothing" (T.pack . show) f + , "bool=" <> maybe "Nothing" (T.pack . show) b + ] + -- Test descriptions for custom description functionality testDescriptions :: [(String, String)] testDescriptions =