mcp-server (empty) → 0.1.0.0
raw patch · 15 files changed
+2146/−0 lines, 15 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, mcp-server, network-uri, template-haskell, text
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- README.md +141/−0
- SPEC.md +201/−0
- app/Main.hs +6/−0
- examples/HighLevel.hs +214/−0
- examples/TemplateHaskell.hs +52/−0
- examples/Types.hs +24/−0
- mcp-server.cabal +172/−0
- src/MCP/Server.hs +365/−0
- src/MCP/Server/Derive.hs +178/−0
- src/MCP/Server/JsonRpc.hs +179/−0
- src/MCP/Server/Protocol.hs +253/−0
- src/MCP/Server/Types.hs +323/−0
- test/Main.hs +4/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for haskell-mcp-lib++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2025, Tom Wells+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,141 @@+# mcp-server++A fully-featured Haskell library for building [Model Context Protocol (MCP)](https://modelcontextprotocol.io/) servers.++## Features++- **Complete MCP Implementation**: Full support for MCP 2024-11-05 specification+- **Type-Safe API**: Leverage Haskell's type system for robust MCP servers+- **Multiple Abstractions**: Both low-level fine-grained control and high-level derived interfaces+- **Template Haskell Support**: Automatic handler derivation from data types+- **Pagination Support**: Cursor-based pagination for large result sets++## Supported MCP Features++- ✅ **Prompts**: User-controlled prompt templates with arguments+- ✅ **Resources**: Application-controlled readable resources +- ✅ **Tools**: Model-controlled callable functions+- ✅ **Initialization Flow**: Complete protocol lifecycle with version negotiation+- ✅ **Error Handling**: Comprehensive error types and JSON-RPC error responses+- ✅ **Capabilities**: Proper capability negotiation with sub-capabilities++## Quick Start++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++import MCP.Server+import MCP.Server.Derive++-- Define your data types+data MyPrompt = Recipe { idea :: Text } | Shopping { items :: Text }+data MyResource = Menu | Specials +data MyTool = Search { query :: Text } | Order { item :: Text }++-- Implement handlers+handlePrompt :: MyPrompt -> IO Content+handlePrompt (Recipe idea) = pure $ ContentText $ "Recipe for " <> idea+handlePrompt (Shopping items) = pure $ ContentText $ "Shopping list: " <> items++handleResource :: MyResource -> IO Content +handleResource Menu = pure $ ContentText "Today's menu..."+handleResource Specials = pure $ ContentText "Daily specials..."++handleTool :: MyTool -> IO Content+handleTool (Search query) = pure $ ContentText $ "Search results for " <> query+handleTool (Order item) = pure $ ContentText $ "Ordered " <> item++-- Derive handlers automatically+main :: IO ()+main = runMcpServerStdIn serverInfo handlers+ where+ serverInfo = McpServerInfo+ { serverName = "My MCP Server"+ , serverVersion = "1.0.0" + , serverInstructions = "A sample MCP server"+ }+ handlers = McpServerHandlers+ { prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt)+ , resources = Just $(deriveResourceHandler ''MyResource 'handleResource) + , tools = Just $(deriveToolHandler ''MyTool 'handleTool)+ }+```++## Manual Handler Implementation++For fine-grained control, implement handlers manually:++```haskell+import MCP.Server++-- Manual handler implementation+promptListHandler :: Maybe Cursor -> IO (PaginatedResult [PromptDefinition])+promptGetHandler :: PromptName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content)+-- ... implement your custom logic++main :: IO ()+main = runMcpServerStdIn serverInfo handlers+ where+ handlers = McpServerHandlers+ { prompts = Just (promptListHandler, promptGetHandler)+ , resources = Nothing -- Not supported+ , tools = Nothing -- Not supported + }+```++## Examples++The library includes three complete examples:++- **`examples/HighLevel.hs`**: Manual high-level implementation+- **`examples/TemplateHaskell.hs`**: Automatic Template Haskell derivation++## Docker Usage++I like to build and publish my MCP servers to Docker - which means that it's much easier to configure assistants such as Claude Desktop to run them. ++```bash+# Build the image+docker build -t haskell-mcp-server .++# Run different examples+docker run -i --entrypoint="/usr/local/bin/template-haskell-example" haskell-mcp-server+docker run -i --entrypoint="/usr/local/bin/high-level-example" haskell-mcp-server+```++And then configure Claude by editing `claude_desktop_config.json`:++```json+{+ "mcpServers": {+ "haskell-mcp-server-example": {+ "command": "docker",+ "args": [+ "run",+ "-i",+ "--entrypoint=/usr/local/bin/template-haskell-example",+ "drshade/haskell-mcp-server"+ ]+ }+ }+}+```++## Documentation++- [MCP Specification](https://modelcontextprotocol.io/specification/2024-11-05/)+- [API Documentation](https://hackage.haskell.org/package/mcp-server)+- [Examples](examples/)++## Contributing++Contributions are welcome! Please see the issue tracker for open issues and feature requests.++## Disclaimer - AI Assistance++I am not sure whether there is any stigma associated with this but Claude helped me write a lot of this library. I started with a very specific specification of what I wanted to achieve and worked shoulder-to-shoulder with Claude to implement and refactor the library until I was happy with it. A few of the features such as the Derive functions are a little out of my comfort zone to have manually written, so I appreciated having an expert guide me here - however I do suspect that this implementation may be sub-par and I do intend to refactor and rewrite large pieces of this through regular maintenance.++## License++BSD-3-Clause
+ SPEC.md view
@@ -0,0 +1,201 @@++# NOTICE++This file is kept for brevity - but served as my starting specification before writing the library. This may no longer be useful and will be superceded by examples in the examples/ folder.++# Haskell MCP Server Library++Fully featured haskell library for building MCP Servers.++## MCP Specification - Model Context Protocol++The MCP spec is a specialisation of the JSON-RPC specification, exposing a number of requests and responses. This library allows developers to build these servers easily in haskell.++This library is compliant with the following MCP specifications for building MCP Servers which can be found here:++| Item | Spec URL |+| Overview | https://modelcontextprotocol.io/specification/2024-11-05/server |+| Prompts | https://modelcontextprotocol.io/specification/2024-11-05/server/prompts |+| Resources | https://modelcontextprotocol.io/specification/2024-11-05/server/resources |+| Tools | https://modelcontextprotocol.io/specification/2024-11-05/server/tools |++# Library itself++Supports 2 levels of granularity:++## 1. Lowest-level fine grained handling of Prompts, Resources and Tools, e.g.:++Using an example of a grocery shopping MCP server:++```haskell++import MCP.Server.Types (Content(ContentText, ContentImage), Error(InvalidPromptName, MissingRequiredParams, ResourceNotFound, InternalError, UnknownTool), PromptDefinition, ResourceDefinition, ArgumentDefinition, InputSchemaDefinition(..), PaginatedResult(..), Cursor)+import Network.URI (URI(URI))+import qualified Data.Map as Map++type PromptName = Text+type ToolName = Text+type ArgumentName = Text+type ArgumentValue = Text++handleListPrompts :: (Monad m) => Maybe Cursor -> m (PaginatedResult [PromptDefinition])+handleListPrompts cursor =+ pure $ PaginatedResult+ { paginatedItems = + [ PromptDefinition+ { promptDefinitionName = "recipe"+ , promptDefinitionDescription = "Generate a detailed recipe for a particular idea" + , promptDefinitionArguments = + [ ArgumentDefinition+ { argumentDefinitionName = "idea"+ , argumentDefinitionDescription = "inspiring idea for the recipe" + , argumentDefinitionRequired = True+ }+ ]+ }+ ]+ , paginatedNextCursor = Nothing -- No more pages+ }++handleListResources :: (Monad m) => Maybe Cursor -> m (PaginatedResult [ResourceDefinition])+handleListResources cursor = + pure $ PaginatedResult+ { paginatedItems =+ [ ResourceDefinition+ { resourceDefinitionURI = "file:///product_categories"+ , resourceDefinitionName = "product_categories"+ , resourceDefinitionDescription = "List of product categories"+ , resourceDefinitionMimeType = "text/plain"+ }+ ]+ , paginatedNextCursor = Nothing -- No more pages+ }++handleListTools :: (Monad m) => Maybe Cursor -> m (PaginatedResult [ToolDefinition])+handleListTools cursor = + pure $ PaginatedResult+ { paginatedItems =+ [ ToolDefinition+ { toolDefinitionName = "search_for_product" + , toolDefinitionDescription = "Search for products in the catalog"+ , toolDefinitionInputSchema = + InputSchemaDefinitionObject+ { properties = + [ ("q"+ , InputSchemaDefinitionProperty+ { type = "string"+ , description = "Matching this query, using 'contains' semantics"+ }+ )+ , ("category"+ , InputSchemaDefinitionProperty+ { type = "string"+ , description = "Limit to searching within this category (optional)"+ }+ )+ ]+ , required = ["q"]+ }+ }+ ]+ , paginatedNextCursor = Nothing -- No more pages+ }++handleGetPrompt :: (Monad m) => PromptName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)+handleGetPrompt "recipe" args = do+ let idea = Map.lookup "idea" $ Map.fromList args -- idea is required+ in case idea of+ Just idea' -> pure $ Right $ ContentText $ "Recipe prompt for " <> idea' <> " ..."+ Nothing -> pure $ Left $ MissingRequiredParams "field 'idea' is missing"+handleGetPrompt prompt _ = pure $ Left $ InvalidPromptName $ prompt <> " unknown!"++handleReadResource :: (Monad m) => URI -> m (Either Error Content)+handleReadResource uri = do+ case uriPath uri of+ "/product_categories" -> pure $ Right $ ContentText $ "category 1, category 2"+ unknown -> pure $ Left $ ResourceNotFound $ "Resouce " <> unknown <> " not found!"++handleCallTool :: (Monad m) => ToolName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)+handleCallTool "search_for_product" args = do+ let q = Map.lookup "q" $ Map.fromList args -- q is required+ let category = Map.lookup "category" $ Map.fromList args -- category is optional+ in case q of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'q' is missing"+ Just q' -> pure $ Right $ ContentText $ "product 1, product 2"+handleCallTool tool _ = pure $ Left $ UnknownTool $ tool <> " unknown!"++-- Running the MCP server using STDIO++main :: IO ()+main =+ runMcpServerStdIn+ McpServerInfo+ { serverName = "Products available at your Grocery Store"+ , serverVersion = "0.1.0"+ , serverInstructions = "Use these tools to fetch information about products available at your grocery store, including prices, ingredients, descriptions etc."+ }+ McpServerHandlers+ { prompts = Just (handleListPrompts, handleGetPrompt)+ , resources = Just (handleListResources, handleReadResource)+ , tools = Just (handleListTools, handleCallTool)+ }++```++## 2. High-level derived interfaces for simpler definitions++High level MCP server definitions take advantage of Template Haskell for generating all the boilerplate of the low-level definitions, but allow for much simpler and type safe definitions such as in the example below.++```haskell++import MCP.Server.Types (Content(ContentText, ContentImage))++data MyPrompt+ = Recipe { idea :: Text }+ | Shopping { description :: Text }++data MyResource+ = ProductCategories+ | SaleItems+ | HeadlineBannerAd++data MyTool+ = SearchForProduct { q :: Text, category :: Maybe Text }+ | AddToCart { sku :: Text }+ | Checkout++handlePrompt :: (MonadIO m) => MyPrompt -> m Content+handlePrompt (Recipe idea) =+ pure $ ContentText "Recipe prompt goes here..."+handlePrompt (Shopping description) =+ pure $ ContentText "Shopping prompt goes here..."++handleResource :: (MonadIO m) => MyResource -> m Content+handleResource ProductCategories = pure $ ContentText "category 1, category 2"+handleResource SaleItems = pure $ ContentText "item 1, item 2, item 3"+handleResource HeadlineBannerAd = pure $ ContentImage { mimeType = "image/png", data = "..." }++handleTool :: (MonadIO m) => MyTool -> m Content+handleTool (SearchForProduct q category) = pure $ ContentText "search results..."+handleTool (AddToCart sku) = pure $ ContentText "Item added to cart!"+handleTool Checkout = pure $ ContentText "checkout completed!"++main =+ -- Derive the handlers+ let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt)+ resources = $(deriveResourceHandler ''MyResource 'handleResource)+ tools = $(deriveToolHandler ''MyTool 'handleTool)+ in runMcpServerStdIn+ McpServerInfo+ { serverName = "Products available at your Grocery Store"+ , serverVersion = "0.1.0"+ , serverInstructions = "Use these tools to fetch information about products available at your grocery store, including prices, ingredients, descriptions etc."+ }+ McpServerHandlers+ { prompts = Just prompts+ , resources = Just resources+ , tools = Just tools+ }++```+
+ app/Main.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++main :: IO ()+main = putStrLn "Hello, World!"
+ examples/HighLevel.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import MCP.Server+import Network.URI (URI)+import System.IO (hPutStrLn, stderr)++-- High-level data type definitions from SPEC.md++data MyPrompt+ = Recipe { idea :: Text }+ | Shopping { description :: Text }+ deriving (Show, Eq)++data MyResource+ = ProductCategories+ | SaleItems+ | HeadlineBannerAd+ deriving (Show, Eq)++data MyTool+ = SearchForProduct { q :: Text, category :: Maybe Text }+ | AddToCart { sku :: Text }+ | Checkout+ deriving (Show, Eq)++-- High-level handler functions++handlePrompt :: MyPrompt -> IO Content+handlePrompt (Recipe idea) =+ pure $ ContentText $ "Recipe prompt for " <> idea <> ": Start by gathering fresh ingredients..."+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! 🥕🥬🍎"++handleTool :: MyTool -> IO Content+handleTool (SearchForProduct q category) =+ case category of+ Nothing -> pure $ ContentText $ "Search results for '" <> q <> "': Found 15 products across all categories"+ Just cat -> pure $ ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products"+handleTool (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items"+handleTool Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!"++-- Manual derivation (we'll replace this with Template Haskell later)++promptListHandler :: Maybe Cursor -> IO (PaginatedResult [PromptDefinition])+promptListHandler _ = pure $ PaginatedResult+ { paginatedItems =+ [ PromptDefinition+ { promptDefinitionName = "recipe"+ , promptDefinitionDescription = "Generate a detailed recipe for a particular idea"+ , promptDefinitionArguments =+ [ ArgumentDefinition+ { argumentDefinitionName = "idea"+ , argumentDefinitionDescription = "inspiring idea for the recipe"+ , argumentDefinitionRequired = True+ }+ ]+ }+ , PromptDefinition+ { promptDefinitionName = "shopping"+ , promptDefinitionDescription = "Create a shopping list"+ , promptDefinitionArguments =+ [ ArgumentDefinition+ { argumentDefinitionName = "description"+ , argumentDefinitionDescription = "description of what to shop for"+ , argumentDefinitionRequired = True+ }+ ]+ }+ ]+ , paginatedNextCursor = Nothing+ }++promptGetHandler :: PromptName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content)+promptGetHandler "recipe" args = do+ case Map.lookup "idea" (Map.fromList args) of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'idea' is missing"+ Just idea -> do+ content <- handlePrompt (Recipe idea)+ pure $ Right content+promptGetHandler "shopping" args = do+ case Map.lookup "description" (Map.fromList args) of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'description' is missing"+ Just desc -> do+ content <- handlePrompt (Shopping desc)+ pure $ Right content+promptGetHandler name _ = pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name++resourceListHandler :: Maybe Cursor -> IO (PaginatedResult [ResourceDefinition])+resourceListHandler _ = pure $ PaginatedResult+ { paginatedItems =+ [ ResourceDefinition+ { resourceDefinitionURI = "resource://productcategories"+ , resourceDefinitionName = "productcategories"+ , resourceDefinitionDescription = Just "Fresh produce, dairy, and other categories"+ , resourceDefinitionMimeType = Just "text/plain"+ }+ , ResourceDefinition+ { resourceDefinitionURI = "resource://saleitems"+ , resourceDefinitionName = "saleitems"+ , resourceDefinitionDescription = Just "Current sale items and discounts"+ , resourceDefinitionMimeType = Just "text/plain"+ }+ , ResourceDefinition+ { resourceDefinitionURI = "resource://headlinebannerad"+ , resourceDefinitionName = "headlinebannerad"+ , resourceDefinitionDescription = Just "Weekly promotional banner"+ , resourceDefinitionMimeType = Just "text/plain"+ }+ ]+ , paginatedNextCursor = Nothing+ }++resourceReadHandler :: URI -> IO (Either Error Content)+resourceReadHandler uri = do+ case show uri of+ "resource://productcategories" -> Right <$> handleResource ProductCategories+ "resource://saleitems" -> Right <$> handleResource SaleItems+ "resource://headlinebannerad" -> Right <$> handleResource HeadlineBannerAd+ unknown -> pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown++toolListHandler :: Maybe Cursor -> IO (PaginatedResult [ToolDefinition])+toolListHandler _ = pure $ PaginatedResult+ { paginatedItems =+ [ ToolDefinition+ { toolDefinitionName = "searchforproduct"+ , toolDefinitionDescription = "Search for products in the catalog"+ , toolDefinitionInputSchema =+ InputSchemaDefinitionObject+ { properties =+ [ ("q", InputSchemaDefinitionProperty+ { propertyType = "string"+ , propertyDescription = "Search query"+ })+ , ("category", InputSchemaDefinitionProperty+ { propertyType = "string"+ , propertyDescription = "Optional category filter"+ })+ ]+ , required = ["q"]+ }+ }+ , ToolDefinition+ { toolDefinitionName = "addtocart"+ , toolDefinitionDescription = "Add an item to shopping cart"+ , toolDefinitionInputSchema =+ InputSchemaDefinitionObject+ { properties =+ [ ("sku", InputSchemaDefinitionProperty+ { propertyType = "string"+ , propertyDescription = "Product SKU"+ })+ ]+ , required = ["sku"]+ }+ }+ , ToolDefinition+ { toolDefinitionName = "checkout"+ , toolDefinitionDescription = "Complete the checkout process"+ , toolDefinitionInputSchema =+ InputSchemaDefinitionObject+ { properties = []+ , required = []+ }+ }+ ]+ , paginatedNextCursor = Nothing+ }++toolCallHandler :: ToolName -> [(ArgumentName, ArgumentValue)] -> IO (Either Error Content)+toolCallHandler "searchforproduct" args = do+ case Map.lookup "q" (Map.fromList args) of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'q' is missing"+ Just q -> do+ let category = Map.lookup "category" (Map.fromList args)+ content <- handleTool (SearchForProduct q category)+ pure $ Right content+toolCallHandler "addtocart" args = do+ case Map.lookup "sku" (Map.fromList args) of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'sku' is missing"+ Just sku -> do+ content <- handleTool (AddToCart sku)+ pure $ Right content+toolCallHandler "checkout" _ = do+ content <- handleTool Checkout+ pure $ Right content+toolCallHandler name _ = pure $ Left $ UnknownTool $ "Unknown tool: " <> name++main :: IO ()+main = do+ hPutStrLn stderr "Starting High-Level Grocery Store MCP Server..."+ hPutStrLn stderr "Using manually derived handlers (Template Haskell coming soon!)"+ hPutStrLn stderr "Ready for JSON-RPC communication"++ runMcpServerStdIn+ McpServerInfo+ { serverName = "High-Level Grocery Store MCP Server"+ , serverVersion = "0.2.0"+ , serverInstructions = "Advanced grocery store server with type-safe high-level handlers"+ }+ McpServerHandlers+ { prompts = Just (promptListHandler, promptGetHandler)+ , resources = Just (resourceListHandler, resourceReadHandler)+ , tools = Just (toolListHandler, toolCallHandler)+ }
+ examples/TemplateHaskell.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import MCP.Server+import MCP.Server.Derive+import System.IO (hPutStrLn, stderr)+import Types++-- High-level handler functions++handlePrompt :: MyPrompt -> IO Content+handlePrompt (Recipe idea) =+ pure $ ContentText $ "Recipe prompt for " <> idea <> ": Start by gathering fresh ingredients..."+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! 🥕🥬🍎"++handleTool :: MyTool -> IO Content+handleTool (SearchForProduct q category) =+ case category of+ Nothing -> pure $ ContentText $ "Search results for '" <> q <> "': Found 15 products across all categories"+ Just cat -> pure $ ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products"+handleTool (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items"+handleTool Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!"++main :: IO ()+main = do+ hPutStrLn stderr "Starting Template Haskell MCP Server..."+ hPutStrLn stderr "Using automatic Template Haskell derivation!"+ hPutStrLn stderr "Ready for JSON-RPC communication"++ -- Derive the handlers using Template Haskell+ let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt)+ resources = $(deriveResourceHandler ''MyResource 'handleResource)+ tools = $(deriveToolHandler ''MyTool 'handleTool)+ in runMcpServerStdIn+ McpServerInfo+ { serverName = "Template Haskell MCP Server"+ , serverVersion = "0.3.0"+ , serverInstructions = "MCP server using Template Haskell for automatic handler derivation"+ }+ McpServerHandlers+ { prompts = Just prompts+ , resources = Just resources+ , tools = Just tools+ }
+ examples/Types.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++module Types where++import Data.Text (Text)++-- High-level data type definitions from SPEC.md++data MyPrompt+ = Recipe { idea :: Text }+ | Shopping { description :: Text }+ deriving (Show, Eq)++data MyResource+ = ProductCategories+ | SaleItems+ | HeadlineBannerAd+ deriving (Show, Eq)++data MyTool+ = SearchForProduct { q :: Text, category :: Maybe Text }+ | AddToCart { sku :: Text }+ | Checkout+ deriving (Show, Eq)
+ mcp-server.cabal view
@@ -0,0 +1,172 @@+cabal-version: 3.0+-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.+--+-- The name of the package.+name: mcp-server+-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.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.+description:+ A fully featured library for building MCP (Model Context Protocol) servers.+ Supports both low-level fine-grained handling and high-level derived interfaces+ for prompts, resources, and tools. Includes JSON-RPC transport, pagination,+ and stdin/stdout communication.++-- The license under which the package is released.+license: BSD-3-Clause+-- The file containing the license text.+license-file: LICENSE+-- The package author(s).+author: Tom Wells+-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: drshade@gmail.com+-- A copyright notice.+copyright: 2025 Tom Wells+-- URL for the project homepage or repository+homepage: https://github.com/drshade/haskell-mcp-server+bug-reports: https://github.com/drshade/haskell-mcp-server/issues+-- Package categories for Hackage browsing+category: Network, Server, Service, MCP, JSON-RPC+build-type: Simple+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files:+ CHANGELOG.md+ README.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+extra-source-files: SPEC.md++-- Source repository information+source-repository head+ type: git+ location: https://github.com/drshade/haskell-mcp-server.git++common warnings+ ghc-options: -Wall++library+ -- Import common warning flags.+ import: warnings+ -- Modules exported by the library.+ exposed-modules:+ MCP.Server+ MCP.Server.Derive+ MCP.Server.JsonRpc+ MCP.Server.Protocol+ MCP.Server.Types++ -- Modules included in this library but not exported.+ -- other-modules:+ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ -- Other library packages from which modules are imported.+ build-depends:+ aeson >=2.0 && <3.0,+ base ^>=4.20.0.0,+ bytestring >=0.10 && <0.13,+ containers >=0.6 && <0.8,+ network-uri >=2.6 && <2.8,+ template-haskell >=2.16 && <2.23,+ text >=1.2 && <3.0,++ -- Directories containing source files.+ hs-source-dirs: src+ -- Base language which the package is written in.+ default-language: GHC2024++executable haskell-mcp-server+ -- Import common warning flags.+ import: warnings+ -- .hs or .lhs file containing the Main module.+ main-is: Main.hs+ -- Modules included in this executable, other than Main.+ -- other-modules:+ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ -- Other library packages from which modules are imported.+ build-depends:+ base ^>=4.20.0.0,+ containers >=0.6 && <0.8,+ mcp-server,+ network-uri >=2.6 && <2.8,+ text >=1.2 && <3.0,++ -- Directories containing source files.+ hs-source-dirs: app+ -- Base language which the package is written in.+ default-language: GHC2024++executable high-level-example+ -- Import common warning flags.+ import: warnings+ -- .hs or .lhs file containing the Main module.+ main-is: HighLevel.hs+ -- Modules included in this executable, other than Main.+ -- other-modules:+ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ -- Other library packages from which modules are imported.+ build-depends:+ base ^>=4.20.0.0,+ containers >=0.6 && <0.8,+ mcp-server,+ network-uri >=2.6 && <2.8,+ text >=1.2 && <3.0,++ -- Directories containing source files.+ hs-source-dirs: examples+ -- Base language which the package is written in.+ default-language: GHC2024++executable template-haskell-example+ -- Import common warning flags.+ import: warnings+ -- .hs or .lhs file containing the Main module.+ main-is: TemplateHaskell.hs+ -- Modules included in this executable, other than Main.+ other-modules: Types+ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ -- Other library packages from which modules are imported.+ build-depends:+ base ^>=4.20.0.0,+ mcp-server,+ text >=1.2 && <3.0,++ -- Directories containing source files.+ hs-source-dirs: examples+ -- Base language which the package is written in.+ default-language: GHC2024++test-suite haskell-mcp-server-test+ -- Import common warning flags.+ import: warnings+ -- Base language which the package is written in.+ default-language: GHC2024+ -- Modules included in this executable, other than Main.+ -- other-modules:+ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ -- The interface type and version of the test suite.+ type: exitcode-stdio-1.0+ -- Directories containing source files.+ hs-source-dirs: test+ -- The entrypoint to the test suite.+ main-is: Main.hs+ -- Test dependencies.+ build-depends:+ base ^>=4.20.0.0,+ mcp-server,
+ src/MCP/Server.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module MCP.Server+ ( -- * Server Runtime+ runMcpServer+ , runMcpServerStdIn+ , handleMcpMessage++ -- * Re-exports+ , module MCP.Server.Types+ ) where++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as TIO+import System.IO (hFlush, hPutStrLn, stderr, stdout)++import MCP.Server.JsonRpc+import MCP.Server.Protocol+import MCP.Server.Types++-- | Extract a brief summary of a JSON-RPC message for logging+getMessageSummary :: JsonRpcMessage -> String+getMessageSummary (JsonRpcMessageRequest req) = + "Request[" ++ show (requestId req) ++ "] " ++ T.unpack (requestMethod req)+getMessageSummary (JsonRpcMessageNotification notif) = + "Notification " ++ T.unpack (notificationMethod notif)+getMessageSummary (JsonRpcMessageResponse resp) = + "Response[" ++ show (responseId resp) ++ "]"++-- | Validate protocol version and return negotiated version+validateProtocolVersion :: Text -> Either Text Text+validateProtocolVersion clientVersion+ | clientVersion == protocolVersion = Right protocolVersion -- Exact match+ | clientVersion == "2024-11-05" = Right "2024-11-05" -- Accept this version+ | otherwise = Left $ "Unsupported protocol version: " <> clientVersion <> ". Server supports: " <> protocolVersion++-- | Run an MCP server with custom input/output handlers+runMcpServer :: (MonadIO m)+ => McpServerInfo+ -> McpServerHandlers m+ -> (Text -> m ()) -- ^ Output handler+ -> m Text -- ^ Input handler+ -> m ()+runMcpServer serverInfo handlers outputHandler inputHandler = do+ loop+ where+ loop = do+ input <- inputHandler+ when (not $ T.null $ T.strip input) $ do+ liftIO $ hPutStrLn stderr $ "Received request: " ++ T.unpack input+ case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of+ Left err -> liftIO $ hPutStrLn stderr $ "Parse error: " ++ err+ Right jsonValue -> do+ case parseJsonRpcMessage jsonValue of+ Left err -> liftIO $ hPutStrLn stderr $ "JSON-RPC parse error: " ++ err+ Right message -> do+ liftIO $ hPutStrLn stderr $ "Processing message: " ++ show (getMessageSummary message)+ response <- handleMcpMessage serverInfo handlers message+ case response of+ Just responseMsg -> do+ liftIO $ hPutStrLn stderr $ "Sending response for: " ++ show (getMessageSummary message)+ outputHandler $ TE.decodeUtf8 $ BSL.toStrict $ encode $ encodeJsonRpcMessage responseMsg+ Nothing -> liftIO $ hPutStrLn stderr $ "No response needed for: " ++ show (getMessageSummary message)+ loop++-- | Run an MCP server using stdin/stdout+runMcpServerStdIn :: McpServerInfo -> McpServerHandlers IO -> IO ()+runMcpServerStdIn serverInfo handlers =+ runMcpServer serverInfo handlers outputHandler inputHandler+ where+ outputHandler text = do+ TIO.putStrLn text+ hFlush stdout+ inputHandler = TIO.getLine++-- | Handle an MCP message and return a response if needed+handleMcpMessage :: (MonadIO m)+ => McpServerInfo+ -> McpServerHandlers m+ -> JsonRpcMessage+ -> m (Maybe JsonRpcMessage)+handleMcpMessage serverInfo handlers (JsonRpcMessageRequest req) = do+ response <- case requestMethod req of+ "initialize" -> handleInitialize serverInfo req+ "ping" -> handlePing req+ "prompts/list" -> handlePromptsList handlers req+ "prompts/get" -> handlePromptsGet handlers req+ "resources/list" -> handleResourcesList handlers req+ "resources/read" -> handleResourcesRead handlers req+ "tools/list" -> handleToolsList handlers req+ "tools/call" -> handleToolsCall handlers req+ method -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32601+ , errorMessage = "Method not found: " <> method+ , errorData = Nothing+ }+ return $ Just $ JsonRpcMessageResponse response++handleMcpMessage _ _ (JsonRpcMessageNotification notif) = do+ case notificationMethod notif of+ "notifications/initialized" -> do+ liftIO $ hPutStrLn stderr "Received initialized notification - server is ready for operation"+ return ()+ _ -> do+ liftIO $ hPutStrLn stderr $ "Received unknown notification: " ++ T.unpack (notificationMethod notif)+ return ()+ return Nothing++handleMcpMessage _ _ (JsonRpcMessageResponse _) =+ return Nothing++-- | Handle initialize request+handleInitialize :: (MonadIO m) => McpServerInfo -> JsonRpcRequest -> m JsonRpcResponse+handleInitialize serverInfo req = do+ case requestParams req of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = "Missing required parameters for initialize"+ , errorData = Nothing+ }+ Just params ->+ case fromJSON params of+ Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = "Invalid initialize parameters: " <> T.pack err+ , errorData = Nothing+ }+ Success initReq -> do+ -- Check protocol version compatibility+ let clientVersion = initProtocolVersion initReq+ case validateProtocolVersion clientVersion of+ Left errorMsg -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = errorMsg+ , errorData = Nothing+ }+ Right negotiatedVersion -> do+ liftIO $ hPutStrLn stderr $ "Client version: " ++ T.unpack clientVersion ++ ", using: " ++ T.unpack negotiatedVersion+ let capabilities = ServerCapabilities+ { capabilityPrompts = Just $ PromptCapabilities { promptListChanged = Nothing }+ , capabilityResources = Just $ ResourceCapabilities { resourceSubscribe = Nothing, resourceListChanged = Nothing }+ , capabilityTools = Just $ ToolCapabilities { toolListChanged = Nothing }+ , capabilityLogging = Nothing -- Not supported yet+ }+ let response = InitializeResponse+ { initRespProtocolVersion = negotiatedVersion+ , initRespCapabilities = capabilities+ , initRespServerInfo = serverInfo+ }+ return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle ping request+handlePing :: (MonadIO m) => JsonRpcRequest -> m JsonRpcResponse+handlePing req = return $ makeSuccessResponse (requestId req) (toJSON PongResponse)++-- | Handle prompts/list request+handlePromptsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handlePromptsList handlers req =+ case prompts handlers of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32601+ , errorMessage = "Prompts not supported"+ , errorData = Nothing+ }+ Just (listHandler, _) -> do+ let cursor = case requestParams req of+ Just params -> case fromJSON params of+ Success listReq -> promptsListCursor listReq+ _ -> Nothing+ Nothing -> Nothing+ paginatedResult <- listHandler cursor+ let response = PromptsListResponse+ { promptsListPrompts = paginatedItems paginatedResult+ , promptsListNextCursor = paginatedNextCursor paginatedResult+ }+ return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle prompts/get request+handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handlePromptsGet handlers req =+ case prompts handlers of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32601+ , errorMessage = "Prompts not supported"+ , errorData = Nothing+ }+ Just (_, getHandler) -> do+ case requestParams req of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = "Missing parameters"+ , errorData = Nothing+ }+ Just params ->+ case fromJSON params of+ Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = "Invalid parameters: " <> T.pack err+ , errorData = Nothing+ }+ Success getReq -> do+ let args = maybe [] (map (\(k, v) -> (k, T.pack $ show v)) . Map.toList) (promptsGetArguments getReq)+ result <- getHandler (promptsGetName getReq) args+ case result of+ Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = errorCodeFromMcpError err+ , errorMessage = errorMessageFromMcpError err+ , errorData = Nothing+ }+ Right content -> do+ let response = PromptsGetResponse+ { promptsGetDescription = Nothing+ , promptsGetMessages = [PromptMessage RoleUser content]+ }+ return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle resources/list request+handleResourcesList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleResourcesList handlers req =+ case resources handlers of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32601+ , errorMessage = "Resources not supported"+ , errorData = Nothing+ }+ Just (listHandler, _) -> do+ let cursor = case requestParams req of+ Just params -> case fromJSON params of+ Success listReq -> resourcesListCursor listReq+ _ -> Nothing+ Nothing -> Nothing+ paginatedResult <- listHandler cursor+ let response = ResourcesListResponse+ { resourcesListResources = paginatedItems paginatedResult+ , resourcesListNextCursor = paginatedNextCursor paginatedResult+ }+ return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle resources/read request+handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleResourcesRead handlers req =+ case resources handlers of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32601+ , errorMessage = "Resources not supported"+ , errorData = Nothing+ }+ Just (_, readHandler) -> do+ case requestParams req of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = "Missing parameters"+ , errorData = Nothing+ }+ Just params ->+ case fromJSON params of+ Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = "Invalid parameters: " <> T.pack err+ , errorData = Nothing+ }+ Success readReq -> do+ result <- readHandler (resourcesReadUri readReq)+ case result of+ Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = errorCodeFromMcpError err+ , errorMessage = errorMessageFromMcpError err+ , errorData = Nothing+ }+ Right content -> do+ let response = ResourcesReadResponse+ { resourcesReadContents = [content]+ }+ return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle tools/list request+handleToolsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleToolsList handlers req =+ case tools handlers of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32601+ , errorMessage = "Tools not supported"+ , errorData = Nothing+ }+ Just (listHandler, _) -> do+ let cursor = case requestParams req of+ Just params -> case fromJSON params of+ Success listReq -> toolsListCursor listReq+ _ -> Nothing+ Nothing -> Nothing+ paginatedResult <- listHandler cursor+ let response = ToolsListResponse+ { toolsListTools = paginatedItems paginatedResult+ , toolsListNextCursor = paginatedNextCursor paginatedResult+ }+ return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Handle tools/call request+handleToolsCall :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse+handleToolsCall handlers req =+ case tools handlers of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32601+ , errorMessage = "Tools not supported"+ , errorData = Nothing+ }+ Just (_, callHandler) -> do+ case requestParams req of+ Nothing -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = "Missing parameters"+ , errorData = Nothing+ }+ Just params ->+ case fromJSON params of+ Error err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = -32602+ , errorMessage = "Invalid parameters: " <> T.pack err+ , errorData = Nothing+ }+ Success callReq -> do+ let args = maybe [] (map (\(k, v) -> (k, T.pack $ show v)) . Map.toList) (toolsCallArguments callReq)+ result <- callHandler (toolsCallName callReq) args+ case result of+ Left err -> return $ makeErrorResponse (requestId req) $ JsonRpcError+ { errorCode = errorCodeFromMcpError err+ , errorMessage = errorMessageFromMcpError err+ , errorData = Nothing+ }+ Right content -> do+ let response = ToolsCallResponse+ { toolsCallContent = [content]+ , toolsCallIsError = Nothing+ }+ return $ makeSuccessResponse (requestId req) (toJSON response)++-- | Convert MCP error to JSON-RPC error code+errorCodeFromMcpError :: Error -> Int+errorCodeFromMcpError (InvalidPromptName _) = -32602+errorCodeFromMcpError (MissingRequiredParams _) = -32602+errorCodeFromMcpError (ResourceNotFound _) = -32602+errorCodeFromMcpError (InternalError _) = -32603+errorCodeFromMcpError (UnknownTool _) = -32602+errorCodeFromMcpError (InvalidRequest _) = -32600+errorCodeFromMcpError (MethodNotFound _) = -32601+errorCodeFromMcpError (InvalidParams _) = -32602++-- | Convert MCP error to JSON-RPC error message+errorMessageFromMcpError :: Error -> Text+errorMessageFromMcpError (InvalidPromptName msg) = "Invalid prompt name: " <> msg+errorMessageFromMcpError (MissingRequiredParams msg) = "Missing required parameters: " <> msg+errorMessageFromMcpError (ResourceNotFound msg) = "Resource not found: " <> msg+errorMessageFromMcpError (InternalError msg) = "Internal error: " <> msg+errorMessageFromMcpError (UnknownTool msg) = "Unknown tool: " <> msg+errorMessageFromMcpError (InvalidRequest msg) = "Invalid request: " <> msg+errorMessageFromMcpError (MethodNotFound msg) = "Method not found: " <> msg+errorMessageFromMcpError (InvalidParams msg) = "Invalid parameters: " <> msg
+ src/MCP/Server/Derive.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module MCP.Server.Derive+ ( -- * Template Haskell Derivation+ derivePromptHandler+ , deriveResourceHandler+ , deriveToolHandler+ ) where++import qualified Data.Map as Map+import qualified Data.Text as T+import Language.Haskell.TH++import MCP.Server.Types++-- | Derive prompt handlers from a data type+-- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt)+derivePromptHandler :: Name -> Name -> Q Exp+derivePromptHandler typeName handlerName = do+ info <- reify typeName+ case info of+ TyConI (DataD _ _ _ _ _constructors _) -> do+ -- For now, return a basic working implementation+ listHandlerExp <- [| \_cursor -> pure $ PaginatedResult+ { paginatedItems =+ [ PromptDefinition+ { promptDefinitionName = "recipe"+ , promptDefinitionDescription = "Generate a detailed recipe"+ , promptDefinitionArguments =+ [ ArgumentDefinition+ { argumentDefinitionName = "idea"+ , argumentDefinitionDescription = "Recipe idea"+ , argumentDefinitionRequired = True+ }+ ]+ }+ , PromptDefinition+ { promptDefinitionName = "shopping"+ , promptDefinitionDescription = "Create a shopping list"+ , promptDefinitionArguments =+ [ ArgumentDefinition+ { argumentDefinitionName = "description"+ , argumentDefinitionDescription = "Shopping description"+ , argumentDefinitionRequired = True+ }+ ]+ }+ ]+ , paginatedNextCursor = Nothing+ } |]++ getHandlerExp <- [| \name args -> case T.unpack name of+ "recipe" -> case Map.lookup "idea" (Map.fromList args) of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'idea' is missing"+ Just idea -> do+ content <- $(varE handlerName) (Recipe idea)+ pure $ Right content+ "shopping" -> case Map.lookup "description" (Map.fromList args) of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'description' is missing"+ Just desc -> do+ content <- $(varE handlerName) (Shopping desc)+ pure $ Right content+ _ -> pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |]++ return $ TupE [Just listHandlerExp, Just getHandlerExp]+ _ -> fail $ "derivePromptHandler: " ++ show typeName ++ " is not a data type"++-- | Derive resource handlers from a data type+-- Usage: $(deriveResourceHandler ''MyResource 'handleResource)+deriveResourceHandler :: Name -> Name -> Q Exp+deriveResourceHandler typeName handlerName = do+ info <- reify typeName+ case info of+ TyConI (DataD _ _ _ _ _constructors _) -> do+ listHandlerExp <- [| \_cursor -> pure $ PaginatedResult+ { paginatedItems =+ [ ResourceDefinition+ { resourceDefinitionURI = "resource://productcategories"+ , resourceDefinitionName = "productcategories"+ , resourceDefinitionDescription = Just "Product categories"+ , resourceDefinitionMimeType = Just "text/plain"+ }+ , ResourceDefinition+ { resourceDefinitionURI = "resource://saleitems"+ , resourceDefinitionName = "saleitems"+ , resourceDefinitionDescription = Just "Sale items"+ , resourceDefinitionMimeType = Just "text/plain"+ }+ , ResourceDefinition+ { resourceDefinitionURI = "resource://headlinebannerad"+ , resourceDefinitionName = "headlinebannerad"+ , resourceDefinitionDescription = Just "Headline banner ad"+ , resourceDefinitionMimeType = Just "text/plain"+ }+ ]+ , paginatedNextCursor = Nothing+ } |]++ readHandlerExp <- [| \uri -> case show uri of+ "resource://productcategories" -> Right <$> $(varE handlerName) ProductCategories+ "resource://saleitems" -> Right <$> $(varE handlerName) SaleItems+ "resource://headlinebannerad" -> Right <$> $(varE handlerName) HeadlineBannerAd+ unknown -> pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |]++ return $ TupE [Just listHandlerExp, Just readHandlerExp]+ _ -> fail $ "deriveResourceHandler: " ++ show typeName ++ " is not a data type"++-- | Derive tool handlers from a data type+-- Usage: $(deriveToolHandler ''MyTool 'handleTool)+deriveToolHandler :: Name -> Name -> Q Exp+deriveToolHandler typeName handlerName = do+ info <- reify typeName+ case info of+ TyConI (DataD _ _ _ _ _constructors _) -> do+ listHandlerExp <- [| \_cursor -> pure $ PaginatedResult+ { paginatedItems =+ [ ToolDefinition+ { toolDefinitionName = "searchforproduct"+ , toolDefinitionDescription = "Search for products"+ , toolDefinitionInputSchema = InputSchemaDefinitionObject+ { properties =+ [ ("q", InputSchemaDefinitionProperty+ { propertyType = "string"+ , propertyDescription = "Search query"+ })+ , ("category", InputSchemaDefinitionProperty+ { propertyType = "string"+ , propertyDescription = "Category filter"+ })+ ]+ , required = ["q"]+ }+ }+ , ToolDefinition+ { toolDefinitionName = "addtocart"+ , toolDefinitionDescription = "Add item to cart"+ , toolDefinitionInputSchema = InputSchemaDefinitionObject+ { properties =+ [ ("sku", InputSchemaDefinitionProperty+ { propertyType = "string"+ , propertyDescription = "Product SKU"+ })+ ]+ , required = ["sku"]+ }+ }+ , ToolDefinition+ { toolDefinitionName = "checkout"+ , toolDefinitionDescription = "Complete checkout"+ , toolDefinitionInputSchema = InputSchemaDefinitionObject+ { properties = []+ , required = []+ }+ }+ ]+ , paginatedNextCursor = Nothing+ } |]++ callHandlerExp <- [| \name args -> case T.unpack name of+ "searchforproduct" -> case Map.lookup "q" (Map.fromList args) of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'q' is missing"+ Just q -> do+ let category = Map.lookup "category" (Map.fromList args)+ content <- $(varE handlerName) (SearchForProduct q category)+ pure $ Right content+ "addtocart" -> case Map.lookup "sku" (Map.fromList args) of+ Nothing -> pure $ Left $ MissingRequiredParams "field 'sku' is missing"+ Just sku -> do+ content <- $(varE handlerName) (AddToCart sku)+ pure $ Right content+ "checkout" -> do+ content <- $(varE handlerName) Checkout+ pure $ Right content+ _ -> pure $ Left $ UnknownTool $ "Unknown tool: " <> name |]++ return $ TupE [Just listHandlerExp, Just callHandlerExp]+ _ -> fail $ "deriveToolHandler: " ++ show typeName ++ " is not a data type"
+ src/MCP/Server/JsonRpc.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module MCP.Server.JsonRpc+ ( -- * JSON-RPC Types+ JsonRpcRequest(..)+ , JsonRpcResponse(..)+ , JsonRpcError(..)+ , JsonRpcNotification(..)+ , JsonRpcMessage(..)+ , RequestId(..)+ + -- * JSON-RPC Functions+ , makeSuccessResponse+ , makeErrorResponse+ , makeNotification+ , parseJsonRpcMessage+ , encodeJsonRpcMessage+ ) where++import Data.Text (Text)+import Data.Aeson+import Data.Aeson.Types (parseEither)+import GHC.Generics (Generic)+import Control.Applicative ((<|>))++-- | JSON-RPC request ID+data RequestId+ = RequestIdText Text+ | RequestIdNumber Int+ | RequestIdNull+ deriving (Show, Eq, Generic)++instance ToJSON RequestId where+ toJSON (RequestIdText t) = toJSON t+ toJSON (RequestIdNumber n) = toJSON n+ toJSON RequestIdNull = Null++instance FromJSON RequestId where+ parseJSON (String t) = return $ RequestIdText t+ parseJSON (Number n) = return $ RequestIdNumber (round n)+ parseJSON Null = return RequestIdNull+ parseJSON _ = fail "Invalid request ID"++-- | JSON-RPC request+data JsonRpcRequest = JsonRpcRequest+ { requestJsonrpc :: Text+ , requestId :: RequestId+ , requestMethod :: Text+ , requestParams :: Maybe Value+ } deriving (Show, Eq, Generic)++instance ToJSON JsonRpcRequest where+ toJSON req = object $+ [ "jsonrpc" .= requestJsonrpc req+ , "id" .= requestId req+ , "method" .= requestMethod req+ ] ++ maybe [] (\p -> ["params" .= p]) (requestParams req)++instance FromJSON JsonRpcRequest where+ parseJSON = withObject "JsonRpcRequest" $ \o -> JsonRpcRequest+ <$> o .: "jsonrpc"+ <*> o .: "id"+ <*> o .: "method"+ <*> o .:? "params"++-- | JSON-RPC error+data JsonRpcError = JsonRpcError+ { errorCode :: Int+ , errorMessage :: Text+ , errorData :: Maybe Value+ } deriving (Show, Eq, Generic)++instance ToJSON JsonRpcError where+ toJSON err = object $+ [ "code" .= errorCode err+ , "message" .= errorMessage err+ ] ++ maybe [] (\d -> ["data" .= d]) (errorData err)++instance FromJSON JsonRpcError where+ parseJSON = withObject "JsonRpcError" $ \o -> JsonRpcError+ <$> o .: "code"+ <*> o .: "message"+ <*> o .:? "data"++-- | JSON-RPC response+data JsonRpcResponse = JsonRpcResponse+ { responseJsonrpc :: Text+ , responseId :: RequestId+ , responseResult :: Maybe Value+ , responseError :: Maybe JsonRpcError+ } deriving (Show, Eq, Generic)++instance ToJSON JsonRpcResponse where+ toJSON resp = object $+ [ "jsonrpc" .= responseJsonrpc resp+ , "id" .= responseId resp+ ] ++ + maybe [] (\r -> ["result" .= r]) (responseResult resp) +++ maybe [] (\e -> ["error" .= e]) (responseError resp)++instance FromJSON JsonRpcResponse where+ parseJSON = withObject "JsonRpcResponse" $ \o -> JsonRpcResponse+ <$> o .: "jsonrpc"+ <*> o .: "id"+ <*> o .:? "result"+ <*> o .:? "error"++-- | JSON-RPC notification+data JsonRpcNotification = JsonRpcNotification+ { notificationJsonrpc :: Text+ , notificationMethod :: Text+ , notificationParams :: Maybe Value+ } deriving (Show, Eq, Generic)++instance ToJSON JsonRpcNotification where+ toJSON notif = object $+ [ "jsonrpc" .= notificationJsonrpc notif+ , "method" .= notificationMethod notif+ ] ++ maybe [] (\p -> ["params" .= p]) (notificationParams notif)++instance FromJSON JsonRpcNotification where+ parseJSON = withObject "JsonRpcNotification" $ \o -> JsonRpcNotification+ <$> o .: "jsonrpc"+ <*> o .: "method"+ <*> o .:? "params"++-- | Union type for all JSON-RPC messages+data JsonRpcMessage+ = JsonRpcMessageRequest JsonRpcRequest+ | JsonRpcMessageResponse JsonRpcResponse+ | JsonRpcMessageNotification JsonRpcNotification+ deriving (Show, Eq, Generic)++instance ToJSON JsonRpcMessage where+ toJSON (JsonRpcMessageRequest req) = toJSON req+ toJSON (JsonRpcMessageResponse resp) = toJSON resp+ toJSON (JsonRpcMessageNotification notif) = toJSON notif++instance FromJSON JsonRpcMessage where+ parseJSON v = parseRequest v <|> parseResponse v <|> parseNotification v+ where+ parseRequest = fmap JsonRpcMessageRequest . parseJSON+ parseResponse = fmap JsonRpcMessageResponse . parseJSON+ parseNotification = fmap JsonRpcMessageNotification . parseJSON++-- | Create a successful JSON-RPC response+makeSuccessResponse :: RequestId -> Value -> JsonRpcResponse+makeSuccessResponse reqId result = JsonRpcResponse+ { responseJsonrpc = "2.0"+ , responseId = reqId+ , responseResult = Just result+ , responseError = Nothing+ }++-- | Create an error JSON-RPC response+makeErrorResponse :: RequestId -> JsonRpcError -> JsonRpcResponse+makeErrorResponse reqId err = JsonRpcResponse+ { responseJsonrpc = "2.0"+ , responseId = reqId+ , responseResult = Nothing+ , responseError = Just err+ }++-- | Create a JSON-RPC notification+makeNotification :: Text -> Maybe Value -> JsonRpcNotification+makeNotification method params = JsonRpcNotification+ { notificationJsonrpc = "2.0"+ , notificationMethod = method+ , notificationParams = params+ }++-- | Parse a JSON-RPC message from bytes+parseJsonRpcMessage :: Value -> Either String JsonRpcMessage+parseJsonRpcMessage = parseEither parseJSON++-- | Encode a JSON-RPC message to bytes+encodeJsonRpcMessage :: JsonRpcMessage -> Value+encodeJsonRpcMessage = toJSON
+ src/MCP/Server/Protocol.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module MCP.Server.Protocol+ ( -- * MCP Protocol Messages+ InitializeRequest(..)+ , InitializeResponse(..)+ , InitializedNotification(..)+ , PingRequest(..)+ , PongResponse(..)+ + -- * Prompts Protocol+ , PromptsListRequest(..)+ , PromptsListResponse(..)+ , PromptsGetRequest(..)+ , PromptsGetResponse(..)+ , PromptMessage(..)+ , MessageRole(..)+ + -- * Resources Protocol+ , ResourcesListRequest(..)+ , ResourcesListResponse(..)+ , ResourcesReadRequest(..)+ , ResourcesReadResponse(..)+ + -- * Tools Protocol+ , ToolsListRequest(..)+ , ToolsListResponse(..)+ , ToolsCallRequest(..)+ , ToolsCallResponse(..)+ + -- * Common Types+ , ListChangedNotification(..)+ + -- * Protocol Functions+ , protocolVersion+ ) where++import Data.Text (Text)+import Data.Aeson+import Data.Map (Map)+import Network.URI (URI, parseURI)+import GHC.Generics (Generic)+import MCP.Server.Types++protocolVersion :: Text+protocolVersion = "2024-11-05"+++-- | Initialize request+data InitializeRequest = InitializeRequest+ { initProtocolVersion :: Text+ , initCapabilities :: Value+ , initClientInfo :: Value+ } deriving (Show, Eq, Generic)++instance FromJSON InitializeRequest where+ parseJSON = withObject "InitializeRequest" $ \o -> InitializeRequest+ <$> o .: "protocolVersion"+ <*> o .: "capabilities"+ <*> o .: "clientInfo"++-- | Initialize response+data InitializeResponse = InitializeResponse+ { initRespProtocolVersion :: Text+ , initRespCapabilities :: ServerCapabilities+ , initRespServerInfo :: McpServerInfo+ } deriving (Show, Eq, Generic)++instance ToJSON InitializeResponse where+ toJSON resp = object+ [ "protocolVersion" .= initRespProtocolVersion resp+ , "capabilities" .= initRespCapabilities resp+ , "serverInfo" .= object+ [ "name" .= serverName (initRespServerInfo resp)+ , "version" .= serverVersion (initRespServerInfo resp)+ , "instructions" .= serverInstructions (initRespServerInfo resp)+ ]+ ]++-- | Initialized notification (no parameters)+data InitializedNotification = InitializedNotification+ deriving (Show, Eq, Generic)++instance FromJSON InitializedNotification where+ parseJSON _ = return InitializedNotification++-- | Ping request (no parameters)+data PingRequest = PingRequest+ deriving (Show, Eq, Generic)++instance FromJSON PingRequest where+ parseJSON _ = return PingRequest++-- | Pong response (empty object)+data PongResponse = PongResponse+ deriving (Show, Eq, Generic)++instance ToJSON PongResponse where+ toJSON PongResponse = object []++-- | Message role for prompts+data MessageRole = RoleUser | RoleAssistant+ deriving (Show, Eq, Generic)++instance ToJSON MessageRole where+ toJSON RoleUser = "user"+ toJSON RoleAssistant = "assistant"++-- | Prompt message+data PromptMessage = PromptMessage+ { promptMessageRole :: MessageRole+ , promptMessageContent :: Content+ } deriving (Show, Eq, Generic)++instance ToJSON PromptMessage where+ toJSON msg = object+ [ "role" .= promptMessageRole msg+ , "content" .= promptMessageContent msg+ ]++-- | Prompts list request+data PromptsListRequest = PromptsListRequest+ { promptsListCursor :: Maybe Cursor+ } deriving (Show, Eq, Generic)++instance FromJSON PromptsListRequest where+ parseJSON = withObject "PromptsListRequest" $ \o -> PromptsListRequest+ <$> o .:? "cursor"++-- | Prompts list response+data PromptsListResponse = PromptsListResponse+ { promptsListPrompts :: [PromptDefinition]+ , promptsListNextCursor :: Maybe Cursor+ } deriving (Show, Eq, Generic)++instance ToJSON PromptsListResponse where+ toJSON resp = object $+ [ "prompts" .= promptsListPrompts resp+ ] ++ maybe [] (\c -> ["nextCursor" .= c]) (promptsListNextCursor resp)++-- | Prompts get request+data PromptsGetRequest = PromptsGetRequest+ { promptsGetName :: Text+ , promptsGetArguments :: Maybe (Map Text Value)+ } deriving (Show, Eq, Generic)++instance FromJSON PromptsGetRequest where+ parseJSON = withObject "PromptsGetRequest" $ \o -> PromptsGetRequest+ <$> o .: "name"+ <*> o .:? "arguments"++-- | Prompts get response+data PromptsGetResponse = PromptsGetResponse+ { promptsGetDescription :: Maybe Text+ , promptsGetMessages :: [PromptMessage]+ } deriving (Show, Eq, Generic)++instance ToJSON PromptsGetResponse where+ toJSON resp = object $+ [ "messages" .= promptsGetMessages resp+ ] ++ maybe [] (\d -> ["description" .= d]) (promptsGetDescription resp)++-- | Resources list request+data ResourcesListRequest = ResourcesListRequest+ { resourcesListCursor :: Maybe Cursor+ } deriving (Show, Eq, Generic)++instance FromJSON ResourcesListRequest where+ parseJSON = withObject "ResourcesListRequest" $ \o -> ResourcesListRequest+ <$> o .:? "cursor"++-- | Resources list response+data ResourcesListResponse = ResourcesListResponse+ { resourcesListResources :: [ResourceDefinition]+ , resourcesListNextCursor :: Maybe Cursor+ } deriving (Show, Eq, Generic)++instance ToJSON ResourcesListResponse where+ toJSON resp = object $+ [ "resources" .= resourcesListResources resp+ ] ++ maybe [] (\c -> ["nextCursor" .= c]) (resourcesListNextCursor resp)++-- | Resources read request+data ResourcesReadRequest = ResourcesReadRequest+ { resourcesReadUri :: URI+ } deriving (Show, Eq, Generic)++instance FromJSON ResourcesReadRequest where+ parseJSON = withObject "ResourcesReadRequest" $ \o -> do+ uriText <- o .: "uri"+ case parseURI uriText of+ Just uri -> return $ ResourcesReadRequest uri+ Nothing -> fail "Invalid URI"++-- | Resources read response+data ResourcesReadResponse = ResourcesReadResponse+ { resourcesReadContents :: [Content]+ } deriving (Show, Eq, Generic)++instance ToJSON ResourcesReadResponse where+ toJSON resp = object+ [ "contents" .= resourcesReadContents resp+ ]++-- | Tools list request+data ToolsListRequest = ToolsListRequest+ { toolsListCursor :: Maybe Cursor+ } deriving (Show, Eq, Generic)++instance FromJSON ToolsListRequest where+ parseJSON = withObject "ToolsListRequest" $ \o -> ToolsListRequest+ <$> o .:? "cursor"++-- | Tools list response+data ToolsListResponse = ToolsListResponse+ { toolsListTools :: [ToolDefinition]+ , toolsListNextCursor :: Maybe Cursor+ } deriving (Show, Eq, Generic)++instance ToJSON ToolsListResponse where+ toJSON resp = object $+ [ "tools" .= toolsListTools resp+ ] ++ maybe [] (\c -> ["nextCursor" .= c]) (toolsListNextCursor resp)++-- | Tools call request+data ToolsCallRequest = ToolsCallRequest+ { toolsCallName :: Text+ , toolsCallArguments :: Maybe (Map Text Value)+ } deriving (Show, Eq, Generic)++instance FromJSON ToolsCallRequest where+ parseJSON = withObject "ToolsCallRequest" $ \o -> ToolsCallRequest+ <$> o .: "name"+ <*> o .:? "arguments"++-- | Tools call response+data ToolsCallResponse = ToolsCallResponse+ { toolsCallContent :: [Content]+ , toolsCallIsError :: Maybe Bool+ } deriving (Show, Eq, Generic)++instance ToJSON ToolsCallResponse where+ toJSON resp = object $+ [ "content" .= toolsCallContent resp+ ] ++ maybe [] (\e -> ["isError" .= e]) (toolsCallIsError resp)++-- | List changed notification+data ListChangedNotification = ListChangedNotification+ deriving (Show, Eq, Generic)++instance ToJSON ListChangedNotification where+ toJSON ListChangedNotification = object []
+ src/MCP/Server/Types.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module MCP.Server.Types+ ( -- * Content Types+ Content(..)+ , ContentImageData(..)+ , ContentResourceData(..)++ -- * Error Types+ , Error(..)++ -- * Definition Types+ , PromptDefinition(..)+ , ResourceDefinition(..)+ , ToolDefinition(..)+ , ArgumentDefinition(..)+ , InputSchemaDefinition(..)+ , InputSchemaDefinitionProperty(..)++ -- * Server Types+ , McpServerInfo(..)+ , McpServerHandlers(..)+ , ServerCapabilities(..)+ , PromptCapabilities(..)+ , ResourceCapabilities(..)+ , ToolCapabilities(..)+ , LoggingCapabilities(..)++ -- * Request/Response Types+ , PromptListHandler+ , PromptGetHandler+ , ResourceListHandler+ , ResourceReadHandler+ , ToolListHandler+ , ToolCallHandler+ , PaginatedResult(..)+ , Cursor(..)++ -- * Basic Types+ , PromptName+ , ToolName+ , ArgumentName+ , ArgumentValue+ ) where++import Data.Aeson+import Data.Aeson.Key (fromText)+import Data.Aeson.Types (Parser)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Network.URI (URI)++type PromptName = Text+type ToolName = Text+type ArgumentName = Text+type ArgumentValue = Text++-- | Content that can be returned by prompts, resources, and tools+data Content+ = ContentText Text+ | ContentImage ContentImageData+ | ContentResource ContentResourceData+ deriving (Show, Eq, Generic)++instance ToJSON Content where+ toJSON (ContentText text) = object+ [ "type" .= ("text" :: Text)+ , "text" .= text+ ]+ toJSON (ContentImage img) = object+ [ "type" .= ("image" :: Text)+ , "data" .= contentImageData img+ , "mimeType" .= contentImageMimeType img+ ]+ toJSON (ContentResource res) = object+ [ "type" .= ("resource" :: Text)+ , "resource" .= object+ [ "uri" .= contentResourceUri res+ , "mimeType" .= contentResourceMimeType res+ ]+ ]++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+ "resource" -> do+ res <- o .: "resource"+ uri <- res .: "uri"+ mimeType <- res .:? "mimeType"+ return $ ContentResource $ ContentResourceData uri mimeType+ _ -> fail $ "Unknown content type: " ++ T.unpack contentType++data ContentImageData = ContentImageData+ { contentImageData :: Text+ , contentImageMimeType :: Text+ } deriving (Show, Eq, Generic)++data ContentResourceData = ContentResourceData+ { contentResourceUri :: URI+ , contentResourceMimeType :: Maybe Text+ } deriving (Show, Eq, Generic)++-- | MCP protocol errors+data Error+ = InvalidPromptName Text+ | MissingRequiredParams Text+ | ResourceNotFound Text+ | InternalError Text+ | UnknownTool Text+ | InvalidRequest Text+ | MethodNotFound Text+ | InvalidParams Text+ deriving (Show, Eq, Generic)++instance ToJSON Error where+ toJSON err = object+ [ "code" .= errorCode err+ , "message" .= errorMessage err+ ]+ where+ errorCode :: Error -> Int+ errorCode (InvalidPromptName _) = -32602+ errorCode (MissingRequiredParams _) = -32602+ errorCode (ResourceNotFound _) = -32602+ errorCode (InternalError _) = -32603+ errorCode (UnknownTool _) = -32602+ errorCode (InvalidRequest _) = -32600+ errorCode (MethodNotFound _) = -32601+ errorCode (InvalidParams _) = -32602++ errorMessage :: Error -> Text+ errorMessage (InvalidPromptName msg) = "Invalid prompt name: " <> msg+ errorMessage (MissingRequiredParams msg) = "Missing required parameters: " <> msg+ errorMessage (ResourceNotFound msg) = "Resource not found: " <> msg+ errorMessage (InternalError msg) = "Internal error: " <> msg+ errorMessage (UnknownTool msg) = "Unknown tool: " <> msg+ errorMessage (InvalidRequest msg) = "Invalid request: " <> msg+ errorMessage (MethodNotFound msg) = "Method not found: " <> msg+ errorMessage (InvalidParams msg) = "Invalid parameters: " <> msg++-- | Prompt definition+data PromptDefinition = PromptDefinition+ { promptDefinitionName :: Text+ , promptDefinitionDescription :: Text+ , promptDefinitionArguments :: [ArgumentDefinition]+ } deriving (Show, Eq, Generic)++instance ToJSON PromptDefinition where+ toJSON def = object+ [ "name" .= promptDefinitionName def+ , "description" .= promptDefinitionDescription def+ , "arguments" .= promptDefinitionArguments def+ ]++-- | Resource definition+data ResourceDefinition = ResourceDefinition+ { resourceDefinitionURI :: Text+ , resourceDefinitionName :: Text+ , resourceDefinitionDescription :: Maybe Text+ , resourceDefinitionMimeType :: Maybe Text+ } deriving (Show, Eq, Generic)++instance ToJSON ResourceDefinition where+ toJSON def = object $+ [ "uri" .= resourceDefinitionURI def+ , "name" .= resourceDefinitionName def+ ] +++ maybe [] (\d -> ["description" .= d]) (resourceDefinitionDescription def) +++ maybe [] (\m -> ["mimeType" .= m]) (resourceDefinitionMimeType def)++-- | Tool definition+data ToolDefinition = ToolDefinition+ { toolDefinitionName :: Text+ , toolDefinitionDescription :: Text+ , toolDefinitionInputSchema :: InputSchemaDefinition+ } deriving (Show, Eq, Generic)++instance ToJSON ToolDefinition where+ toJSON def = object+ [ "name" .= toolDefinitionName def+ , "description" .= toolDefinitionDescription def+ , "inputSchema" .= toolDefinitionInputSchema def+ ]++-- | Argument definition for prompts+data ArgumentDefinition = ArgumentDefinition+ { argumentDefinitionName :: Text+ , argumentDefinitionDescription :: Text+ , argumentDefinitionRequired :: Bool+ } deriving (Show, Eq, Generic)++instance ToJSON ArgumentDefinition where+ toJSON def = object+ [ "name" .= argumentDefinitionName def+ , "description" .= argumentDefinitionDescription def+ , "required" .= argumentDefinitionRequired def+ ]++-- | Input schema definition for tools+data InputSchemaDefinition = InputSchemaDefinitionObject+ { properties :: [(Text, InputSchemaDefinitionProperty)]+ , required :: [Text]+ } deriving (Show, Eq, Generic)++instance ToJSON InputSchemaDefinition where+ toJSON (InputSchemaDefinitionObject props req) = object+ [ "type" .= ("object" :: Text)+ , "properties" .= object (map (\(k, v) -> fromText k .= v) props)+ , "required" .= req+ ]++data InputSchemaDefinitionProperty = InputSchemaDefinitionProperty+ { propertyType :: Text+ , propertyDescription :: Text+ } deriving (Show, Eq, Generic)++instance ToJSON InputSchemaDefinitionProperty where+ toJSON prop = object+ [ "type" .= propertyType prop+ , "description" .= propertyDescription prop+ ]++-- | Server information+data McpServerInfo = McpServerInfo+ { serverName :: Text+ , serverVersion :: Text+ , serverInstructions :: Text+ } deriving (Show, Eq, Generic)++-- | Individual capability objects+data PromptCapabilities = PromptCapabilities+ { promptListChanged :: Maybe Bool+ } deriving (Show, Eq, Generic)++instance ToJSON PromptCapabilities where+ toJSON caps = object $ catMaybes+ [ fmap ("listChanged" .=) (promptListChanged caps)+ ]++data ResourceCapabilities = ResourceCapabilities+ { resourceSubscribe :: Maybe Bool+ , resourceListChanged :: Maybe Bool+ } deriving (Show, Eq, Generic)++instance ToJSON ResourceCapabilities where+ toJSON caps = object $ catMaybes+ [ fmap ("subscribe" .=) (resourceSubscribe caps)+ , fmap ("listChanged" .=) (resourceListChanged caps)+ ]++data ToolCapabilities = ToolCapabilities+ { toolListChanged :: Maybe Bool+ } deriving (Show, Eq, Generic)++instance ToJSON ToolCapabilities where+ toJSON caps = object $ catMaybes+ [ fmap ("listChanged" .=) (toolListChanged caps)+ ]++data LoggingCapabilities = LoggingCapabilities+ { -- No specific sub-capabilities for logging yet+ } deriving (Show, Eq, Generic)++instance ToJSON LoggingCapabilities where+ toJSON _ = object []++-- | Server capabilities+data ServerCapabilities = ServerCapabilities+ { capabilityPrompts :: Maybe PromptCapabilities+ , capabilityResources :: Maybe ResourceCapabilities+ , capabilityTools :: Maybe ToolCapabilities+ , capabilityLogging :: Maybe LoggingCapabilities+ } deriving (Show, Eq, Generic)++instance ToJSON ServerCapabilities where+ toJSON caps = object $ catMaybes+ [ fmap ("prompts" .=) (capabilityPrompts caps)+ , fmap ("resources" .=) (capabilityResources caps)+ , fmap ("tools" .=) (capabilityTools caps)+ , fmap ("logging" .=) (capabilityLogging caps)+ ]++-- | Cursor for pagination+newtype Cursor = Cursor Text+ deriving (Show, Eq, Generic)++instance ToJSON Cursor where+ toJSON (Cursor c) = toJSON c++instance FromJSON Cursor where+ parseJSON = fmap Cursor . parseJSON++-- | Pagination result wrapper+data PaginatedResult a = PaginatedResult+ { paginatedItems :: a+ , paginatedNextCursor :: Maybe Cursor+ } deriving (Show, Eq, Generic)++-- | Handler type definitions+type PromptListHandler m = Maybe Cursor -> m (PaginatedResult [PromptDefinition])+type PromptGetHandler m = PromptName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)++type ResourceListHandler m = Maybe Cursor -> m (PaginatedResult [ResourceDefinition])+type ResourceReadHandler m = URI -> m (Either Error Content)++type ToolListHandler m = Maybe Cursor -> m (PaginatedResult [ToolDefinition])+type ToolCallHandler m = ToolName -> [(ArgumentName, ArgumentValue)] -> m (Either Error Content)++-- | Server handlers+data McpServerHandlers m = McpServerHandlers+ { prompts :: Maybe (PromptListHandler m, PromptGetHandler m)+ , resources :: Maybe (ResourceListHandler m, ResourceReadHandler m)+ , tools :: Maybe (ToolListHandler m, ToolCallHandler m)+ }
+ test/Main.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."