diff --git a/examples/Complete/Main.hs b/examples/Complete/Main.hs --- a/examples/Complete/Main.hs +++ b/examples/Complete/Main.hs @@ -15,10 +15,13 @@ handlePrompt (Shopping description) = pure $ ContentText $ "Shopping prompt for " <> description <> ": Create a detailed shopping list..." -handleResource :: MyResource -> IO Content -handleResource ProductCategories = pure $ ContentText "Fresh Produce, Dairy, Bakery, Meat & Seafood, Frozen Foods" -handleResource SaleItems = pure $ ContentText "Organic Apples $2.99/lb, Free Range Eggs $4.50/dozen, Artisan Bread $3.25/loaf" -handleResource HeadlineBannerAd = pure $ ContentText "🛒 Weekly Special: 20% off all organic produce! 🥕🥬🍎" +handleResource :: URI -> MyResource -> IO ResourceContent +handleResource uri ProductCategories = + pure $ ResourceText uri "text/plain" "Fresh Produce, Dairy, Bakery, Meat & Seafood, Frozen Foods" +handleResource uri SaleItems = + pure $ ResourceText uri "text/plain" "Organic Apples $2.99/lb, Free Range Eggs $4.50/dozen, Artisan Bread $3.25/loaf" +handleResource uri HeadlineBannerAd = + pure $ ResourceText uri "text/plain" "🛒 Weekly Special: 20% off all organic produce! 🥕🥬🍎" handleTool :: MyTool -> IO Content handleTool (SearchForProduct q category) = 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.9 +version: 0.1.0.10 -- 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/src/MCP/Server.hs b/src/MCP/Server.hs --- a/src/MCP/Server.hs +++ b/src/MCP/Server.hs @@ -279,9 +279,9 @@ , errorMessage = errorMessageFromMcpError err , errorData = Nothing } - Right content -> do + Right resourceContent -> do let response = ResourcesReadResponse - { resourcesReadContents = [content] + { resourcesReadContents = [resourceContent] } return $ makeSuccessResponse (requestId req) (toJSON response) 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 @@ -378,7 +378,7 @@ let resourceName = T.pack . toSnakeCase . nameBase $ name let resourceURI = "resource://" <> T.unpack resourceName clause [litP $ stringL resourceURI] - (normalB [| Right <$> $(varE handlerName) $(conE name) |]) + (normalB [| $(varE handlerName) $(varE (mkName "uri")) $(conE name) >>= pure . Right |]) [] mkResourceCase _ _ = fail "Unsupported constructor type for resources" diff --git a/src/MCP/Server/Protocol.hs b/src/MCP/Server/Protocol.hs --- a/src/MCP/Server/Protocol.hs +++ b/src/MCP/Server/Protocol.hs @@ -39,7 +39,7 @@ import Data.Text (Text) import Data.Aeson import Data.Map (Map) -import Network.URI (URI, parseURI) +import Network.URI (URI) import GHC.Generics (Generic) import MCP.Server.Types @@ -189,7 +189,7 @@ -- | Resources read response data ResourcesReadResponse = ResourcesReadResponse - { resourcesReadContents :: [Content] + { resourcesReadContents :: [ResourceContent] } deriving (Show, Eq, Generic) instance ToJSON ResourcesReadResponse where diff --git a/src/MCP/Server/Types.hs b/src/MCP/Server/Types.hs --- a/src/MCP/Server/Types.hs +++ b/src/MCP/Server/Types.hs @@ -6,7 +6,12 @@ Content(..) , ContentImageData(..) , ContentResourceData(..) + , ResourceContent(..) + -- * URI Utilities + , parseURI + , URI + -- * Error Types , Error(..) @@ -49,7 +54,7 @@ import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) -import Network.URI (URI) +import Network.URI (URI, parseURI) type PromptName = Text type ToolName = Text @@ -107,6 +112,47 @@ , contentResourceMimeType :: Maybe Text } deriving (Show, Eq, Generic) +-- | Resource content compliant with MCP specification +-- Must include uri and mimeType, with either text or blob data +data ResourceContent + = ResourceText + { resourceUri :: URI + , resourceMimeType :: Text + , resourceText :: Text + } + | ResourceBlob + { resourceUri :: URI + , resourceMimeType :: Text + , resourceBlob :: Text -- base64 encoded + } + deriving (Show, Eq, Generic) + +instance ToJSON ResourceContent where + toJSON (ResourceText uri mimeType text) = object + [ "uri" .= show uri + , "mimeType" .= mimeType + , "text" .= text + ] + toJSON (ResourceBlob uri mimeType blob) = object + [ "uri" .= show uri + , "mimeType" .= mimeType + , "blob" .= blob + ] + +instance FromJSON ResourceContent where + parseJSON = withObject "ResourceContent" $ \o -> do + uriText <- o .: "uri" + mimeType <- o .: "mimeType" + case parseURI uriText of + Nothing -> fail "Invalid URI" + Just uri -> do + maybeText <- o .:? "text" + maybeBlob <- o .:? "blob" + case (maybeText, maybeBlob) of + (Just text, Nothing) -> return $ ResourceText uri mimeType text + (Nothing, Just blob) -> return $ ResourceBlob uri mimeType blob + _ -> fail "ResourceContent must have either 'text' or 'blob' field" + -- | MCP protocol errors data Error = InvalidPromptName Text @@ -293,7 +339,7 @@ type PromptGetHandler m = PromptName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content) type ResourceListHandler m = m [ResourceDefinition] -type ResourceReadHandler m = URI -> m (Either Error Content) +type ResourceReadHandler m = URI -> m (Either Error ResourceContent) type ToolListHandler m = m [ToolDefinition] type ToolCallHandler m = ToolName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content) diff --git a/test/Spec/BasicDerivation.hs b/test/Spec/BasicDerivation.hs --- a/test/Spec/BasicDerivation.hs +++ b/test/Spec/BasicDerivation.hs @@ -46,7 +46,12 @@ testResourceCall :: ResourceReadHandler IO -> String -> Text -> IO () testResourceCall handler uriString expected = do case parseURI uriString of - Just uri -> shouldReturnContentText (handler uri) expected + Just uri -> do + result <- handler uri + case result of + Right (ResourceText _ _ content) -> content `shouldBe` expected + Right (ResourceBlob _ _ _) -> expectationFailure "Expected ResourceText but got ResourceBlob" + Left err -> expectationFailure $ "Expected success but got error: " ++ show err Nothing -> expectationFailure $ "Failed to parse URI: " ++ uriString testToolCall :: ToolCallHandler IO -> Text -> [(Text, Text)] -> Text -> IO () @@ -68,12 +73,18 @@ forM_ resourceTestCases $ \testCase -> it (T.unpack $ resourceTestDescription testCase) $ do - case parseURI (T.unpack $ resourceUri testCase) of + case parseURI (T.unpack $ TestData.resourceUri testCase) of Just uri -> if useSubstringMatch testCase - then shouldContainText (readHandler uri) (resourceExpectedContent testCase) - else testResourceCall readHandler (T.unpack $ resourceUri testCase) (resourceExpectedContent testCase) - Nothing -> expectationFailure $ "Failed to parse URI: " ++ T.unpack (resourceUri testCase) + then do + result <- readHandler uri + case result of + Right (ResourceText _ _ content) -> + T.isInfixOf (resourceExpectedContent testCase) content `shouldBe` True + Right (ResourceBlob _ _ _) -> expectationFailure "Expected ResourceText but got ResourceBlob" + Left err -> expectationFailure $ "Expected success but got error: " ++ show err + else testResourceCall readHandler (T.unpack $ TestData.resourceUri testCase) (resourceExpectedContent testCase) + Nothing -> expectationFailure $ "Failed to parse URI: " ++ T.unpack (TestData.resourceUri testCase) describe "Tool derivation" $ do let (_, callHandler) = testToolHandlers diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -4,7 +4,8 @@ import Data.Text (Text) import qualified Data.Text as T -import MCP.Server (Content(..)) +import MCP.Server (Content(..), ResourceContent(..), parseURI) +import Network.URI (URI) -- Test data types for end-to-end testing data TestPrompt @@ -54,13 +55,13 @@ handleTestPrompt (OptionalPrompt req opt) = pure $ ContentText $ "Optional prompt: " <> req <> maybe "" ((" optional=" <>) . T.pack . show) opt -handleTestResource :: TestResource -> IO Content -handleTestResource ConfigFile = - pure $ ContentText "Config file contents: debug=true, timeout=30" -handleTestResource DatabaseConnection = - pure $ ContentText "Database at localhost:5432" -handleTestResource UserProfile = - pure $ ContentText "User profile for ID 123" +handleTestResource :: URI -> TestResource -> IO ResourceContent +handleTestResource uri ConfigFile = + pure $ ResourceText uri "text/plain" "Config file contents: debug=true, timeout=30" +handleTestResource uri DatabaseConnection = + pure $ ResourceText uri "text/plain" "Database at localhost:5432" +handleTestResource uri UserProfile = + pure $ ResourceText uri "text/plain" "User profile for ID 123" handleTestTool :: TestTool -> IO Content handleTestTool (Echo text) =