mcp-server 0.1.0.9 → 0.1.0.10

raw patch · 8 files changed

+86/−25 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/Complete/Main.hs +7/−4
• mcp-server.cabal +1/−1
• src/MCP/Server.hs +2/−2
• src/MCP/Server/Derive.hs +1/−1
• src/MCP/Server/Protocol.hs +2/−2
• src/MCP/Server/Types.hs +48/−2
• test/Spec/BasicDerivation.hs +16/−5
• test/TestTypes.hs +9/−8

@@ -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) =

@@ -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.

@@ -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) 

@@ -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" 

@@ -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

@@ -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)

@@ -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

@@ -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) =