mcp-server 0.1.0.3 → 0.1.0.4
raw patch · 3 files changed
+28/−17 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- mcp-server.cabal +1/−1
- src/MCP/Server/Derive.hs +21/−10
- test/Main.hs +6/−6
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.3+version: 0.1.0.4 -- 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
@@ -12,9 +12,20 @@ import qualified Data.Text as T import Language.Haskell.TH import Text.Read (readMaybe)+import qualified Data.Char as Char import MCP.Server.Types +-- Helper function to convert PascalCase/camelCase to snake_case+toSnakeCase :: String -> String+toSnakeCase [] = []+toSnakeCase (x:xs) = Char.toLower x : go xs+ where+ go [] = []+ go (c:cs)+ | Char.isUpper c = '_' : Char.toLower c : go cs+ | otherwise = c : go cs+ -- 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@@ -49,14 +60,14 @@ mkPromptDef :: Con -> Q Exp mkPromptDef (NormalC name []) = do- let promptName = T.toLower . T.pack . nameBase $ name+ 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.toLower . T.pack . nameBase $ name+ let promptName = T.pack . toSnakeCase . nameBase $ name args <- sequence $ map mkArgDef fields [| PromptDefinition { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)@@ -78,14 +89,14 @@ mkPromptCase :: Name -> Con -> Q Clause mkPromptCase handlerName (NormalC name []) = do- let promptName = T.toLower . T.pack . nameBase $ name+ 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.toLower . T.pack . nameBase $ name+ let promptName = T.pack . toSnakeCase . nameBase $ name body <- mkRecordCase name handlerName fields clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) [] mkPromptCase _ _ = fail "Unsupported constructor type"@@ -191,7 +202,7 @@ mkResourceDef :: Con -> Q Exp mkResourceDef (NormalC name []) = do- let resourceName = T.toLower . T.pack . nameBase $ name+ let resourceName = T.pack . toSnakeCase . nameBase $ name let resourceURI = "resource://" <> T.unpack resourceName [| ResourceDefinition { resourceDefinitionURI = $(litE $ stringL resourceURI)@@ -203,7 +214,7 @@ mkResourceCase :: Name -> Con -> Q Clause mkResourceCase handlerName (NormalC name []) = do- let resourceName = T.toLower . T.pack . nameBase $ name+ let resourceName = T.pack . toSnakeCase . nameBase $ name let resourceURI = "resource://" <> T.unpack resourceName clause [litP $ stringL resourceURI] (normalB [| Right <$> $(varE handlerName) $(conE name) |])@@ -239,7 +250,7 @@ mkToolDef :: Con -> Q Exp mkToolDef (NormalC name []) = do- let toolName = T.toLower . T.pack . nameBase $ name+ let toolName = T.pack . toSnakeCase . nameBase $ name [| ToolDefinition { toolDefinitionName = $(litE $ stringL $ T.unpack toolName) , toolDefinitionDescription = $(litE $ stringL $ nameBase name)@@ -249,7 +260,7 @@ } } |] mkToolDef (RecC name fields) = do- let toolName = T.toLower . T.pack . nameBase $ name+ let toolName = T.pack . toSnakeCase . nameBase $ name props <- sequence $ map mkProperty fields requiredFields <- return $ map (\(fieldName, _, fieldType) -> let isOptional = case fieldType of@@ -293,14 +304,14 @@ mkToolCase :: Name -> Con -> Q Clause mkToolCase handlerName (NormalC name []) = do- let toolName = T.toLower . T.pack . nameBase $ name+ 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.toLower . T.pack . nameBase $ name+ let toolName = T.pack . toSnakeCase . nameBase $ name body <- mkRecordCase name handlerName fields clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) [] mkToolCase _ _ = fail "Unsupported constructor type for tools"
test/Main.hs view
@@ -148,25 +148,25 @@ let (_, getHandler) = testPromptHandlers -- Test simple prompt- result1 <- getHandler "simpleprompt" [("message", "hello")]+ result1 <- getHandler "simple_prompt" [("message", "hello")] let test1 = case result1 of Right (ContentText content) -> content == "Simple prompt: hello" _ -> False -- Test complex prompt with multiple types- result2 <- getHandler "complexprompt" [("title", "urgent task"), ("priority", "5"), ("urgent", "true")]+ result2 <- getHandler "complex_prompt" [("title", "urgent task"), ("priority", "5"), ("urgent", "true")] let test2 = case result2 of Right (ContentText content) -> content == "Complex prompt: urgent task (priority=5, urgent=True)" _ -> False -- Test optional prompt with missing optional field- result3 <- getHandler "optionalprompt" [("required", "test")]+ result3 <- getHandler "optional_prompt" [("required", "test")] let test3 = case result3 of Right (ContentText content) -> content == "Optional prompt: test" _ -> False -- Test optional prompt with optional field present- result4 <- getHandler "optionalprompt" [("required", "test"), ("optional", "42")]+ result4 <- getHandler "optional_prompt" [("required", "test"), ("optional", "42")] let test4 = case result4 of Right (ContentText content) -> content == "Optional prompt: test optional=42" _ -> False@@ -178,7 +178,7 @@ let (_, readHandler) = testResourceHandlers -- Test simple resource- case parseURI "resource://configfile" of+ case parseURI "resource://config_file" of Just uri1 -> do result1 <- readHandler uri1 let test1 = case result1 of@@ -186,7 +186,7 @@ _ -> False -- Test parameterized resource (this would need to match actual schema)- case parseURI "resource://databaseconnection" of+ case parseURI "resource://database_connection" of Just uri2 -> do result2 <- readHandler uri2 let test2 = case result2 of