From 22c6d2ee7606e05614f41db72b913be5567ef4d6 Mon Sep 17 00:00:00 2001 From: tom Date: Sat, 1 Aug 2026 10:52:42 +0200 Subject: [PATCH 1/4] Definition metadata types and options-based derive customization (core) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - New metadata types: ToolAnnotations (readOnly/destructive/idempotent/ openWorld hints + title, all advisory and unset by default), Icon (src/mimeType/sizes), and content Annotations (audience/priority/ lastModified) attached via the new ContentAnnotated wrapper, whose annotations merge into the inner block's JSON object (and parse back). - Definition types gain the corresponding fields: annotations + icons on ToolDefinition, icons on Prompt/Resource/ResourceTemplate definitions — all omitted from JSON when unset, so existing fixtures are unaffected. - Smart constructors (mkToolDefinition, mkPromptDefinition, mkResourceDefinition, mkResourceTemplateDefinition) build definitions from required fields only, so future optional fields stop breaking manual constructions; in-repo manual sites migrated. - DefinitionOptions: one per-constructor customization record (description, title, icons, tool annotations, and constructor-scoped field descriptions — fixing the old global-namespace wart) behind new WithOptions variants of all five derivations. The legacy [(String, String)] description API is unchanged and now implemented as an adapter over the same generic path. --- src/MCP/Server/Derive.hs | 242 ++++++++++++++++++++++++++--------- src/MCP/Server/Types.hs | 201 ++++++++++++++++++++++++++--- test/Spec/GoldenWire.hs | 28 ++-- test/Spec/UnicodeHandling.hs | 27 ++-- 4 files changed, 394 insertions(+), 104 deletions(-) diff --git a/src/MCP/Server/Derive.hs b/src/MCP/Server/Derive.hs index 3c4de5a..0ef3996 100644 --- a/src/MCP/Server/Derive.hs +++ b/src/MCP/Server/Derive.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -14,27 +15,84 @@ module MCP.Server.Derive ( -- * Template Haskell Derivation derivePromptHandler , derivePromptHandlerWithDescription + , derivePromptHandlerWithOptions , deriveResourceHandler , deriveResourceHandlerWithDescription + , deriveResourceHandlerWithOptions , deriveResourceTemplates , deriveResourceTemplatesWithDescription + , deriveResourceTemplatesWithOptions , deriveToolHandler , deriveToolHandlerWithDescription + , deriveToolHandlerWithOptions , deriveToolHandlerWithOutput , deriveToolHandlerWithOutputDescription + , deriveToolHandlerWithOutputOptions + + -- * Per-constructor customization + , DefinitionOptions(..) + , defaultOptions ) where import Control.Monad (zipWithM) import Data.Aeson (Value (..)) import Data.List (intercalate) import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift, lift) import qualified Data.Char as Char import MCP.Server.Derive.Internal import MCP.Server.Types +-- | Per-constructor customization for the @WithOptions@ derivations: a +-- single mechanism for everything a definition can carry beyond its shape. +-- Entries are looked up by constructor name; for output-typed tool +-- derivations, an entry keyed by the /output type's/ name supplies its +-- field descriptions. +data DefinitionOptions = DefinitionOptions + { optDescription :: Maybe Text + -- ^ The definition's description (falls back to the constructor name) + , optTitle :: Maybe Text + , optIcons :: [Icon] + , optToolAnnotations :: Maybe ToolAnnotations + -- ^ Behavioral hints; meaningful for tools, ignored elsewhere + , optFieldDescriptions :: [(Text, Text)] + -- ^ Field\/argument descriptions, scoped to this constructor — two + -- constructors may describe a same-named field differently + } deriving (Show, Eq, Lift) + +-- | Nothing customized; record-update what you need. +defaultOptions :: DefinitionOptions +defaultOptions = DefinitionOptions + { optDescription = Nothing + , optTitle = Nothing + , optIcons = [] + , optToolAnnotations = Nothing + , optFieldDescriptions = [] + } + +-- | Look up a constructor's options. +optionsFor :: [(String, DefinitionOptions)] -> String -> DefinitionOptions +optionsFor opts name = fromMaybe defaultOptions (lookup name opts) + +-- | Adapt the legacy flat description list to per-constructor options: +-- constructor entries become 'optDescription'; the whole list also serves +-- as the (unscoped) field-description namespace, preserving the old +-- behavior exactly. +optionsFromDescriptions :: [(String, String)] -> String -> DefinitionOptions +optionsFromDescriptions descriptions name = defaultOptions + { optDescription = T.pack <$> lookup name descriptions + } + +-- The merged field-description namespace for one constructor: its scoped +-- entries shadow the legacy global list. +fieldDescsFor :: DefinitionOptions -> [(String, String)] -> [(String, String)] +fieldDescsFor opts globalDescs = + [(T.unpack k, T.unpack v) | (k, v) <- optFieldDescriptions opts] ++ globalDescs + ------------------------------------------------------------------------------- -- Small helpers ------------------------------------------------------------------------------- @@ -143,8 +201,8 @@ mkValueParser ty = case ty of cons <- reifyCons n case cons of Just cs | not (null cs), all isNullary cs -> mkEnumValueParser n cs - Just [RecC icon ifields] -> mkObjectParser n icon ifields - Just [NormalC icon [(_bang, inner)]] -> [| fmap $(conE icon) . $(mkValueParser inner) |] + Just [RecC icn ifields] -> mkObjectParser n icn ifields + Just [NormalC icn [(_bang, inner)]] -> [| fmap $(conE icn) . $(mkValueParser inner) |] _ -> fail $ "Unsupported tool argument type: " ++ show n _ -> fail $ "Unsupported tool argument type: " ++ show ty @@ -175,11 +233,11 @@ mkEnumTextParser tyName cons = do -- Parser for a nested record: a JSON object decoded field by field mkObjectParser :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp -mkObjectParser tyName icon ifields = do +mkObjectParser tyName icn ifields = do vVar <- newName "v" oVar <- newName "o" chain <- foldl (\acc f -> [| $acc <*> $(fieldExtractor oVar f) |]) - [| pure $(conE icon) |] + [| pure $(conE icn) |] ifields fallback <- [| Left ("Failed to parse " <> $(litE $ stringL $ nameBase tyName) <> " object from: " <> renderValue $(varE vVar)) |] @@ -237,10 +295,10 @@ mkValueBuilder ty = case ty of vVar <- newName "v" matches <- mapM enumMatch cs return $ LamE [VarP vVar] $ CaseE (VarE vVar) matches - Just [RecC icon ifields] -> mkRecordBuilder icon ifields - Just [NormalC icon [(_bang, inner)]] -> do + Just [RecC icn ifields] -> mkRecordBuilder icn ifields + Just [NormalC icn [(_bang, inner)]] -> do xVar <- newName "x" - wrapped <- conP icon [varP xVar] + wrapped <- conP icn [varP xVar] body <- [| $(mkValueBuilder inner) $(varE xVar) |] return $ LamE [wrapped] body _ -> fail $ "Unsupported output field type: " ++ show n @@ -300,11 +358,11 @@ mkConDecoder style (NormalC cn [(_bang, paramType)]) = ConT typeName -> do cons <- reifyCons typeName case cons of - Just [RecC icon ifields] -> do - inner <- mkFieldsDecoder style (conE icon) ifields + Just [RecC icn ifields] -> do + inner <- mkFieldsDecoder style (conE icn) ifields [| $(conE cn) <$> $(return inner) |] - Just [NormalC icon [(_b, innerTy)]] -> do - innerCon <- mkConDecoder style (NormalC icon [(_b, innerTy)]) + Just [NormalC icn [(_b, innerTy)]] -> do + innerCon <- mkConDecoder style (NormalC icn [(_b, innerTy)]) [| $(conE cn) <$> $(return innerCon) |] _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" _ -> fail $ "Parameter type must be a concrete type, got: " ++ show ty @@ -376,12 +434,25 @@ mkObjectShape descriptions fields = do -- -- > $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")]) derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp -derivePromptHandlerWithDescription typeName handlerName descriptions = do +derivePromptHandlerWithDescription typeName handlerName descriptions = + derivePromptHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions + +-- | Derive prompt handlers with per-constructor 'DefinitionOptions' +-- (title, icons, scoped argument descriptions). Usage: +-- +-- > $(derivePromptHandlerWithOptions ''MyPrompt 'handlePrompt +-- > [("Recipe", defaultOptions { optDescription = Just "…" })]) +derivePromptHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +derivePromptHandlerWithOptions typeName handlerName opts = + derivePromptHandlerGeneric typeName handlerName (optionsFor opts) [] + +derivePromptHandlerGeneric :: Name -> Name -> (String -> DefinitionOptions) -> [(String, String)] -> Q Exp +derivePromptHandlerGeneric typeName handlerName conOpts globalDescs = do cons <- reifyCons typeName case cons of Just constructors -> do -- Generate prompt definitions - promptDefs <- traverse (mkPromptDefWithDescription descriptions) constructors + promptDefs <- traverse (mkPromptDef conOpts globalDescs) constructors -- Generate list handler listHandlerExp <- [| \_ctx -> pure $(return $ ListE promptDefs) |] @@ -395,7 +466,7 @@ derivePromptHandlerWithDescription typeName handlerName descriptions = do (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just getHandlerExp] - Nothing -> fail $ "derivePromptHandlerWithDescription: " ++ show typeName ++ " is not a data type" + Nothing -> fail $ "derivePromptHandler: " ++ show typeName ++ " is not a data type" -- | Derive prompt handlers from a data type. -- Usage: @@ -405,18 +476,20 @@ derivePromptHandler :: Name -> Name -> Q Exp derivePromptHandler typeName handlerName = derivePromptHandlerWithDescription typeName handlerName [] -mkPromptDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkPromptDefWithDescription descriptions con = do +mkPromptDef :: (String -> DefinitionOptions) -> [(String, String)] -> Con -> Q Exp +mkPromptDef conOpts globalDescs con = do let name = conName con let sname = snakeName name - let description = descriptionFor descriptions (nameBase name) ("Handle " ++ nameBase name) + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack ("Handle " ++ nameBase name)) (optDescription opts) fields <- getConFields con - args <- traverse (mkArgDef descriptions) fields + args <- traverse (mkArgDef (fieldDescsFor opts globalDescs)) fields [| PromptDefinition { promptDefinitionName = $(litE $ stringL sname) - , promptDefinitionDescription = $(litE $ stringL description) + , promptDefinitionDescription = $(lift description) , promptDefinitionArguments = $(return $ ListE args) - , promptDefinitionTitle = Nothing + , promptDefinitionTitle = $(lift (optTitle opts)) + , promptDefinitionIcons = $(lift (optIcons opts)) } |] mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp @@ -477,12 +550,22 @@ mkDispatchCase style handlerName con = do -- -- > $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")]) deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp -deriveResourceHandlerWithDescription typeName handlerName descriptions = do +deriveResourceHandlerWithDescription typeName handlerName descriptions = + deriveResourceHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) + +-- | Derive resource handlers with per-constructor 'DefinitionOptions' +-- (description, title, icons). +deriveResourceHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +deriveResourceHandlerWithOptions typeName handlerName opts = + deriveResourceHandlerGeneric typeName handlerName (optionsFor opts) + +deriveResourceHandlerGeneric :: Name -> Name -> (String -> DefinitionOptions) -> Q Exp +deriveResourceHandlerGeneric typeName handlerName conOpts = do cons <- reifyCons typeName case cons of Just constructors -> do -- Static resource definitions: nullary constructors only - resourceDefs <- traverse (mkResourceDefWithDescription descriptions) + resourceDefs <- traverse (mkResourceDef conOpts) (filter isNullary constructors) listHandlerExp <- [| \_ctx -> pure $(return $ ListE resourceDefs) |] @@ -494,7 +577,7 @@ deriveResourceHandlerWithDescription typeName handlerName descriptions = do let readHandlerExp = LamE [VarP ctxName, VarP uriName] readBody return $ TupE [Just listHandlerExp, Just readHandlerExp] - Nothing -> fail $ "deriveResourceHandlerWithDescription: " ++ show typeName ++ " is not a data type" + Nothing -> fail $ "deriveResourceHandler: " ++ show typeName ++ " is not a data type" -- | Derive resource handlers from a data type. -- Usage: @@ -510,14 +593,24 @@ deriveResourceHandler typeName handlerName = -- -- > $(deriveResourceTemplatesWithDescription ''MyResource [("Constructor", "Description")]) deriveResourceTemplatesWithDescription :: Name -> [(String, String)] -> Q Exp -deriveResourceTemplatesWithDescription typeName descriptions = do +deriveResourceTemplatesWithDescription typeName descriptions = + deriveResourceTemplatesGeneric typeName (optionsFromDescriptions descriptions) + +-- | Derive a 'ResourceTemplateListHandler' with per-constructor +-- 'DefinitionOptions' (description, title, icons). +deriveResourceTemplatesWithOptions :: Name -> [(String, DefinitionOptions)] -> Q Exp +deriveResourceTemplatesWithOptions typeName opts = + deriveResourceTemplatesGeneric typeName (optionsFor opts) + +deriveResourceTemplatesGeneric :: Name -> (String -> DefinitionOptions) -> Q Exp +deriveResourceTemplatesGeneric typeName conOpts = do cons <- reifyCons typeName case cons of Just constructors -> do - templateDefs <- traverse (mkTemplateDefWithDescription descriptions) + templateDefs <- traverse (mkTemplateDef conOpts) [c | c@(RecC _ _) <- constructors] [| \_ctx -> pure $(return $ ListE templateDefs) |] - Nothing -> fail $ "deriveResourceTemplatesWithDescription: " ++ show typeName ++ " is not a data type" + Nothing -> fail $ "deriveResourceTemplates: " ++ show typeName ++ " is not a data type" -- | Derive a 'ResourceTemplateListHandler' from a resource type's record -- constructors. Usage: @@ -534,38 +627,37 @@ templateURI name fields = "resource://" <> snakeName name <> concat ["/{" <> nameBase fn <> "}" | (fn, _, _) <- fields] -mkTemplateDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkTemplateDefWithDescription _ (RecC name []) = +mkTemplateDef :: (String -> DefinitionOptions) -> Con -> Q Exp +mkTemplateDef _ (RecC name []) = fail $ "Resource template constructors need at least one field: " ++ nameBase name -mkTemplateDefWithDescription descriptions (RecC name fields) = do - let description = descriptionFor descriptions (nameBase name) (nameBase name) +mkTemplateDef conOpts (RecC name fields) = do + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack (nameBase name)) (optDescription opts) [| ResourceTemplateDefinition { resourceTemplateURITemplate = $(litE $ stringL $ templateURI name fields) , resourceTemplateName = $(litE $ stringL $ snakeName name) - , resourceTemplateDescription = Just $(litE $ stringL description) + , resourceTemplateDescription = Just $(lift description) , resourceTemplateMimeType = Just "text/plain" - , resourceTemplateTitle = Nothing + , resourceTemplateTitle = $(lift (optTitle opts)) + , resourceTemplateIcons = $(lift (optIcons opts)) } |] -mkTemplateDefWithDescription _ _ = fail "Resource templates require record constructors" +mkTemplateDef _ _ = fail "Resource templates require record constructors" -mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp -mkResourceDefWithDescription descriptions (NormalC name []) = do +mkResourceDef :: (String -> DefinitionOptions) -> Con -> Q Exp +mkResourceDef conOpts (NormalC name []) = do let resourceName = T.pack . snakeName $ 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 + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack (nameBase name)) (optDescription opts) [| ResourceDefinition { resourceDefinitionURI = $(litE $ stringL resourceURI) , resourceDefinitionName = $(litE $ stringL $ T.unpack resourceName) - , resourceDefinitionDescription = $(case description of - Just desc -> [| Just $(litE $ stringL desc) |] - Nothing -> [| Nothing |]) + , resourceDefinitionDescription = Just $(lift description) , resourceDefinitionMimeType = Just "text/plain" - , resourceDefinitionTitle = Nothing + , resourceDefinitionTitle = $(lift (optTitle opts)) + , resourceDefinitionIcons = $(lift (optIcons opts)) } |] -mkResourceDefWithDescription _ _ = fail "Unsupported constructor type for resources" +mkResourceDef _ _ = fail "Unsupported constructor type for resources" -- One alternative of the read handler: try this constructor, else fall -- through to the rest of the chain. @@ -621,7 +713,21 @@ mkSegmentsDecoder segsName con fields = -- > $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")]) deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp deriveToolHandlerWithDescription typeName handlerName descriptions = - deriveToolHandlerGeneric typeName handlerName descriptions Nothing + deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions Nothing + +-- | Derive tool handlers with per-constructor 'DefinitionOptions' +-- (description, title, icons, behavioral annotations, scoped argument +-- descriptions). Usage: +-- +-- > $(deriveToolHandlerWithOptions ''MyTool 'handleTool +-- > [ ("Search", defaultOptions +-- > { optDescription = Just "Search the catalog" +-- > , optToolAnnotations = Just defaultToolAnnotations { toolReadOnlyHint = Just True } +-- > }) +-- > ]) +deriveToolHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +deriveToolHandlerWithOptions typeName handlerName opts = + deriveToolHandlerGeneric typeName handlerName (optionsFor opts) [] Nothing -- | Derive tool handlers from a data type. -- Usage: @@ -648,24 +754,35 @@ deriveToolHandlerWithOutput typeName handlerName outputName = -- description list is shared with the output type: entries matching output -- field names describe the @outputSchema@ properties. deriveToolHandlerWithOutputDescription :: Name -> Name -> Name -> [(String, String)] -> Q Exp -deriveToolHandlerWithOutputDescription typeName handlerName outputName descriptions = do - requireOutputRecord outputName - deriveToolHandlerGeneric typeName handlerName descriptions (Just outputName) - -deriveToolHandlerGeneric :: Name -> Name -> [(String, String)] -> Maybe Name -> Q Exp -deriveToolHandlerGeneric typeName handlerName descriptions outputName = do +deriveToolHandlerWithOutputDescription typeName handlerName outputName descriptions = + deriveToolHandlerGeneric typeName handlerName (optionsFromDescriptions descriptions) descriptions (Just outputName) + +-- | 'deriveToolHandlerWithOutput' with per-constructor +-- 'DefinitionOptions'. An entry keyed by the output type's name supplies +-- the @outputSchema@ field descriptions via 'optFieldDescriptions'. +deriveToolHandlerWithOutputOptions :: Name -> Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +deriveToolHandlerWithOutputOptions typeName handlerName outputName opts = + deriveToolHandlerGeneric typeName handlerName (optionsFor opts) [] (Just outputName) + +deriveToolHandlerGeneric :: Name -> Name -> (String -> DefinitionOptions) -> [(String, String)] -> Maybe Name -> Q Exp +deriveToolHandlerGeneric typeName handlerName conOpts globalDescs outputName = do cons <- reifyCons typeName case cons of Just constructors -> do -- The output type's schema and its matching serializer, when typed - -- output is requested + -- output is requested. Its field descriptions come from an options + -- entry keyed by the output type's own name, merged with the legacy + -- global list. output <- traverse - (\o -> (,) <$> mkSchemaShape descriptions (ConT o) - <*> mkValueBuilder (ConT o)) + (\o -> do + requireOutputRecord o + let outDescs = fieldDescsFor (conOpts (nameBase o)) globalDescs + (,) <$> mkSchemaShape outDescs (ConT o) + <*> mkValueBuilder (ConT o)) outputName -- Generate tool definitions - toolDefs <- traverse (mkToolDefWithDescription descriptions (fst <$> output)) constructors + toolDefs <- traverse (mkToolDef conOpts globalDescs (fst <$> output)) constructors listHandlerExp <- [| \_ctx -> pure $(return $ ListE toolDefs) |] @@ -681,19 +798,22 @@ deriveToolHandlerGeneric typeName handlerName descriptions outputName = do return $ TupE [Just listHandlerExp, Just callHandlerExp] Nothing -> fail $ "deriveToolHandler: " ++ show typeName ++ " is not a data type" -mkToolDefWithDescription :: [(String, String)] -> Maybe Exp -> Con -> Q Exp -mkToolDefWithDescription descriptions outputShape con = do +mkToolDef :: (String -> DefinitionOptions) -> [(String, String)] -> Maybe Exp -> Con -> Q Exp +mkToolDef conOpts globalDescs outputShape con = do let name = conName con let sname = snakeName name - let description = descriptionFor descriptions (nameBase name) (nameBase name) + let opts = conOpts (nameBase name) + let description = fromMaybe (T.pack (nameBase name)) (optDescription opts) fields <- getConFields con - shapeExp <- mkObjectShape descriptions fields + shapeExp <- mkObjectShape (fieldDescsFor opts globalDescs) fields [| ToolDefinition { toolDefinitionName = $(litE $ stringL sname) - , toolDefinitionDescription = $(litE $ stringL description) + , toolDefinitionDescription = $(lift description) , toolDefinitionInputSchema = Schema Nothing $(return shapeExp) , toolDefinitionOutputSchema = $(case outputShape of Just shape -> [| Just (Schema Nothing $(return shape)) |] Nothing -> [| Nothing |]) - , toolDefinitionTitle = Nothing + , toolDefinitionTitle = $(lift (optTitle opts)) + , toolDefinitionAnnotations = $(lift (optToolAnnotations opts)) + , toolDefinitionIcons = $(lift (optIcons opts)) } |] diff --git a/src/MCP/Server/Types.hs b/src/MCP/Server/Types.hs index 5fe2a9c..0c6f1c8 100644 --- a/src/MCP/Server/Types.hs +++ b/src/MCP/Server/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} module MCP.Server.Types @@ -8,6 +9,14 @@ module MCP.Server.Types , ContentAudioData(..) , ResourceContent(..) + -- * Metadata Types + , Annotations(..) + , defaultAnnotations + , ToolAnnotations(..) + , defaultToolAnnotations + , Icon(..) + , icon + -- * Handler Result Types , ToolResult(..) , toolResult @@ -34,9 +43,13 @@ module MCP.Server.Types -- * Definition Types , PromptDefinition(..) + , mkPromptDefinition , ResourceDefinition(..) + , mkResourceDefinition , ResourceTemplateDefinition(..) + , mkResourceTemplateDefinition , ToolDefinition(..) + , mkToolDefinition , ArgumentDefinition(..) -- * Completion Types @@ -87,6 +100,7 @@ import Data.Maybe (catMaybes, listToMaybe) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) +import Language.Haskell.TH.Syntax (Lift) import Network.URI (URI, parseURI) type PromptName = Text @@ -103,6 +117,9 @@ data Content -- ^ A resource embedded into the result, carrying its full contents | ContentResourceLink ResourceDefinition -- ^ A reference to a resource the client can read separately + | ContentAnnotated Annotations Content + -- ^ A content block carrying 'Annotations'; the annotations are merged + -- into the inner block's JSON object. Do not nest. deriving (Show, Eq, Generic) instance ToJSON Content where @@ -128,23 +145,61 @@ instance ToJSON Content where case toJSON def of Object o -> Object (KM.insert "type" (String "resource_link") o) other -> other + toJSON (ContentAnnotated anns inner) = + case toJSON inner of + Object o -> Object (KM.insert "annotations" (toJSON anns) o) + other -> other instance FromJSON Content where parseJSON = withObject "Content" $ \o -> do - contentType <- o .: "type" :: Parser Text - case contentType of - "text" -> ContentText <$> o .: "text" - "image" -> do - imgData <- o .: "data" - mimeType <- o .: "mimeType" - return $ ContentImage $ ContentImageData imgData mimeType - "audio" -> do - audioData <- o .: "data" - mimeType <- o .: "mimeType" - return $ ContentAudio $ ContentAudioData audioData mimeType - "resource" -> ContentEmbeddedResource <$> o .: "resource" - "resource_link" -> ContentResourceLink <$> parseJSON (Object o) - _ -> fail $ "Unknown content type: " ++ T.unpack contentType + inner <- parseInner o + case KM.lookup "annotations" o of + Just anns -> ContentAnnotated <$> parseJSON anns <*> pure inner + Nothing -> pure inner + where + parseInner o = do + contentType <- o .: "type" :: Parser Text + case contentType of + "text" -> ContentText <$> o .: "text" + "image" -> do + imgData <- o .: "data" + mimeType <- o .: "mimeType" + return $ ContentImage $ ContentImageData imgData mimeType + "audio" -> do + audioData <- o .: "data" + mimeType <- o .: "mimeType" + return $ ContentAudio $ ContentAudioData audioData mimeType + "resource" -> ContentEmbeddedResource <$> o .: "resource" + "resource_link" -> ContentResourceLink <$> parseJSON (Object o) + _ -> fail $ "Unknown content type: " ++ T.unpack contentType + +-- | Optional hints on content blocks: who the content is for, how important +-- it is, and when it last changed (2025-03-26+). +data Annotations = Annotations + { annotationsAudience :: [MessageRole] -- ^ Intended audience(s); omitted when empty + , annotationsPriority :: Maybe Double -- ^ 0.0 (optional) … 1.0 (most important) + , annotationsLastModified :: Maybe Text -- ^ ISO 8601 timestamp + } deriving (Show, Eq, Generic) + +-- | No annotations set; record-update the ones you need. +defaultAnnotations :: Annotations +defaultAnnotations = Annotations + { annotationsAudience = [] + , annotationsPriority = Nothing + , annotationsLastModified = Nothing + } + +instance ToJSON Annotations where + toJSON anns = object $ + (if null (annotationsAudience anns) then [] else ["audience" .= annotationsAudience anns]) + ++ maybe [] (\p -> ["priority" .= p]) (annotationsPriority anns) + ++ maybe [] (\lm -> ["lastModified" .= lm]) (annotationsLastModified anns) + +instance FromJSON Annotations where + parseJSON = withObject "Annotations" $ \o -> Annotations + <$> o .:? "audience" .!= [] + <*> o .:? "priority" + <*> o .:? "lastModified" data ContentImageData = ContentImageData { contentImageData :: Text -- ^ base64-encoded image data @@ -205,6 +260,60 @@ instance ToJSON MessageRole where toJSON RoleUser = "user" toJSON RoleAssistant = "assistant" +instance FromJSON MessageRole where + parseJSON = withText "MessageRole" $ \t -> case t of + "user" -> pure RoleUser + "assistant" -> pure RoleAssistant + _ -> fail $ "Unknown role: " ++ T.unpack t + +-- | Behavioral hints on a tool (2025-03-26+): clients use these for +-- permission UX (e.g. auto-approving read-only tools). All hints are +-- advisory and default to unset. +data ToolAnnotations = ToolAnnotations + { toolAnnotationsTitle :: Maybe Text + , toolReadOnlyHint :: Maybe Bool -- ^ The tool does not modify its environment + , toolDestructiveHint :: Maybe Bool -- ^ The tool may perform destructive updates + , toolIdempotentHint :: Maybe Bool -- ^ Repeated calls with the same arguments have no additional effect + , toolOpenWorldHint :: Maybe Bool -- ^ The tool interacts with an open world of external entities + } deriving (Show, Eq, Generic, Lift) + +-- | No hints set; record-update the ones you need. +defaultToolAnnotations :: ToolAnnotations +defaultToolAnnotations = ToolAnnotations + { toolAnnotationsTitle = Nothing + , toolReadOnlyHint = Nothing + , toolDestructiveHint = Nothing + , toolIdempotentHint = Nothing + , toolOpenWorldHint = Nothing + } + +instance ToJSON ToolAnnotations where + toJSON anns = object $ concat + [ maybe [] (\t -> ["title" .= t]) (toolAnnotationsTitle anns) + , maybe [] (\b -> ["readOnlyHint" .= b]) (toolReadOnlyHint anns) + , maybe [] (\b -> ["destructiveHint" .= b]) (toolDestructiveHint anns) + , maybe [] (\b -> ["idempotentHint" .= b]) (toolIdempotentHint anns) + , maybe [] (\b -> ["openWorldHint" .= b]) (toolOpenWorldHint anns) + ] + +-- | An icon a client may display for a tool, prompt or resource +-- (2025-11-25+). +data Icon = Icon + { iconSrc :: Text -- ^ URI of the icon + , iconMimeType :: Maybe Text + , iconSizes :: [Text] -- ^ e.g. @[\"48x48\"]@; omitted when empty + } deriving (Show, Eq, Generic, Lift) + +-- | An icon with just a source URI. +icon :: Text -> Icon +icon src = Icon { iconSrc = src, iconMimeType = Nothing, iconSizes = [] } + +instance ToJSON Icon where + toJSON i = object $ + [ "src" .= iconSrc i ] + ++ maybe [] (\m -> ["mimeType" .= m]) (iconMimeType i) + ++ (if null (iconSizes i) then [] else ["sizes" .= iconSizes i]) + -- | Prompt message data PromptMessage = PromptMessage { promptMessageRole :: MessageRole @@ -416,14 +525,28 @@ data PromptDefinition = PromptDefinition , promptDefinitionDescription :: Text , promptDefinitionArguments :: [ArgumentDefinition] , promptDefinitionTitle :: Maybe Text -- New title field for human-friendly display + , promptDefinitionIcons :: [Icon] -- ^ omitted when empty (2025-11-25+) } deriving (Show, Eq, Generic) +-- | A prompt definition with only the required fields set; record-update +-- the optional ones (constructing 'PromptDefinition' directly breaks when +-- fields are added). +mkPromptDefinition :: Text -> Text -> [ArgumentDefinition] -> PromptDefinition +mkPromptDefinition name description args = PromptDefinition + { promptDefinitionName = name + , promptDefinitionDescription = description + , promptDefinitionArguments = args + , promptDefinitionTitle = Nothing + , promptDefinitionIcons = [] + } + instance ToJSON PromptDefinition where toJSON def = object $ [ "name" .= promptDefinitionName def , "description" .= promptDefinitionDescription def , "arguments" .= promptDefinitionArguments def ] ++ maybe [] (\t -> ["title" .= t]) (promptDefinitionTitle def) + ++ (if null (promptDefinitionIcons def) then [] else ["icons" .= promptDefinitionIcons def]) -- | Resource definition (2025-06-18 enhanced) data ResourceDefinition = ResourceDefinition @@ -432,8 +555,21 @@ data ResourceDefinition = ResourceDefinition , resourceDefinitionDescription :: Maybe Text , resourceDefinitionMimeType :: Maybe Text , resourceDefinitionTitle :: Maybe Text -- New title field for human-friendly display + , resourceDefinitionIcons :: [Icon] -- ^ omitted when empty (2025-11-25+) } deriving (Show, Eq, Generic) +-- | A resource definition with only the required fields set; record-update +-- the optional ones. +mkResourceDefinition :: Text -> Text -> ResourceDefinition +mkResourceDefinition uri name = ResourceDefinition + { resourceDefinitionURI = uri + , resourceDefinitionName = name + , resourceDefinitionDescription = Nothing + , resourceDefinitionMimeType = Nothing + , resourceDefinitionTitle = Nothing + , resourceDefinitionIcons = [] + } + instance ToJSON ResourceDefinition where toJSON def = object $ [ "uri" .= resourceDefinitionURI def @@ -441,7 +577,8 @@ instance ToJSON ResourceDefinition where ] ++ maybe [] (\d -> ["description" .= d]) (resourceDefinitionDescription def) ++ maybe [] (\m -> ["mimeType" .= m]) (resourceDefinitionMimeType def) ++ - maybe [] (\t -> ["title" .= t]) (resourceDefinitionTitle def) + maybe [] (\t -> ["title" .= t]) (resourceDefinitionTitle def) ++ + (if null (resourceDefinitionIcons def) then [] else ["icons" .= resourceDefinitionIcons def]) instance FromJSON ResourceDefinition where parseJSON = withObject "ResourceDefinition" $ \o -> ResourceDefinition @@ -450,6 +587,7 @@ instance FromJSON ResourceDefinition where <*> o .:? "description" <*> o .:? "mimeType" <*> o .:? "title" + <*> pure [] -- | Resource template definition: a parameterized resource identified by an -- RFC 6570 URI template. @@ -459,8 +597,21 @@ data ResourceTemplateDefinition = ResourceTemplateDefinition , resourceTemplateDescription :: Maybe Text , resourceTemplateMimeType :: Maybe Text , resourceTemplateTitle :: Maybe Text + , resourceTemplateIcons :: [Icon] -- ^ omitted when empty (2025-11-25+) } deriving (Show, Eq, Generic) +-- | A template definition with only the required fields set; record-update +-- the optional ones. +mkResourceTemplateDefinition :: Text -> Text -> ResourceTemplateDefinition +mkResourceTemplateDefinition uriTemplate name = ResourceTemplateDefinition + { resourceTemplateURITemplate = uriTemplate + , resourceTemplateName = name + , resourceTemplateDescription = Nothing + , resourceTemplateMimeType = Nothing + , resourceTemplateTitle = Nothing + , resourceTemplateIcons = [] + } + instance ToJSON ResourceTemplateDefinition where toJSON def = object $ [ "uriTemplate" .= resourceTemplateURITemplate def @@ -468,7 +619,8 @@ instance ToJSON ResourceTemplateDefinition where ] ++ maybe [] (\d -> ["description" .= d]) (resourceTemplateDescription def) ++ maybe [] (\m -> ["mimeType" .= m]) (resourceTemplateMimeType def) ++ - maybe [] (\t -> ["title" .= t]) (resourceTemplateTitle def) + maybe [] (\t -> ["title" .= t]) (resourceTemplateTitle def) ++ + (if null (resourceTemplateIcons def) then [] else ["icons" .= resourceTemplateIcons def]) -- | What a completion request is completing an argument for. data CompletionRef @@ -498,8 +650,23 @@ data ToolDefinition = ToolDefinition , toolDefinitionInputSchema :: Schema , toolDefinitionOutputSchema :: Maybe Schema , toolDefinitionTitle :: Maybe Text -- New title field for human-friendly display + , toolDefinitionAnnotations :: Maybe ToolAnnotations -- ^ behavioral hints (2025-03-26+) + , toolDefinitionIcons :: [Icon] -- ^ omitted when empty (2025-11-25+) } deriving (Show, Eq, Generic) +-- | A tool definition with only the required fields set; record-update the +-- optional ones. +mkToolDefinition :: Text -> Text -> Schema -> ToolDefinition +mkToolDefinition name description inputSchema = ToolDefinition + { toolDefinitionName = name + , toolDefinitionDescription = description + , toolDefinitionInputSchema = inputSchema + , toolDefinitionOutputSchema = Nothing + , toolDefinitionTitle = Nothing + , toolDefinitionAnnotations = Nothing + , toolDefinitionIcons = [] + } + instance ToJSON ToolDefinition where toJSON def = object $ [ "name" .= toolDefinitionName def @@ -507,6 +674,8 @@ instance ToJSON ToolDefinition where , "inputSchema" .= toolDefinitionInputSchema def ] ++ maybe [] (\s -> ["outputSchema" .= s]) (toolDefinitionOutputSchema def) ++ maybe [] (\t -> ["title" .= t]) (toolDefinitionTitle def) + ++ maybe [] (\a -> ["annotations" .= a]) (toolDefinitionAnnotations def) + ++ (if null (toolDefinitionIcons def) then [] else ["icons" .= toolDefinitionIcons def]) -- | Argument definition for prompts data ArgumentDefinition = ArgumentDefinition diff --git a/test/Spec/GoldenWire.hs b/test/Spec/GoldenWire.hs index 725c5f8..ba21609 100644 --- a/test/Spec/GoldenWire.hs +++ b/test/Spec/GoldenWire.hs @@ -60,8 +60,8 @@ goldenHandlers = noHandlers } where promptList _ = pure - [ PromptDefinition "greet" "Greet someone" - [ArgumentDefinition "name" "Who to greet" True] Nothing + [ mkPromptDefinition "greet" "Greet someone" + [ArgumentDefinition "name" "Who to greet" True] ] promptGet _ name args = case name of "greet" -> pure $ Right $ PromptResult (Just "A greeting") @@ -69,16 +69,19 @@ goldenHandlers = noHandlers _ -> pure $ Left $ InvalidPromptName name resourceList _ = pure - [ ResourceDefinition "resource://info" "info" (Just "Some info") (Just "text/plain") Nothing ] + [ (mkResourceDefinition "resource://info" "info") + { resourceDefinitionDescription = Just "Some info" + , resourceDefinitionMimeType = Just "text/plain" + } + ] resourceRead _ uri | show uri == "resource://info" = pure $ Right $ ResourceText uri "text/plain" "The golden info" | otherwise = pure $ Left $ ResourceNotFound $ T.pack $ show uri toolList _ = pure - [ ToolDefinition "echo" "Echo the text" + [ mkToolDefinition "echo" "Echo the text" (Schema Nothing (SchemaObject [("text", Schema (Just "The text") (SchemaString Nothing))] ["text"])) - Nothing Nothing ] toolCall _ name args = case name of "echo" -> case Map.lookup "text" args of @@ -88,14 +91,21 @@ goldenHandlers = noHandlers _ -> pure $ Left $ UnknownTool name -- The extended set's structured-output tool, derived so the corpus pins --- exactly what the TH derivation puts on the wire (ADR 0005) +-- exactly what the TH derivation puts on the wire (ADR 0005). The field +-- selectors are intentionally unused: the generated serializer binds +-- fields by pattern-matching. data GoldenEchoOutput = GoldenEchoOutput { echoedText :: Text , echoedLength :: Int } + data GoldenStructTool = EchoStructured { input :: Text } +-- Selector uses, so -Wunused-top-binds stays quiet +_selectors :: (GoldenEchoOutput -> Text, GoldenEchoOutput -> Int, GoldenStructTool -> Text) +_selectors = (echoedText, echoedLength, input) + goldenStructHandler :: ClientContext -> GoldenStructTool -> IO (ToolOutput GoldenEchoOutput) goldenStructHandler _ (EchoStructured t) = pure $ ToolOutput (GoldenEchoOutput t (T.length t)) @@ -119,8 +129,10 @@ structuredTools = $(deriveToolHandlerWithOutputDescription extendedHandlers :: McpServerHandlers extendedHandlers = goldenHandlers { resourceTemplates = Just $ \_ -> pure - [ ResourceTemplateDefinition "resource://item/{itemId}" "item" - (Just "An item") (Just "text/plain") Nothing + [ (mkResourceTemplateDefinition "resource://item/{itemId}" "item") + { resourceTemplateDescription = Just "An item" + , resourceTemplateMimeType = Just "text/plain" + } ] , completions = Just $ \_ _ref _arg partial _ctx -> pure $ Right $ completionResult (filter (T.isPrefixOf partial) ["alpha", "beta"]) diff --git a/test/Spec/UnicodeHandling.hs b/test/Spec/UnicodeHandling.hs index b0b83c9..0ffc194 100644 --- a/test/Spec/UnicodeHandling.hs +++ b/test/Spec/UnicodeHandling.hs @@ -171,12 +171,9 @@ spec = describe "Unicode Handling" $ do it "handles complete Unicode workflow without Template Haskell" $ do -- Create manual handlers with Unicode content let promptListHandler = return [ - PromptDefinition - { promptDefinitionName = "math_formula" - , promptDefinitionDescription = "Generate mathematical formulas with Unicode: ∀∃∈√" - , promptDefinitionArguments = [ArgumentDefinition "formula" "Mathematical expression" True] - , promptDefinitionTitle = Nothing -- 2025-06-18: New title field - } + mkPromptDefinition "math_formula" + "Generate mathematical formulas with Unicode: ∀∃∈√" + [ArgumentDefinition "formula" "Mathematical expression" True] ] let promptGetHandler name args = case name of @@ -186,12 +183,9 @@ spec = describe "Unicode Handling" $ do _ -> return $ Left $ InvalidPromptName name let resourceListHandler = return [ - ResourceDefinition - { resourceDefinitionURI = "resource://unicode_symbols" - , resourceDefinitionName = "unicode_symbols" - , resourceDefinitionDescription = Just "Unicode mathematical symbols: ∀∃∈∉√∑" + (mkResourceDefinition "resource://unicode_symbols" "unicode_symbols") + { resourceDefinitionDescription = Just "Unicode mathematical symbols: ∀∃∈∉√∑" , resourceDefinitionMimeType = Just "text/plain" - , resourceDefinitionTitle = Nothing -- 2025-06-18: New title field } ] @@ -201,15 +195,10 @@ spec = describe "Unicode Handling" $ do else return $ Left $ ResourceNotFound $ T.pack $ show uri let toolListHandler = return [ - ToolDefinition - { toolDefinitionName = "calculate" - , toolDefinitionDescription = "Calculate with Unicode symbols: √∑∏" - , toolDefinitionInputSchema = schema $ SchemaObject + mkToolDefinition "calculate" "Calculate with Unicode symbols: √∑∏" + (schema $ SchemaObject [("expression", describedSchema "Mathematical expression" (SchemaString Nothing))] - ["expression"] - , toolDefinitionOutputSchema = Nothing - , toolDefinitionTitle = Nothing -- 2025-06-18: New title field - } + ["expression"]) ] let toolCallHandler name args = case name of From 5c8e0eb7c3685854e654b6d2ee149cdc52552203 Mon Sep 17 00:00:00 2001 From: tom Date: Sat, 1 Aug 2026 10:57:37 +0200 Subject: [PATCH 2/4] ADR 0006: tests, corpus cases, example, docs; pending version becomes 0.3.0.0 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - DefinitionMetadata spec: annotation/icon JSON shapes (unset fields omitted), ContentAnnotated merge + FromJSON round-trip, options-based derivation carrying description/title/icons/annotations, and constructor-scoped field descriptions (same-named fields described differently per constructor — the old global-namespace wart, now fixed and pinned by a test). - Conformance corpus: the extended reference server gains annotated_probe, derived via WithOptions so the corpus pins the options wire shape (annotations/title/icons on the definition, annotated content on the result); tools-call-annotated cases in both eras, tools-list-extended regenerated deliberately. The v0.2.0-anchored fixtures are untouched (new fields are omitted when unset). - Complete example showcases WithOptions: read-only/idempotent hints on search, destructive hint on checkout, scoped argument descriptions. - VERSIONING: extending the exported definition datatypes and Content is a major change under strict PVP, so the pending 0.2.1.0 line is folded into 0.3.0.0 (CHANGELOG notes the fold; ADR_0005's landed version updated accordingly; ROADMAP updated — ADR 0006's minor-bump guess did not survive contact with the PVP). - README: annotations/icons/options section. ADR_0006 marked Landed. 172 test examples; verified on GHC 9.10.3 and 9.14.1; cabal check clean. --- CHANGELOG.md | 31 +++++- README.md | 27 +++++ examples/Complete/Main.hs | 16 ++- mcp-server.cabal | 3 +- specs/ADR_0005_derived_output_schemas.md | 2 +- specs/ADR_0006_definition_metadata.md | 2 +- specs/ROADMAP.md | 20 ++-- src/MCP/Server/Derive.hs | 14 +-- test/HspecMain.hs | 2 + test/Spec/DefinitionMetadata.hs | 99 +++++++++++++++++++ test/Spec/GoldenWire.hs | 34 ++++++- test/golden/README.md | 1 + .../legacy/tools-call-annotated.request.json | 1 + .../legacy/tools-call-annotated.response.json | 1 + .../legacy/tools-list-extended.response.json | 2 +- test/golden/manifest.json | 10 ++ .../modern/tools-call-annotated.request.json | 1 + .../modern/tools-call-annotated.response.json | 1 + 18 files changed, 242 insertions(+), 25 deletions(-) create mode 100644 test/Spec/DefinitionMetadata.hs create mode 100644 test/golden/legacy/tools-call-annotated.request.json create mode 100644 test/golden/legacy/tools-call-annotated.response.json create mode 100644 test/golden/modern/tools-call-annotated.request.json create mode 100644 test/golden/modern/tools-call-annotated.response.json diff --git a/CHANGELOG.md b/CHANGELOG.md index 8a2b34a..4c4e255 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,35 @@ # Revision history for mcp-server -## 0.2.1.0 - ??? +## 0.3.0.0 - ??? + +(The unreleased 0.2.1.0 line below is folded into this release: definition +metadata extends exported datatypes, which is a major change under the PVP, +so the pending version becomes 0.3.0.0.) + +* Definition metadata (ADR 0006): + * `ToolAnnotations` — `readOnlyHint`/`destructiveHint`/`idempotentHint`/ + `openWorldHint` behavioral hints (2025-03-26+) plus a title, all unset + by default (`defaultToolAnnotations`), carried on `ToolDefinition` and + driving client permission UX. + * `Icon` lists (2025-11-25+) on tool, prompt, resource and + resource-template definitions. + * Content `Annotations` (`audience`/`priority`/`lastModified`, + 2025-03-26+) attached via the new `ContentAnnotated` wrapper, whose + annotations merge into the inner block's JSON (and parse back out). +* New `WithOptions` derivations for all five derive families, taking + per-constructor `DefinitionOptions` (description, title, icons, tool + annotations, and **constructor-scoped field descriptions** — two + constructors can now describe a same-named field differently, fixing the + global-namespace wart of the flat description list, which remains + supported unchanged). +* BREAKING: `ToolDefinition`, `PromptDefinition`, `ResourceDefinition` and + `ResourceTemplateDefinition` gain fields, and `Content` gains the + `ContentAnnotated` constructor. New smart constructors + (`mkToolDefinition`, `mkPromptDefinition`, `mkResourceDefinition`, + `mkResourceTemplateDefinition`) build definitions from required fields + only — construct through them and record-update, so future optional + fields stop breaking your code. All new JSON fields are omitted when + unset, so wire output for existing servers is unchanged. * Derived output schemas and structured content (ADR 0005): the new `deriveToolHandlerWithOutput` (and `...WithOutputDescription`) take a diff --git a/README.md b/README.md index c652d6d..9f3c58a 100644 --- a/README.md +++ b/README.md @@ -244,6 +244,33 @@ data SimpleTool All parameter types must ultimately resolve to records with named fields to generate proper MCP schemas. +#### Tool Annotations, Icons and Titles + +The `WithOptions` derivation variants take per-constructor +`DefinitionOptions` — description, title, icons, behavioral annotations +(which drive client permission UX, e.g. auto-approving read-only tools), +and argument descriptions scoped to the constructor: + +```haskell +tools = Just $(deriveToolHandlerWithOptions ''MyTool 'handleTool + [ ("Search", defaultDefinitionOptions + { optDescription = Just "Search the catalog" + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True, toolIdempotentHint = Just True } + , optIcons = [icon "https://example.com/search.png"] + , optFieldDescriptions = [("q", "Search terms")] + }) + ]) +``` + +Content blocks can carry annotations too (`audience`, `priority`, +`lastModified`), attached with the `ContentAnnotated` wrapper: + +```haskell +ContentAnnotated defaultAnnotations { annotationsPriority = Just 0.9 } + (ContentText "important result") +``` + ## Custom Descriptions You can provide custom descriptions for constructors and fields using the `*WithDescription` variants: diff --git a/examples/Complete/Main.hs b/examples/Complete/Main.hs index 6dac70d..bf1db87 100644 --- a/examples/Complete/Main.hs +++ b/examples/Complete/Main.hs @@ -69,7 +69,21 @@ main = do let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt) resources = $(deriveResourceHandler ''MyResource 'handleResource) templates = $(deriveResourceTemplates ''MyResource) - tools = $(deriveToolHandler ''MyTool 'handleTool) + -- Per-constructor options: descriptions, behavioral hints for + -- client permission UX, icons, and constructor-scoped argument + -- descriptions + tools = $(deriveToolHandlerWithOptions ''MyTool 'handleTool + [ ("SearchForProduct", defaultDefinitionOptions + { optDescription = Just "Search the product catalog" + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True, toolIdempotentHint = Just True } + , optFieldDescriptions = [("q", "Search terms"), ("category", "Restrict to a category")] + }) + , ("Checkout", defaultDefinitionOptions + { optToolAnnotations = Just defaultToolAnnotations + { toolDestructiveHint = Just True } + }) + ]) in runMcpServerStdio McpServerInfo { serverName = "Complete Example MCP Server" diff --git a/mcp-server.cabal b/mcp-server.cabal index c8b0342..a3350be 100644 --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -15,7 +15,7 @@ name: mcp-server -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.1.0 +version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package. @@ -180,6 +180,7 @@ test-suite haskell-mcp-server-test other-modules: Spec.AdvancedDerivation Spec.BasicDerivation + Spec.DefinitionMetadata Spec.DerivedOutput Spec.GoldenWire Spec.JSONConversion diff --git a/specs/ADR_0005_derived_output_schemas.md b/specs/ADR_0005_derived_output_schemas.md index 3f9c6cd..c41f59d 100644 --- a/specs/ADR_0005_derived_output_schemas.md +++ b/specs/ADR_0005_derived_output_schemas.md @@ -1,6 +1,6 @@ # ADR 0005: Derived output schemas and structured content -- **Status**: Landed (0.2.1.0) +- **Status**: Landed (0.3.0.0, née 0.2.1.0 — see CHANGELOG) - **Date**: 2026-08-01 - **Depends on**: — diff --git a/specs/ADR_0006_definition_metadata.md b/specs/ADR_0006_definition_metadata.md index cbdf323..4154e48 100644 --- a/specs/ADR_0006_definition_metadata.md +++ b/specs/ADR_0006_definition_metadata.md @@ -1,6 +1,6 @@ # ADR 0006: Tool annotations, icons, content annotations -- **Status**: Proposed +- **Status**: Landed (0.3.0.0) - **Date**: 2026-08-01 - **Depends on**: — diff --git a/specs/ROADMAP.md b/specs/ROADMAP.md index 1f03478..ed9730d 100644 --- a/specs/ROADMAP.md +++ b/specs/ROADMAP.md @@ -8,19 +8,19 @@ value, not commitment. **Current state**: 0.2.0.0 is on Hackage (typed core, dual-era protocol support for 2024-11-05…2025-11-25 via `initialize` and stateless 2026-07-28, resource templates, completions, change notifications with -`subscriptions/listen`). 0.2.1.0 sits merged-but-unreleased (WAI -application export, conformance corpus), soaking until enough accumulates. +`subscriptions/listen`). 0.3.0.0 sits merged-but-unreleased (WAI +application export, conformance corpus, and Batch 1: derived output +schemas, definition metadata — the metadata datatype extensions made the +pending line a major bump), soaking until released. -## Batch 1 — complete the typed core *(candidates to join the pending release)* +## Batch 1 — complete the typed core *(landed)* -Both are additive (PVP minor) and could ship with 0.2.1.x. +Both landed in the pending 0.3.0.0. -1. [ADR_0005 — Derived output schemas and structured content](ADR_0005_derived_output_schemas.md). - The highest-leverage item: finishes the library's thesis (typed in, - typed out) and is a genuine differentiator. -2. [ADR_0006 — Tool annotations, icons, content annotations](ADR_0006_definition_metadata.md). - Cheap metadata that materially improves how clients treat our servers - (read-only/destructive hints drive permission UX). +1. [ADR_0005 — Derived output schemas and structured content](ADR_0005_derived_output_schemas.md) — **Landed**. +2. [ADR_0006 — Tool annotations, icons, content annotations](ADR_0006_definition_metadata.md) — **Landed** + (the definition-datatype extensions turned the pending release into a + major bump under strict PVP, contrary to the ADR's minor-bump guess). ## Batch 2 — long-running tools diff --git a/src/MCP/Server/Derive.hs b/src/MCP/Server/Derive.hs index 0ef3996..0694972 100644 --- a/src/MCP/Server/Derive.hs +++ b/src/MCP/Server/Derive.hs @@ -31,7 +31,7 @@ module MCP.Server.Derive -- * Per-constructor customization , DefinitionOptions(..) - , defaultOptions + , defaultDefinitionOptions ) where import Control.Monad (zipWithM) @@ -65,8 +65,8 @@ data DefinitionOptions = DefinitionOptions } deriving (Show, Eq, Lift) -- | Nothing customized; record-update what you need. -defaultOptions :: DefinitionOptions -defaultOptions = DefinitionOptions +defaultDefinitionOptions :: DefinitionOptions +defaultDefinitionOptions = DefinitionOptions { optDescription = Nothing , optTitle = Nothing , optIcons = [] @@ -76,14 +76,14 @@ defaultOptions = DefinitionOptions -- | Look up a constructor's options. optionsFor :: [(String, DefinitionOptions)] -> String -> DefinitionOptions -optionsFor opts name = fromMaybe defaultOptions (lookup name opts) +optionsFor opts name = fromMaybe defaultDefinitionOptions (lookup name opts) -- | Adapt the legacy flat description list to per-constructor options: -- constructor entries become 'optDescription'; the whole list also serves -- as the (unscoped) field-description namespace, preserving the old -- behavior exactly. optionsFromDescriptions :: [(String, String)] -> String -> DefinitionOptions -optionsFromDescriptions descriptions name = defaultOptions +optionsFromDescriptions descriptions name = defaultDefinitionOptions { optDescription = T.pack <$> lookup name descriptions } @@ -441,7 +441,7 @@ derivePromptHandlerWithDescription typeName handlerName descriptions = -- (title, icons, scoped argument descriptions). Usage: -- -- > $(derivePromptHandlerWithOptions ''MyPrompt 'handlePrompt --- > [("Recipe", defaultOptions { optDescription = Just "…" })]) +-- > [("Recipe", defaultDefinitionOptions { optDescription = Just "…" })]) derivePromptHandlerWithOptions :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp derivePromptHandlerWithOptions typeName handlerName opts = derivePromptHandlerGeneric typeName handlerName (optionsFor opts) [] @@ -720,7 +720,7 @@ deriveToolHandlerWithDescription typeName handlerName descriptions = -- descriptions). Usage: -- -- > $(deriveToolHandlerWithOptions ''MyTool 'handleTool --- > [ ("Search", defaultOptions +-- > [ ("Search", defaultDefinitionOptions -- > { optDescription = Just "Search the catalog" -- > , optToolAnnotations = Just defaultToolAnnotations { toolReadOnlyHint = Just True } -- > }) diff --git a/test/HspecMain.hs b/test/HspecMain.hs index 84af546..6383707 100644 --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -8,6 +8,7 @@ import qualified Spec.BasicDerivation import qualified Spec.SchemaValidation import qualified Spec.AdvancedDerivation import qualified Spec.UnicodeHandling +import qualified Spec.DefinitionMetadata import qualified Spec.DerivedOutput import qualified Spec.GoldenWire import qualified Spec.ModernEra @@ -25,6 +26,7 @@ main = hspec $ do Spec.SchemaValidation.spec Spec.AdvancedDerivation.spec Spec.UnicodeHandling.spec + Spec.DefinitionMetadata.spec Spec.DerivedOutput.spec Spec.GoldenWire.spec Spec.ModernEra.spec diff --git a/test/Spec/DefinitionMetadata.hs b/test/Spec/DefinitionMetadata.hs new file mode 100644 index 0000000..8410d4f --- /dev/null +++ b/test/Spec/DefinitionMetadata.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Coverage for definition metadata (ADR 0006): tool annotations, icons, +-- content annotations, and the options-based derive customization. +module Spec.DefinitionMetadata (spec) where + +import Data.Aeson +import Data.Text (Text) +import MCP.Server +import MCP.Server.Derive +import Test.Hspec +import TestTypes + +annotatedToolHandlers :: (ToolListHandler, ToolCallHandler) +annotatedToolHandlers = $(deriveToolHandlerWithOptions ''TestTool 'handleTestTool + [ ("Echo", defaultDefinitionOptions + { optDescription = Just "Echoes the input" + , optTitle = Just "Echo" + , optIcons = [icon "https://example.com/echo.png"] + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True + , toolIdempotentHint = Just True + } + , optFieldDescriptions = [("text", "What to echo")] + }) + , ("Calculate", defaultDefinitionOptions + { optFieldDescriptions = [("x", "Calculate's first operand")] + }) + ]) + +toolNamed :: Text -> [ToolDefinition] -> ToolDefinition +toolNamed n defs = case [d | d <- defs, toolDefinitionName d == n] of + (d:_) -> d + [] -> error $ "tool not found: " ++ show n + +propDescription :: Text -> ToolDefinition -> Maybe Text +propDescription name def = case schemaShape (toolDefinitionInputSchema def) of + SchemaObject props _ -> lookup name props >>= schemaDescription + _ -> Nothing + +spec :: Spec +spec = describe "Definition metadata" $ do + + describe "JSON shapes" $ do + it "serializes tool annotations with only the set hints" $ do + toJSON defaultToolAnnotations { toolReadOnlyHint = Just True } `shouldBe` + object ["readOnlyHint" .= True] + + it "serializes icons, omitting empty optional fields" $ do + toJSON (icon "https://example.com/i.png") `shouldBe` + object ["src" .= ("https://example.com/i.png" :: Text)] + toJSON (Icon "u" (Just "image/png") ["48x48"]) `shouldBe` + object ["src" .= ("u" :: Text), "mimeType" .= ("image/png" :: Text), "sizes" .= (["48x48"] :: [Text])] + + it "merges content annotations into the inner block" $ do + let anns = defaultAnnotations { annotationsAudience = [RoleUser], annotationsPriority = Just 0.8 } + toJSON (ContentAnnotated anns (ContentText "hi")) `shouldBe` + object [ "type" .= ("text" :: Text), "text" .= ("hi" :: Text) + , "annotations" .= object ["audience" .= (["user"] :: [Text]), "priority" .= (0.8 :: Double)] + ] + + it "round-trips annotated content through FromJSON" $ do + let anns = defaultAnnotations { annotationsAudience = [RoleAssistant] } + c = ContentAnnotated anns (ContentText "hello") + decode (encode c) `shouldBe` Just c + + describe "Options-based derivation" $ do + it "carries description, title, icons and annotations on the definition" $ do + defs <- fst annotatedToolHandlers anonCtx + let echoDef = toolNamed "echo" defs + toolDefinitionDescription echoDef `shouldBe` "Echoes the input" + toolDefinitionTitle echoDef `shouldBe` Just "Echo" + toolDefinitionIcons echoDef `shouldBe` [icon "https://example.com/echo.png"] + toolDefinitionAnnotations echoDef `shouldBe` Just defaultToolAnnotations + { toolReadOnlyHint = Just True + , toolIdempotentHint = Just True + } + + it "leaves uncustomized constructors bare (constructor-name description)" $ do + defs <- fst annotatedToolHandlers anonCtx + let toggleDef = toolNamed "toggle" defs + toolDefinitionDescription toggleDef `shouldBe` "Toggle" + toolDefinitionAnnotations toggleDef `shouldBe` Nothing + toolDefinitionIcons toggleDef `shouldBe` [] + + it "scopes field descriptions to their constructor" $ do + defs <- fst annotatedToolHandlers anonCtx + -- 'text' described only on Echo; 'x' described only on Calculate + propDescription "text" (toolNamed "echo" defs) `shouldBe` Just "What to echo" + propDescription "x" (toolNamed "calculate" defs) `shouldBe` Just "Calculate's first operand" + -- Echo's options must not leak onto Calculate's same-named args + propDescription "operation" (toolNamed "calculate" defs) `shouldBe` Just "operation" + + it "still dispatches calls unchanged" $ do + result <- snd annotatedToolHandlers anonCtx "echo" mempty + case result of + Left (MissingRequiredParams msg) -> show msg `shouldContain` "text" + other -> expectationFailure $ "expected missing-params error, got: " ++ show other \ No newline at end of file diff --git a/test/Spec/GoldenWire.hs b/test/Spec/GoldenWire.hs index ba21609..ae1358f 100644 --- a/test/Spec/GoldenWire.hs +++ b/test/Spec/GoldenWire.hs @@ -110,6 +110,17 @@ goldenStructHandler :: ClientContext -> GoldenStructTool -> IO (ToolOutput Golde goldenStructHandler _ (EchoStructured t) = pure $ ToolOutput (GoldenEchoOutput t (T.length t)) +-- The extended set's annotated tool (ADR 0006): read-only hints, icon and +-- title on the definition; annotated content on the result +data GoldenAnnotatedTool = AnnotatedProbe { probe :: Text } + +goldenAnnotatedHandler :: ClientContext -> GoldenAnnotatedTool -> IO ToolResult +goldenAnnotatedHandler _ (AnnotatedProbe p) = pure $ toolResult + [ ContentAnnotated + defaultAnnotations { annotationsAudience = [RoleUser], annotationsPriority = Just 0.5 } + (ContentText ("probed: " <> p)) + ] + $(pure []) structuredTools :: (ToolListHandler, ToolCallHandler) @@ -121,6 +132,21 @@ structuredTools = $(deriveToolHandlerWithOutputDescription , ("echoedLength", "Its length") ]) +annotatedTools :: (ToolListHandler, ToolCallHandler) +annotatedTools = $(deriveToolHandlerWithOptions + ''GoldenAnnotatedTool 'goldenAnnotatedHandler + [ ("AnnotatedProbe", defaultDefinitionOptions + { optDescription = Just "A read-only probe" + , optTitle = Just "Probe" + , optIcons = [icon "https://example.com/probe.png"] + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True + , toolIdempotentHint = Just True + } + , optFieldDescriptions = [("probe", "What to probe")] + }) + ]) + -- | 'goldenHandlers' extended with the handler slots and tools introduced -- after v0.2.0. Used only for the fixtures of methods/behaviors that -- postdate the legacy anchor: extending the main handler set would change @@ -139,8 +165,12 @@ extendedHandlers = goldenHandlers , tools = do (baseList, baseCall) <- tools goldenHandlers let (sList, sCall) = structuredTools - pure ( \c -> (++) <$> baseList c <*> sList c - , \c n a -> if n == "echo_structured" then sCall c n a else baseCall c n a + (aList, aCall) = annotatedTools + pure ( \c -> concat <$> sequence [baseList c, sList c, aList c] + , \c n a -> case n of + "echo_structured" -> sCall c n a + "annotated_probe" -> aCall c n a + _ -> baseCall c n a ) } diff --git a/test/golden/README.md b/test/golden/README.md index 9faa5ac..ede6515 100644 --- a/test/golden/README.md +++ b/test/golden/README.md @@ -54,6 +54,7 @@ v0.2.0 anchor, so the anchored capability fixtures stay untouched): | Resource template `resource://item/{itemId}` | name `item`, description `An item`, `text/plain` | — | | Completions | any ref/argument | values = `["alpha", "beta"]` filtered by prefix of the partial value | | Tool `echo_structured` | input schema: object, required `input` (string, "The text"); output schema: object, required `echoedText` (string, "The echoed text") and `echoedLength` (integer, "Its length"); description `Echo with structured output` | returns `structuredContent` `{"echoedText": , "echoedLength": }` plus one text content block containing the same JSON | +| Tool `annotated_probe` | input schema: object, required `probe` (string, "What to probe"); description `A read-only probe`; title `Probe`; annotations `readOnlyHint`/`idempotentHint` true; one icon `https://example.com/probe.png` | returns one text block `probed: ` annotated with audience `["user"]`, priority `0.5` | Cases with `"notifications": true` are answered as if the transport can deliver change notifications (stdio with a configured notifier: legacy push diff --git a/test/golden/legacy/tools-call-annotated.request.json b/test/golden/legacy/tools-call-annotated.request.json new file mode 100644 index 0000000..530c7ac --- /dev/null +++ b/test/golden/legacy/tools-call-annotated.request.json @@ -0,0 +1 @@ +{"jsonrpc":"2.0","id":16,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"}}} \ No newline at end of file diff --git a/test/golden/legacy/tools-call-annotated.response.json b/test/golden/legacy/tools-call-annotated.response.json new file mode 100644 index 0000000..edc0745 --- /dev/null +++ b/test/golden/legacy/tools-call-annotated.response.json @@ -0,0 +1 @@ +{"id":16,"jsonrpc":"2.0","result":{"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}]}} \ No newline at end of file diff --git a/test/golden/legacy/tools-list-extended.response.json b/test/golden/legacy/tools-list-extended.response.json index 47214d7..3f0b1ae 100644 --- a/test/golden/legacy/tools-list-extended.response.json +++ b/test/golden/legacy/tools-list-extended.response.json @@ -1 +1 @@ -{"id":14,"jsonrpc":"2.0","result":{"tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"},{"description":"Echo with structured output","inputSchema":{"properties":{"input":{"description":"The text","type":"string"}},"required":["input"],"type":"object"},"name":"echo_structured","outputSchema":{"properties":{"echoedLength":{"description":"Its length","type":"integer"},"echoedText":{"description":"The echoed text","type":"string"}},"required":["echoedText","echoedLength"],"type":"object"}}]}} \ No newline at end of file +{"id":14,"jsonrpc":"2.0","result":{"tools":[{"description":"Echo the text","inputSchema":{"properties":{"text":{"description":"The text","type":"string"}},"required":["text"],"type":"object"},"name":"echo"},{"description":"Echo with structured output","inputSchema":{"properties":{"input":{"description":"The text","type":"string"}},"required":["input"],"type":"object"},"name":"echo_structured","outputSchema":{"properties":{"echoedLength":{"description":"Its length","type":"integer"},"echoedText":{"description":"The echoed text","type":"string"}},"required":["echoedText","echoedLength"],"type":"object"}},{"annotations":{"idempotentHint":true,"readOnlyHint":true},"description":"A read-only probe","icons":[{"src":"https://example.com/probe.png"}],"inputSchema":{"properties":{"probe":{"description":"What to probe","type":"string"}},"required":["probe"],"type":"object"},"name":"annotated_probe","title":"Probe"}]}} \ No newline at end of file diff --git a/test/golden/manifest.json b/test/golden/manifest.json index 6133bbd..0b64efd 100644 --- a/test/golden/manifest.json +++ b/test/golden/manifest.json @@ -47,6 +47,11 @@ "handlers": "extended", "notifications": false }, + { + "name": "legacy/tools-call-annotated", + "handlers": "extended", + "notifications": false + }, { "name": "legacy/tools-call-boom", "handlers": "base", @@ -117,6 +122,11 @@ "handlers": "base", "notifications": true }, + { + "name": "modern/tools-call-annotated", + "handlers": "extended", + "notifications": false + }, { "name": "modern/tools-call-echo", "handlers": "base", diff --git a/test/golden/modern/tools-call-annotated.request.json b/test/golden/modern/tools-call-annotated.request.json new file mode 100644 index 0000000..9773e7f --- /dev/null +++ b/test/golden/modern/tools-call-annotated.request.json @@ -0,0 +1 @@ +{"jsonrpc":"2.0","id":33,"method":"tools/call","params":{"name":"annotated_probe","arguments":{"probe":"sensor"},"_meta":{"io.modelcontextprotocol/protocolVersion":"2026-07-28","io.modelcontextprotocol/clientInfo":{"name":"golden-client","version":"1.0"},"io.modelcontextprotocol/clientCapabilities":{}}}} \ No newline at end of file diff --git a/test/golden/modern/tools-call-annotated.response.json b/test/golden/modern/tools-call-annotated.response.json new file mode 100644 index 0000000..58a3a43 --- /dev/null +++ b/test/golden/modern/tools-call-annotated.response.json @@ -0,0 +1 @@ +{"id":33,"jsonrpc":"2.0","result":{"_meta":{"io.modelcontextprotocol/serverInfo":{"name":"Golden Server","version":"1.0.0"}},"content":[{"annotations":{"audience":["user"],"priority":0.5},"text":"probed: sensor","type":"text"}],"resultType":"complete"}} \ No newline at end of file From 584c90ec4541aa8304bd2075f4d03be47c67d670 Mon Sep 17 00:00:00 2001 From: tom Date: Sat, 1 Aug 2026 11:02:10 +0200 Subject: [PATCH 3/4] Address review: parse icons back out of resource-link/resource JSON Icon gains a FromJSON instance and ResourceDefinition's parser reads the icons field instead of reconstructing with an empty list, so ContentResourceLink (and ResourceDefinition) values round-trip through JSON Eq-equal to what was encoded. Round-trip test added for a resource link carrying an icon. 173 test examples. --- src/MCP/Server/Types.hs | 8 +++++++- test/Spec/DefinitionMetadata.hs | 6 ++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/MCP/Server/Types.hs b/src/MCP/Server/Types.hs index 0c6f1c8..fd8462a 100644 --- a/src/MCP/Server/Types.hs +++ b/src/MCP/Server/Types.hs @@ -314,6 +314,12 @@ instance ToJSON Icon where ++ maybe [] (\m -> ["mimeType" .= m]) (iconMimeType i) ++ (if null (iconSizes i) then [] else ["sizes" .= iconSizes i]) +instance FromJSON Icon where + parseJSON = withObject "Icon" $ \o -> Icon + <$> o .: "src" + <*> o .:? "mimeType" + <*> o .:? "sizes" .!= [] + -- | Prompt message data PromptMessage = PromptMessage { promptMessageRole :: MessageRole @@ -587,7 +593,7 @@ instance FromJSON ResourceDefinition where <*> o .:? "description" <*> o .:? "mimeType" <*> o .:? "title" - <*> pure [] + <*> o .:? "icons" .!= [] -- | Resource template definition: a parameterized resource identified by an -- RFC 6570 URI template. diff --git a/test/Spec/DefinitionMetadata.hs b/test/Spec/DefinitionMetadata.hs index 8410d4f..8ab507f 100644 --- a/test/Spec/DefinitionMetadata.hs +++ b/test/Spec/DefinitionMetadata.hs @@ -65,6 +65,12 @@ spec = describe "Definition metadata" $ do c = ContentAnnotated anns (ContentText "hello") decode (encode c) `shouldBe` Just c + it "round-trips resource links carrying icons" $ do + let def = (mkResourceDefinition "resource://x" "x") + { resourceDefinitionIcons = [Icon "https://example.com/x.png" (Just "image/png") ["48x48"]] } + c = ContentResourceLink def + decode (encode c) `shouldBe` Just c + describe "Options-based derivation" $ do it "carries description, title, icons and annotations on the definition" $ do defs <- fst annotatedToolHandlers anonCtx From ec10207467a0be50e7da7c4ff12b72aef912148d Mon Sep 17 00:00:00 2001 From: tom Date: Sat, 1 Aug 2026 11:03:50 +0200 Subject: [PATCH 4/4] Renumber pending release to 0.2.0.1, superseding the deprecated 0.2.0.0 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Maintainer decision: 0.2.0.0 was published hours before this line landed and was never adopted, so it is deprecated on Hackage rather than answered with a major bump — 0.2 stays the version of the refactor, and 0.2.0.1 supersedes 0.2.0.0 in place, knowingly including changes that would ordinarily demand a major version. CHANGELOG, ADR statuses and ROADMAP updated to record the reasoning. --- CHANGELOG.md | 13 ++++++++----- mcp-server.cabal | 2 +- specs/ADR_0005_derived_output_schemas.md | 2 +- specs/ADR_0006_definition_metadata.md | 2 +- specs/ROADMAP.md | 16 +++++++++------- 5 files changed, 20 insertions(+), 15 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4c4e255..258c3eb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,13 @@ # Revision history for mcp-server -## 0.3.0.0 - ??? - -(The unreleased 0.2.1.0 line below is folded into this release: definition -metadata extends exported datatypes, which is a major change under the PVP, -so the pending version becomes 0.3.0.0.) +## 0.2.0.1 - ??? + +(Supersedes 0.2.0.0, which is **deprecated on Hackage**: it was published +hours before this line landed and was never adopted, so rather than +burning a major version on a release nobody used, 0.2.0.1 replaces it — +including changes that would ordinarily demand a major bump. Anyone +explicitly pinning the deprecated 0.2.0.0 should move here. The unreleased +0.2.1.0 line below is folded in as well.) * Definition metadata (ADR 0006): * `ToolAnnotations` — `readOnlyHint`/`destructiveHint`/`idempotentHint`/ diff --git a/mcp-server.cabal b/mcp-server.cabal index a3350be..94dc93f 100644 --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -15,7 +15,7 @@ name: mcp-server -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.3.0.0 +version: 0.2.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. diff --git a/specs/ADR_0005_derived_output_schemas.md b/specs/ADR_0005_derived_output_schemas.md index c41f59d..df27fe0 100644 --- a/specs/ADR_0005_derived_output_schemas.md +++ b/specs/ADR_0005_derived_output_schemas.md @@ -1,6 +1,6 @@ # ADR 0005: Derived output schemas and structured content -- **Status**: Landed (0.3.0.0, née 0.2.1.0 — see CHANGELOG) +- **Status**: Landed (0.2.0.1) - **Date**: 2026-08-01 - **Depends on**: — diff --git a/specs/ADR_0006_definition_metadata.md b/specs/ADR_0006_definition_metadata.md index 4154e48..45129c7 100644 --- a/specs/ADR_0006_definition_metadata.md +++ b/specs/ADR_0006_definition_metadata.md @@ -1,6 +1,6 @@ # ADR 0006: Tool annotations, icons, content annotations -- **Status**: Landed (0.3.0.0) +- **Status**: Landed (0.2.0.1) - **Date**: 2026-08-01 - **Depends on**: — diff --git a/specs/ROADMAP.md b/specs/ROADMAP.md index ed9730d..1054e2b 100644 --- a/specs/ROADMAP.md +++ b/specs/ROADMAP.md @@ -8,19 +8,21 @@ value, not commitment. **Current state**: 0.2.0.0 is on Hackage (typed core, dual-era protocol support for 2024-11-05…2025-11-25 via `initialize` and stateless 2026-07-28, resource templates, completions, change notifications with -`subscriptions/listen`). 0.3.0.0 sits merged-but-unreleased (WAI -application export, conformance corpus, and Batch 1: derived output -schemas, definition metadata — the metadata datatype extensions made the -pending line a major bump), soaking until released. +`subscriptions/listen`) but is deprecated there in favor of the pending +line: 0.2.0.1 sits merged-but-unreleased (WAI application export, +conformance corpus, and Batch 1: derived output schemas, definition +metadata), soaking until released. 0.2.0.1 knowingly supersedes the +never-adopted 0.2.0.0 in place rather than burning a major version. ## Batch 1 — complete the typed core *(landed)* -Both landed in the pending 0.3.0.0. +Both landed in the pending 0.2.0.1. 1. [ADR_0005 — Derived output schemas and structured content](ADR_0005_derived_output_schemas.md) — **Landed**. 2. [ADR_0006 — Tool annotations, icons, content annotations](ADR_0006_definition_metadata.md) — **Landed** - (the definition-datatype extensions turned the pending release into a - major bump under strict PVP, contrary to the ADR's minor-bump guess). + (the definition-datatype extensions are breaking; they ship anyway in + 0.2.0.1 because the only affected release, 0.2.0.0, is deprecated with + zero adopters). ## Batch 2 — long-running tools