mcp (empty) → 0.1.0.0
raw patch · 8 files changed
+2436/−0 lines, 8 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, bytestring, containers, mcp, mtl, scientific, stm, text, time, transformers, unordered-containers
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- app/Main.hs +111/−0
- mcp.cabal +151/−0
- src/MCP/Protocol.hs +1157/−0
- src/MCP/Server.hs +374/−0
- src/MCP/Types.hs +614/−0
- test/Main.hs +4/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for mcp++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2025 Matthias Pall Gissurarson++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ app/Main.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Control.Monad.IO.Class (liftIO)+import Data.Text qualified as T+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)+import System.IO (stdin, stdout)++import MCP.Protocol+import MCP.Server+import MCP.Types++-- | Minimal MCP Server implementation+instance MCPServer MCPServerM where+ handleListResources _params = do+ return $ ListResourcesResult{resources = [], nextCursor = Nothing, _meta = Nothing}++ handleReadResource _params = do+ let textContent = TextResourceContents{uri = "example://hello", text = "Hello from MCP Haskell server!", mimeType = Just "text/plain"}+ let content = TextResource textContent+ return $ ReadResourceResult{contents = [content], _meta = Nothing}++ handleListResourceTemplates _params = do+ return $ ListResourceTemplatesResult{resourceTemplates = [], nextCursor = Nothing, _meta = Nothing}++ handleListPrompts _params = do+ return $ ListPromptsResult{prompts = [], nextCursor = Nothing, _meta = Nothing}++ handleGetPrompt _params = do+ let textContent = TextContent{text = "Hello prompt!", textType = "text", annotations = Nothing}+ let content = TextContentType textContent+ let message = PromptMessage{role = User, content = content}+ return $ GetPromptResult{messages = [message], description = Nothing, _meta = Nothing}++ handleListTools _params = do+ let getCurrentDateTool =+ Tool+ { name = "getCurrentDate"+ , description = Just "Get the current date and time"+ , inputSchema = InputSchema "object" Nothing Nothing+ , annotations = Nothing+ }+ return $ ListToolsResult{tools = [getCurrentDateTool], nextCursor = Nothing, _meta = Nothing}++ handleCallTool CallToolParams{name = toolName} = do+ case toolName of+ "getCurrentDate" -> do+ currentTime <- liftIO getCurrentTime+ let dateStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" currentTime+ let textContent = TextContent{text = T.pack dateStr, textType = "text", annotations = Nothing}+ let content = TextContentType textContent+ return $ CallToolResult{content = [content], isError = Nothing, _meta = Nothing}+ _ -> do+ let textContent = TextContent{text = "Tool not found", textType = "text", annotations = Nothing}+ let content = TextContentType textContent+ return $ CallToolResult{content = [content], isError = Just True, _meta = Nothing}++ handleComplete _params = do+ let completionResult = CompletionResult{values = [], total = Nothing, hasMore = Just True}+ return $ CompleteResult{completion = completionResult, _meta = Nothing}++ handleSetLevel _params = do+ liftIO $ putStrLn "Log level set"++main :: IO ()+main = do+ putStrLn "Starting MCP Haskell Server..."++ let serverInfo =+ Implementation+ { name = "mcp-haskell-example"+ , version = "0.1.0"+ }++ let resourcesCap =+ ResourcesCapability+ { subscribe = Just False+ , listChanged = Just False+ }+ let promptsCap =+ PromptsCapability+ { listChanged = Just False+ }+ let toolsCap =+ ToolsCapability+ { listChanged = Just False+ }++ let capabilities =+ ServerCapabilities+ { resources = Just resourcesCap+ , prompts = Just promptsCap+ , tools = Just toolsCap+ , completions = Nothing+ , logging = Nothing+ , experimental = Nothing+ }++ let config =+ ServerConfig+ { configInput = stdin+ , configOutput = stdout+ , configServerInfo = serverInfo+ , configCapabilities = capabilities+ }++ putStrLn "Server configured, starting message loop..."+ runServer config
+ mcp.cabal view
@@ -0,0 +1,151 @@+cabal-version: 3.4+-- 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.++-- Initial package description 'mcp' generated by+-- 'cabal init'. For further documentation, see:+-- http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name: mcp++-- 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: A Haskell implementation of the Model Context Protocol (MCP)++-- A longer description of the package.+description: + This library provides a complete implementation of the Model Context Protocol (MCP)+ for Haskell. MCP is a protocol that enables seamless communication between AI models+ and external tools, resources, and services. This implementation includes support for+ resources, tools, prompts, and all standard MCP message types. It provides both a+ server framework and type definitions for building MCP-compliant applications.++-- The license under which the package is released.+license: MIT++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Matthias Pall Gissurarson++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: mpg@mpg.is++-- A copyright notice.+-- copyright:+category: Network+build-type: Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files: CHANGELOG.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++common warnings+ ghc-options: -Wall++library+ -- Import common warning flags.+ import: warnings++ -- Modules exported by the library.+ exposed-modules: + MCP.Types+ MCP.Protocol + MCP.Server++ -- 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: + base ^>=4.18.2.1,+ aeson >= 2.1 && < 2.3,+ text >= 2.0 && < 2.1,+ containers >= 0.6 && < 0.7,+ bytestring >= 0.11 && < 0.12,+ unordered-containers >= 0.2 && < 0.3,+ stm >= 2.5 && < 2.6,+ async >= 2.2 && < 2.3,+ mtl >= 2.3 && < 2.4,+ transformers >= 0.6 && < 0.7++ -- Directories containing source files.+ hs-source-dirs: src++ -- Base language which the package is written in.+ default-language: GHC2021++executable mcp+ -- 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.18.2.1,+ mcp,+ aeson >= 2.1 && < 2.3,+ text >= 2.0 && < 2.1,+ containers >= 0.6 && < 0.7,+ scientific >= 0.3 && < 0.4,+ time >= 1.12 && < 1.13++ -- Directories containing source files.+ hs-source-dirs: app++ -- Base language which the package is written in.+ default-language: GHC2021++test-suite mcp-test+ -- Import common warning flags.+ import: warnings++ -- Base language which the package is written in.+ default-language: GHC2021++ -- 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.18.2.1,+ mcp
+ src/MCP/Protocol.hs view
@@ -0,0 +1,1157 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : MCP.Protocol+-- Description : JSON-RPC protocol implementation for MCP+-- Copyright : (C) 2025 Matthias Pall Gissurarson+-- License : MIT+-- Maintainer : mpg@mpg.is+-- Stability : experimental+-- Portability : GHC+--+-- This module implements the JSON-RPC 2.0 protocol layer for MCP,+-- including request/response handling, message parsing and encoding,+-- and protocol-level error handling.+module MCP.Protocol (+ -- * JSON-RPC Types+ JSONRPCRequest (..),+ JSONRPCResponse (..),+ JSONRPCError (..),+ JSONRPCNotification (..),+ JSONRPCMessage (..),+ JSONRPCErrorInfo (..),++ -- * Client Request Types+ InitializeRequest (..),+ InitializeParams (..),+ PingRequest (..),+ PingParams (..),+ ListResourcesRequest (..),+ ListResourcesParams (..),+ ListResourceTemplatesRequest (..),+ ListResourceTemplatesParams (..),+ ReadResourceRequest (..),+ ReadResourceParams (..),+ SubscribeRequest (..),+ SubscribeParams (..),+ UnsubscribeRequest (..),+ UnsubscribeParams (..),+ ListPromptsRequest (..),+ ListPromptsParams (..),+ GetPromptRequest (..),+ GetPromptParams (..),+ ListToolsRequest (..),+ ListToolsParams (..),+ CallToolRequest (..),+ CallToolParams (..),+ SetLevelRequest (..),+ SetLevelParams (..),+ CompleteRequest (..),+ CompleteParams (..),+ CompletionArgument (..),+ Reference (..),++ -- * Server Request Types+ CreateMessageRequest (..),+ CreateMessageParams (..),+ ListRootsRequest (..),+ ListRootsParams (..),++ -- * Response Types+ InitializeResult (..),+ ListResourcesResult (..),+ ListResourceTemplatesResult (..),+ ReadResourceResult (..),+ ListPromptsResult (..),+ GetPromptResult (..),+ ListToolsResult (..),+ CallToolResult (..),+ CompleteResult (..),+ CompletionResult (..),+ CreateMessageResult (..),+ ListRootsResult (..),++ -- * Notification Types+ CancelledNotification (..),+ CancelledParams (..),+ InitializedNotification (..),+ InitializedParams (..),+ ProgressNotification (..),+ ProgressParams (..),+ ResourceListChangedNotification (..),+ ResourceUpdatedNotification (..),+ ResourceUpdatedParams (..),+ PromptListChangedNotification (..),+ ToolListChangedNotification (..),+ LoggingMessageNotification (..),+ LoggingMessageParams (..),+ RootsListChangedNotification (..),++ -- * Union Types+ ClientRequest (..),+ ServerRequest (..),+ ClientNotification (..),+ ServerNotification (..),+) where++import Control.Applicative ((<|>))+import Data.Aeson+import Data.Aeson.TH+import Data.Map (Map)+import Data.Text (Text)+import GHC.Generics++import MCP.Types++-- * JSON-RPC Types++-- | JSON-RPC error information+data JSONRPCErrorInfo = JSONRPCErrorInfo+ { code :: Int+ , message :: Text+ , errorData :: Maybe Value+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON JSONRPCErrorInfo where+ toJSON (JSONRPCErrorInfo c m d) =+ object $+ [ "code" .= c+ , "message" .= m+ ]+ ++ maybe [] (\ed -> ["data" .= ed]) d++instance FromJSON JSONRPCErrorInfo where+ parseJSON = withObject "JSONRPCErrorInfo" $ \o ->+ JSONRPCErrorInfo <$> o .: "code" <*> o .: "message" <*> o .:? "data"++-- | A JSON-RPC request that expects a response+data JSONRPCRequest = JSONRPCRequest+ { jsonrpc :: Text -- Always "2.0"+ , id :: RequestId+ , method :: Text+ , params :: Maybe Value+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''JSONRPCRequest)++-- | A successful JSON-RPC response+data JSONRPCResponse = JSONRPCResponse+ { jsonrpc :: Text -- Always "2.0"+ , id :: RequestId+ , result :: Value+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''JSONRPCResponse)++-- | A JSON-RPC error response+data JSONRPCError = JSONRPCError+ { jsonrpc :: Text -- Always "2.0"+ , id :: RequestId+ , error :: JSONRPCErrorInfo+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''JSONRPCError)++-- | A JSON-RPC notification (no response expected)+data JSONRPCNotification = JSONRPCNotification+ { jsonrpc :: Text -- Always "2.0"+ , method :: Text+ , params :: Maybe Value+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''JSONRPCNotification)++-- | Any JSON-RPC message+data JSONRPCMessage+ = RequestMessage JSONRPCRequest+ | ResponseMessage JSONRPCResponse+ | ErrorMessage JSONRPCError+ | NotificationMessage JSONRPCNotification+ deriving stock (Show, Eq, Generic)++instance ToJSON JSONRPCMessage where+ toJSON (RequestMessage r) = toJSON r+ toJSON (ResponseMessage r) = toJSON r+ toJSON (ErrorMessage e) = toJSON e+ toJSON (NotificationMessage n) = toJSON n++instance FromJSON JSONRPCMessage where+ parseJSON v =+ (RequestMessage <$> parseJSON v)+ <|> (ResponseMessage <$> parseJSON v)+ <|> (ErrorMessage <$> parseJSON v)+ <|> (NotificationMessage <$> parseJSON v)++-- * Client Request Types++-- | Initialize request parameters+data InitializeParams = InitializeParams+ { protocolVersion :: Text+ , capabilities :: ClientCapabilities+ , clientInfo :: Implementation+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''InitializeParams)++-- | Initialize request+data InitializeRequest = InitializeRequest+ { method :: Text -- Always "initialize"+ , params :: InitializeParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON InitializeRequest where+ toJSON (InitializeRequest _ p) =+ object+ [ "method" .= ("initialize" :: Text)+ , "params" .= p+ ]++instance FromJSON InitializeRequest where+ parseJSON = withObject "InitializeRequest" $ \o -> do+ m <- o .: "method"+ if m == ("initialize" :: Text)+ then InitializeRequest m <$> o .: "params"+ else fail "Expected method 'initialize'"++-- | Ping request parameters+data PingParams = PingParams+ { _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''PingParams)++-- | Ping request+data PingRequest = PingRequest+ { method :: Text -- Always "ping"+ , params :: Maybe PingParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON PingRequest where+ toJSON (PingRequest _ p) =+ object $+ [ "method" .= ("ping" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON PingRequest where+ parseJSON = withObject "PingRequest" $ \o -> do+ m <- o .: "method"+ if m == ("ping" :: Text)+ then PingRequest m <$> o .:? "params"+ else fail "Expected method 'ping'"++-- | List resources request parameters+data ListResourcesParams = ListResourcesParams+ { cursor :: Maybe Cursor+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ListResourcesParams)++-- | List resources request+data ListResourcesRequest = ListResourcesRequest+ { method :: Text -- Always "resources/list"+ , params :: Maybe ListResourcesParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ListResourcesRequest where+ toJSON (ListResourcesRequest _ p) =+ object $+ [ "method" .= ("resources/list" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON ListResourcesRequest where+ parseJSON = withObject "ListResourcesRequest" $ \o -> do+ m <- o .: "method"+ if m == ("resources/list" :: Text)+ then ListResourcesRequest m <$> o .:? "params"+ else fail "Expected method 'resources/list'"++-- | List resource templates request parameters+data ListResourceTemplatesParams = ListResourceTemplatesParams+ { cursor :: Maybe Cursor+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ListResourceTemplatesParams)++-- | List resource templates request+data ListResourceTemplatesRequest = ListResourceTemplatesRequest+ { method :: Text -- Always "resources/templates/list"+ , params :: Maybe ListResourceTemplatesParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ListResourceTemplatesRequest where+ toJSON (ListResourceTemplatesRequest _ p) =+ object $+ [ "method" .= ("resources/templates/list" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON ListResourceTemplatesRequest where+ parseJSON = withObject "ListResourceTemplatesRequest" $ \o -> do+ m <- o .: "method"+ if m == ("resources/templates/list" :: Text)+ then ListResourceTemplatesRequest m <$> o .:? "params"+ else fail "Expected method 'resources/templates/list'"++-- | Read resource request parameters+data ReadResourceParams = ReadResourceParams+ { uri :: Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''ReadResourceParams)++-- | Read resource request+data ReadResourceRequest = ReadResourceRequest+ { method :: Text -- Always "resources/read"+ , params :: ReadResourceParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ReadResourceRequest where+ toJSON (ReadResourceRequest _ p) =+ object+ [ "method" .= ("resources/read" :: Text)+ , "params" .= p+ ]++instance FromJSON ReadResourceRequest where+ parseJSON = withObject "ReadResourceRequest" $ \o -> do+ m <- o .: "method"+ if m == ("resources/read" :: Text)+ then ReadResourceRequest m <$> o .: "params"+ else fail "Expected method 'resources/read'"++-- | Subscribe request parameters+data SubscribeParams = SubscribeParams+ { uri :: Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''SubscribeParams)++-- | Subscribe request+data SubscribeRequest = SubscribeRequest+ { method :: Text -- Always "resources/subscribe"+ , params :: SubscribeParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON SubscribeRequest where+ toJSON (SubscribeRequest _ p) =+ object+ [ "method" .= ("resources/subscribe" :: Text)+ , "params" .= p+ ]++instance FromJSON SubscribeRequest where+ parseJSON = withObject "SubscribeRequest" $ \o -> do+ m <- o .: "method"+ if m == ("resources/subscribe" :: Text)+ then SubscribeRequest m <$> o .: "params"+ else fail "Expected method 'resources/subscribe'"++-- | Unsubscribe request parameters+data UnsubscribeParams = UnsubscribeParams+ { uri :: Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''UnsubscribeParams)++-- | Unsubscribe request+data UnsubscribeRequest = UnsubscribeRequest+ { method :: Text -- Always "resources/unsubscribe"+ , params :: UnsubscribeParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON UnsubscribeRequest where+ toJSON (UnsubscribeRequest _ p) =+ object+ [ "method" .= ("resources/unsubscribe" :: Text)+ , "params" .= p+ ]++instance FromJSON UnsubscribeRequest where+ parseJSON = withObject "UnsubscribeRequest" $ \o -> do+ m <- o .: "method"+ if m == ("resources/unsubscribe" :: Text)+ then UnsubscribeRequest m <$> o .: "params"+ else fail "Expected method 'resources/unsubscribe'"++-- | List prompts request parameters+data ListPromptsParams = ListPromptsParams+ { cursor :: Maybe Cursor+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ListPromptsParams)++-- | List prompts request+data ListPromptsRequest = ListPromptsRequest+ { method :: Text -- Always "prompts/list"+ , params :: Maybe ListPromptsParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ListPromptsRequest where+ toJSON (ListPromptsRequest _ p) =+ object $+ [ "method" .= ("prompts/list" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON ListPromptsRequest where+ parseJSON = withObject "ListPromptsRequest" $ \o -> do+ m <- o .: "method"+ if m == ("prompts/list" :: Text)+ then ListPromptsRequest m <$> o .:? "params"+ else fail "Expected method 'prompts/list'"++-- | Get prompt request parameters+data GetPromptParams = GetPromptParams+ { name :: Text+ , arguments :: Maybe (Map Text Text)+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''GetPromptParams)++-- | Get prompt request+data GetPromptRequest = GetPromptRequest+ { method :: Text -- Always "prompts/get"+ , params :: GetPromptParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON GetPromptRequest where+ toJSON (GetPromptRequest _ p) =+ object+ [ "method" .= ("prompts/get" :: Text)+ , "params" .= p+ ]++instance FromJSON GetPromptRequest where+ parseJSON = withObject "GetPromptRequest" $ \o -> do+ m <- o .: "method"+ if m == ("prompts/get" :: Text)+ then GetPromptRequest m <$> o .: "params"+ else fail "Expected method 'prompts/get'"++-- | List tools request parameters+data ListToolsParams = ListToolsParams+ { cursor :: Maybe Cursor+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ListToolsParams)++-- | List tools request+data ListToolsRequest = ListToolsRequest+ { method :: Text -- Always "tools/list"+ , params :: Maybe ListToolsParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ListToolsRequest where+ toJSON (ListToolsRequest _ p) =+ object $+ [ "method" .= ("tools/list" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON ListToolsRequest where+ parseJSON = withObject "ListToolsRequest" $ \o -> do+ m <- o .: "method"+ if m == ("tools/list" :: Text)+ then ListToolsRequest m <$> o .:? "params"+ else fail "Expected method 'tools/list'"++-- | Call tool request parameters+data CallToolParams = CallToolParams+ { name :: Text+ , arguments :: Maybe (Map Text Value)+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''CallToolParams)++-- | Call tool request+data CallToolRequest = CallToolRequest+ { method :: Text -- Always "tools/call"+ , params :: CallToolParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON CallToolRequest where+ toJSON (CallToolRequest _ p) =+ object+ [ "method" .= ("tools/call" :: Text)+ , "params" .= p+ ]++instance FromJSON CallToolRequest where+ parseJSON = withObject "CallToolRequest" $ \o -> do+ m <- o .: "method"+ if m == ("tools/call" :: Text)+ then CallToolRequest m <$> o .: "params"+ else fail "Expected method 'tools/call'"++-- | Set level request parameters+data SetLevelParams = SetLevelParams+ { level :: LoggingLevel+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''SetLevelParams)++-- | Set level request+data SetLevelRequest = SetLevelRequest+ { method :: Text -- Always "logging/setLevel"+ , params :: SetLevelParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON SetLevelRequest where+ toJSON (SetLevelRequest _ p) =+ object+ [ "method" .= ("logging/setLevel" :: Text)+ , "params" .= p+ ]++instance FromJSON SetLevelRequest where+ parseJSON = withObject "SetLevelRequest" $ \o -> do+ m <- o .: "method"+ if m == ("logging/setLevel" :: Text)+ then SetLevelRequest m <$> o .: "params"+ else fail "Expected method 'logging/setLevel'"++-- | Completion argument+data CompletionArgument = CompletionArgument+ { name :: Text+ , value :: Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''CompletionArgument)++-- | Reference (prompt or resource)+data Reference+ = PromptRef PromptReference+ | ResourceRef ResourceReference+ deriving stock (Show, Eq, Generic)++instance ToJSON Reference where+ toJSON (PromptRef p) = toJSON p+ toJSON (ResourceRef r) = toJSON r++instance FromJSON Reference where+ parseJSON v =+ (PromptRef <$> parseJSON v)+ <|> (ResourceRef <$> parseJSON v)++-- | Complete request parameters+data CompleteParams = CompleteParams+ { ref :: Reference+ , argument :: CompletionArgument+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''CompleteParams)++-- | Complete request+data CompleteRequest = CompleteRequest+ { method :: Text -- Always "completion/complete"+ , params :: CompleteParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON CompleteRequest where+ toJSON (CompleteRequest _ p) =+ object+ [ "method" .= ("completion/complete" :: Text)+ , "params" .= p+ ]++instance FromJSON CompleteRequest where+ parseJSON = withObject "CompleteRequest" $ \o -> do+ m <- o .: "method"+ if m == ("completion/complete" :: Text)+ then CompleteRequest m <$> o .: "params"+ else fail "Expected method 'completion/complete'"++-- * Server Request Types++-- | Create message request parameters+data CreateMessageParams = CreateMessageParams+ { maxTokens :: Int+ , messages :: [SamplingMessage]+ , modelPreferences :: Maybe ModelPreferences+ , systemPrompt :: Maybe Text+ , includeContext :: Maybe IncludeContext+ , temperature :: Maybe Double+ , stopSequences :: Maybe [Text]+ , metadata :: Maybe (Map Text Value)+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''CreateMessageParams)++-- | Create message request+data CreateMessageRequest = CreateMessageRequest+ { method :: Text -- Always "sampling/createMessage"+ , params :: CreateMessageParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON CreateMessageRequest where+ toJSON (CreateMessageRequest _ p) =+ object+ [ "method" .= ("sampling/createMessage" :: Text)+ , "params" .= p+ ]++instance FromJSON CreateMessageRequest where+ parseJSON = withObject "CreateMessageRequest" $ \o -> do+ m <- o .: "method"+ if m == ("sampling/createMessage" :: Text)+ then CreateMessageRequest m <$> o .: "params"+ else fail "Expected method 'sampling/createMessage'"++-- | List roots request parameters+data ListRootsParams = ListRootsParams+ { _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListRootsParams)++-- | List roots request+data ListRootsRequest = ListRootsRequest+ { method :: Text -- Always "roots/list"+ , params :: Maybe ListRootsParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ListRootsRequest where+ toJSON (ListRootsRequest _ p) =+ object $+ [ "method" .= ("roots/list" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON ListRootsRequest where+ parseJSON = withObject "ListRootsRequest" $ \o -> do+ m <- o .: "method"+ if m == ("roots/list" :: Text)+ then ListRootsRequest m <$> o .:? "params"+ else fail "Expected method 'roots/list'"++-- * Response Types++-- | Initialize result+data InitializeResult = InitializeResult+ { protocolVersion :: Text+ , capabilities :: ServerCapabilities+ , serverInfo :: Implementation+ , instructions :: Maybe Text+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''InitializeResult)++-- | List resources result+data ListResourcesResult = ListResourcesResult+ { resources :: [Resource]+ , nextCursor :: Maybe Cursor+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListResourcesResult)++-- | List resource templates result+data ListResourceTemplatesResult = ListResourceTemplatesResult+ { resourceTemplates :: [ResourceTemplate]+ , nextCursor :: Maybe Cursor+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListResourceTemplatesResult)++-- | Read resource result+data ReadResourceResult = ReadResourceResult+ { contents :: [ResourceContents]+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ReadResourceResult)++-- | List prompts result+data ListPromptsResult = ListPromptsResult+ { prompts :: [Prompt]+ , nextCursor :: Maybe Cursor+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListPromptsResult)++-- | Get prompt result+data GetPromptResult = GetPromptResult+ { description :: Maybe Text+ , messages :: [PromptMessage]+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''GetPromptResult)++-- | List tools result+data ListToolsResult = ListToolsResult+ { tools :: [Tool]+ , nextCursor :: Maybe Cursor+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListToolsResult)++-- | Call tool result+data CallToolResult = CallToolResult+ { content :: [Content]+ , isError :: Maybe Bool+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''CallToolResult)++-- | Completion result inner type+data CompletionResult = CompletionResult+ { values :: [Text]+ , total :: Maybe Int+ , hasMore :: Maybe Bool+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''CompletionResult)++-- | Complete result+data CompleteResult = CompleteResult+ { completion :: CompletionResult+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''CompleteResult)++-- | Create message result+data CreateMessageResult = CreateMessageResult+ { role :: Role+ , content :: Content+ , model :: Text+ , stopReason :: Maybe Text+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''CreateMessageResult)++-- | List roots result+data ListRootsResult = ListRootsResult+ { roots :: [Root]+ , _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''ListRootsResult)++-- * Notification Types++-- | Cancelled notification parameters+data CancelledParams = CancelledParams+ { requestId :: RequestId+ , reason :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''CancelledParams)++-- | Cancelled notification+data CancelledNotification = CancelledNotification+ { method :: Text -- Always "notifications/cancelled"+ , params :: CancelledParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON CancelledNotification where+ toJSON (CancelledNotification _ p) =+ object+ [ "method" .= ("notifications/cancelled" :: Text)+ , "params" .= p+ ]++instance FromJSON CancelledNotification where+ parseJSON = withObject "CancelledNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/cancelled" :: Text)+ then CancelledNotification m <$> o .: "params"+ else fail "Expected method 'notifications/cancelled'"++-- | Initialized notification parameters+data InitializedParams = InitializedParams+ { _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''InitializedParams)++-- | Initialized notification+data InitializedNotification = InitializedNotification+ { method :: Text -- Always "notifications/initialized"+ , params :: Maybe InitializedParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON InitializedNotification where+ toJSON (InitializedNotification _ p) =+ object $+ [ "method" .= ("notifications/initialized" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON InitializedNotification where+ parseJSON = withObject "InitializedNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/initialized" :: Text)+ then InitializedNotification m <$> o .:? "params"+ else fail "Expected method 'notifications/initialized'"++-- | Progress notification parameters+data ProgressParams = ProgressParams+ { progressToken :: ProgressToken+ , progress :: Double+ , total :: Maybe Double+ , message :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ProgressParams)++-- | Progress notification+data ProgressNotification = ProgressNotification+ { method :: Text -- Always "notifications/progress"+ , params :: ProgressParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ProgressNotification where+ toJSON (ProgressNotification _ p) =+ object+ [ "method" .= ("notifications/progress" :: Text)+ , "params" .= p+ ]++instance FromJSON ProgressNotification where+ parseJSON = withObject "ProgressNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/progress" :: Text)+ then ProgressNotification m <$> o .: "params"+ else fail "Expected method 'notifications/progress'"++-- | Resource list changed notification+data ResourceListChangedNotification = ResourceListChangedNotification+ { method :: Text -- Always "notifications/resources/list_changed"+ , params :: Maybe InitializedParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ResourceListChangedNotification where+ toJSON (ResourceListChangedNotification _ p) =+ object $+ [ "method" .= ("notifications/resources/list_changed" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON ResourceListChangedNotification where+ parseJSON = withObject "ResourceListChangedNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/resources/list_changed" :: Text)+ then ResourceListChangedNotification m <$> o .:? "params"+ else fail "Expected method 'notifications/resources/list_changed'"++-- | Resource updated notification parameters+data ResourceUpdatedParams = ResourceUpdatedParams+ { uri :: Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''ResourceUpdatedParams)++-- | Resource updated notification+data ResourceUpdatedNotification = ResourceUpdatedNotification+ { method :: Text -- Always "notifications/resources/updated"+ , params :: ResourceUpdatedParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ResourceUpdatedNotification where+ toJSON (ResourceUpdatedNotification _ p) =+ object+ [ "method" .= ("notifications/resources/updated" :: Text)+ , "params" .= p+ ]++instance FromJSON ResourceUpdatedNotification where+ parseJSON = withObject "ResourceUpdatedNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/resources/updated" :: Text)+ then ResourceUpdatedNotification m <$> o .: "params"+ else fail "Expected method 'notifications/resources/updated'"++-- | Prompt list changed notification+data PromptListChangedNotification = PromptListChangedNotification+ { method :: Text -- Always "notifications/prompts/list_changed"+ , params :: Maybe InitializedParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON PromptListChangedNotification where+ toJSON (PromptListChangedNotification _ p) =+ object $+ [ "method" .= ("notifications/prompts/list_changed" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON PromptListChangedNotification where+ parseJSON = withObject "PromptListChangedNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/prompts/list_changed" :: Text)+ then PromptListChangedNotification m <$> o .:? "params"+ else fail "Expected method 'notifications/prompts/list_changed'"++-- | Tool list changed notification+data ToolListChangedNotification = ToolListChangedNotification+ { method :: Text -- Always "notifications/tools/list_changed"+ , params :: Maybe InitializedParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ToolListChangedNotification where+ toJSON (ToolListChangedNotification _ p) =+ object $+ [ "method" .= ("notifications/tools/list_changed" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON ToolListChangedNotification where+ parseJSON = withObject "ToolListChangedNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/tools/list_changed" :: Text)+ then ToolListChangedNotification m <$> o .:? "params"+ else fail "Expected method 'notifications/tools/list_changed'"++-- | Logging message notification parameters+data LoggingMessageParams = LoggingMessageParams+ { level :: LoggingLevel+ , data' :: Value -- Can be any JSON value+ , logger :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON LoggingMessageParams where+ toJSON (LoggingMessageParams lvl d lgr) =+ object $+ [ "level" .= lvl+ , "data" .= d+ ]+ ++ maybe [] (\l -> ["logger" .= l]) lgr++instance FromJSON LoggingMessageParams where+ parseJSON = withObject "LoggingMessageParams" $ \o ->+ LoggingMessageParams <$> o .: "level" <*> o .: "data" <*> o .:? "logger"++-- | Logging message notification+data LoggingMessageNotification = LoggingMessageNotification+ { method :: Text -- Always "notifications/message"+ , params :: LoggingMessageParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON LoggingMessageNotification where+ toJSON (LoggingMessageNotification _ p) =+ object+ [ "method" .= ("notifications/message" :: Text)+ , "params" .= p+ ]++instance FromJSON LoggingMessageNotification where+ parseJSON = withObject "LoggingMessageNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/message" :: Text)+ then LoggingMessageNotification m <$> o .: "params"+ else fail "Expected method 'notifications/message'"++-- | Roots list changed notification+data RootsListChangedNotification = RootsListChangedNotification+ { method :: Text -- Always "notifications/roots/list_changed"+ , params :: Maybe InitializedParams+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON RootsListChangedNotification where+ toJSON (RootsListChangedNotification _ p) =+ object $+ [ "method" .= ("notifications/roots/list_changed" :: Text)+ ]+ ++ maybe [] (\pr -> ["params" .= pr]) p++instance FromJSON RootsListChangedNotification where+ parseJSON = withObject "RootsListChangedNotification" $ \o -> do+ m <- o .: "method"+ if m == ("notifications/roots/list_changed" :: Text)+ then RootsListChangedNotification m <$> o .:? "params"+ else fail "Expected method 'notifications/roots/list_changed'"++-- * Union Types++-- | Any client request+data ClientRequest+ = InitializeReq InitializeRequest+ | PingReq PingRequest+ | ListResourcesReq ListResourcesRequest+ | ListResourceTemplatesReq ListResourceTemplatesRequest+ | ReadResourceReq ReadResourceRequest+ | SubscribeReq SubscribeRequest+ | UnsubscribeReq UnsubscribeRequest+ | ListPromptsReq ListPromptsRequest+ | GetPromptReq GetPromptRequest+ | ListToolsReq ListToolsRequest+ | CallToolReq CallToolRequest+ | SetLevelReq SetLevelRequest+ | CompleteReq CompleteRequest+ deriving stock (Show, Eq, Generic)++instance ToJSON ClientRequest where+ toJSON (InitializeReq r) = toJSON r+ toJSON (PingReq r) = toJSON r+ toJSON (ListResourcesReq r) = toJSON r+ toJSON (ListResourceTemplatesReq r) = toJSON r+ toJSON (ReadResourceReq r) = toJSON r+ toJSON (SubscribeReq r) = toJSON r+ toJSON (UnsubscribeReq r) = toJSON r+ toJSON (ListPromptsReq r) = toJSON r+ toJSON (GetPromptReq r) = toJSON r+ toJSON (ListToolsReq r) = toJSON r+ toJSON (CallToolReq r) = toJSON r+ toJSON (SetLevelReq r) = toJSON r+ toJSON (CompleteReq r) = toJSON r++instance FromJSON ClientRequest where+ parseJSON v =+ (InitializeReq <$> parseJSON v)+ <|> (PingReq <$> parseJSON v)+ <|> (ListResourcesReq <$> parseJSON v)+ <|> (ListResourceTemplatesReq <$> parseJSON v)+ <|> (ReadResourceReq <$> parseJSON v)+ <|> (SubscribeReq <$> parseJSON v)+ <|> (UnsubscribeReq <$> parseJSON v)+ <|> (ListPromptsReq <$> parseJSON v)+ <|> (GetPromptReq <$> parseJSON v)+ <|> (ListToolsReq <$> parseJSON v)+ <|> (CallToolReq <$> parseJSON v)+ <|> (SetLevelReq <$> parseJSON v)+ <|> (CompleteReq <$> parseJSON v)++-- | Any server request+data ServerRequest+ = PingServerReq PingRequest+ | CreateMessageReq CreateMessageRequest+ | ListRootsReq ListRootsRequest+ deriving stock (Show, Eq, Generic)++instance ToJSON ServerRequest where+ toJSON (PingServerReq r) = toJSON r+ toJSON (CreateMessageReq r) = toJSON r+ toJSON (ListRootsReq r) = toJSON r++instance FromJSON ServerRequest where+ parseJSON v =+ (PingServerReq <$> parseJSON v)+ <|> (CreateMessageReq <$> parseJSON v)+ <|> (ListRootsReq <$> parseJSON v)++-- | Any client notification+data ClientNotification+ = CancelledNotif CancelledNotification+ | InitializedNotif InitializedNotification+ | ProgressNotif ProgressNotification+ | RootsListChangedNotif RootsListChangedNotification+ deriving stock (Show, Eq, Generic)++instance ToJSON ClientNotification where+ toJSON (CancelledNotif n) = toJSON n+ toJSON (InitializedNotif n) = toJSON n+ toJSON (ProgressNotif n) = toJSON n+ toJSON (RootsListChangedNotif n) = toJSON n++instance FromJSON ClientNotification where+ parseJSON v =+ (CancelledNotif <$> parseJSON v)+ <|> (InitializedNotif <$> parseJSON v)+ <|> (ProgressNotif <$> parseJSON v)+ <|> (RootsListChangedNotif <$> parseJSON v)++-- | Any server notification+data ServerNotification+ = CancelledServerNotif CancelledNotification+ | ProgressServerNotif ProgressNotification+ | ResourceListChangedNotif ResourceListChangedNotification+ | ResourceUpdatedNotif ResourceUpdatedNotification+ | PromptListChangedNotif PromptListChangedNotification+ | ToolListChangedNotif ToolListChangedNotification+ | LoggingMessageNotif LoggingMessageNotification+ deriving stock (Show, Eq, Generic)++instance ToJSON ServerNotification where+ toJSON (CancelledServerNotif n) = toJSON n+ toJSON (ProgressServerNotif n) = toJSON n+ toJSON (ResourceListChangedNotif n) = toJSON n+ toJSON (ResourceUpdatedNotif n) = toJSON n+ toJSON (PromptListChangedNotif n) = toJSON n+ toJSON (ToolListChangedNotif n) = toJSON n+ toJSON (LoggingMessageNotif n) = toJSON n++instance FromJSON ServerNotification where+ parseJSON v =+ (CancelledServerNotif <$> parseJSON v)+ <|> (ProgressServerNotif <$> parseJSON v)+ <|> (ResourceListChangedNotif <$> parseJSON v)+ <|> (ResourceUpdatedNotif <$> parseJSON v)+ <|> (PromptListChangedNotif <$> parseJSON v)+ <|> (ToolListChangedNotif <$> parseJSON v)+ <|> (LoggingMessageNotif <$> parseJSON v)
+ src/MCP/Server.hs view
@@ -0,0 +1,374 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : MCP.Server+-- Description : MCP server implementation+-- Copyright : (C) 2025 Matthias Pall Gissurarson+-- License : MIT+-- Maintainer : mpg@mpg.is+-- Stability : experimental+-- Portability : GHC+--+-- This module provides a complete MCP server implementation, including+-- message handling, state management, and JSON-RPC communication over+-- standard input/output streams.+module MCP.Server (+ -- * Server Interface+ MCPServer (..),+ ServerState (..),+ MCPServerM,+ runMCPServer,++ -- * Message Handling+ handleMessage,+ handleRequest,+ handleNotification,++ -- * Server Runner+ runServer,+ ServerConfig (..),++ -- * Utilities+ sendResponse,+ sendNotification,+ sendError,+) where++import Control.Exception (catch, throwIO)+import Control.Monad.Except (ExceptT, runExceptT)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.State.Strict (StateT, get, put, runStateT)+import Data.Aeson (ToJSON, decode, encode, fromJSON, object, toJSON)+import Data.Aeson qualified as Aeson+import Data.ByteString.Char8 qualified as BSC+import Data.ByteString.Lazy qualified as LBS+import Data.ByteString.Lazy.Char8 qualified as LBSC+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import System.IO (Handle, hFlush)+import System.IO.Error (isEOFError)++import MCP.Protocol hiding (capabilities)+import MCP.Protocol qualified as Protocol+import MCP.Types++-- | Server state tracking initialization, capabilities, and subscriptions+data ServerState = ServerState+ { serverInitialized :: Bool+ , serverCapabilities :: ServerCapabilities+ , clientCapabilities :: Maybe ClientCapabilities+ , serverInfo :: Maybe Implementation+ , subscriptions :: Map Text ()+ }+ deriving (Show)++-- | Configuration for running an MCP server+data ServerConfig = ServerConfig+ { configInput :: Handle+ , configOutput :: Handle+ , configServerInfo :: Implementation+ , configCapabilities :: ServerCapabilities+ }+ deriving (Show)++-- | The monad stack for MCP server operations+type MCPServerM = ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))++-- | Run an MCPServerM computation with the given config and initial state+runMCPServer :: ServerConfig -> ServerState -> MCPServerM a -> IO (Either Text (a, ServerState))+runMCPServer config state action = runExceptT $ runStateT (runReaderT action config) state++initialServerState :: ServerCapabilities -> ServerState+initialServerState caps =+ ServerState+ { serverInitialized = False+ , serverCapabilities = caps+ , clientCapabilities = Nothing+ , serverInfo = Nothing+ , subscriptions = Map.empty+ }++-- | Type class for implementing MCP server handlers+class (Monad m) => MCPServer m where+ handleListResources :: ListResourcesParams -> m ListResourcesResult+ handleReadResource :: ReadResourceParams -> m ReadResourceResult+ handleListResourceTemplates :: ListResourceTemplatesParams -> m ListResourceTemplatesResult+ handleListPrompts :: ListPromptsParams -> m ListPromptsResult+ handleGetPrompt :: GetPromptParams -> m GetPromptResult+ handleListTools :: ListToolsParams -> m ListToolsResult+ handleCallTool :: CallToolParams -> m CallToolResult+ handleComplete :: CompleteParams -> m CompleteResult+ handleSetLevel :: SetLevelParams -> m ()++-- | Send a JSON-RPC response+sendResponse :: (MonadIO m, ToJSON a) => Handle -> RequestId -> a -> m ()+sendResponse handle reqId result = liftIO $ do+ let response = JSONRPCResponse "2.0" reqId (toJSON result)+ LBSC.hPutStrLn handle (encode response)+ hFlush handle++-- | Send a JSON-RPC error response+sendError :: (MonadIO m) => Handle -> RequestId -> JSONRPCErrorInfo -> m ()+sendError handle reqId errorInfo = liftIO $ do+ let response = JSONRPCError "2.0" reqId errorInfo+ LBSC.hPutStrLn handle (encode response)+ hFlush handle++-- | Send a JSON-RPC notification+sendNotification :: (MonadIO m, ToJSON a) => Handle -> Text -> a -> m ()+sendNotification handle method params = liftIO $ do+ let notification = JSONRPCNotification "2.0" method (Just (toJSON params))+ LBSC.hPutStrLn handle (encode notification)+ hFlush handle++-- | Handle an incoming JSON-RPC message+handleMessage :: (MCPServer MCPServerM) => BSC.ByteString -> MCPServerM (Maybe ())+handleMessage input = do+ case decode (LBS.fromStrict input) :: Maybe JSONRPCMessage of+ Nothing -> do+ config <- ask+ sendError (configOutput config) (RequestId (toJSON ("unknown" :: Text))) $+ JSONRPCErrorInfo (-32700) "Parse error" Nothing+ return Nothing+ Just msg -> case msg of+ RequestMessage req -> do+ handleRequest req+ return (Just ())+ NotificationMessage notif -> do+ handleNotification notif+ return (Just ())+ _ -> do+ config <- ask+ sendError (configOutput config) (RequestId (toJSON ("unknown" :: Text))) $+ JSONRPCErrorInfo (-32600) "Invalid Request" Nothing+ return Nothing++-- | Handle a JSON-RPC request+handleRequest :: (MCPServer MCPServerM) => JSONRPCRequest -> MCPServerM ()+handleRequest (JSONRPCRequest _ reqId method params) = do+ config <- ask+ state <- get++ case method of+ "initialize" -> case params of+ Just p -> case fromJSON p of+ Aeson.Success initParams -> handleInitialize reqId initParams+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) "Missing params" Nothing+ "ping" -> handlePing reqId+ "resources/list" -> do+ if not (serverInitialized state)+ then+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32002) "Server not initialized" Nothing+ else case params of+ Just p -> case fromJSON p of+ Aeson.Success listParams -> do+ result <- handleListResources listParams+ sendResponse (configOutput config) reqId result+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing -> do+ result <- handleListResources (ListResourcesParams Nothing)+ sendResponse (configOutput config) reqId result+ "resources/read" -> do+ if not (serverInitialized state)+ then+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32002) "Server not initialized" Nothing+ else case params of+ Just p -> case fromJSON p of+ Aeson.Success readParams -> do+ result <- handleReadResource readParams+ sendResponse (configOutput config) reqId result+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) "Missing params" Nothing+ "resources/templates/list" -> do+ if not (serverInitialized state)+ then+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32002) "Server not initialized" Nothing+ else case params of+ Just p -> case fromJSON p of+ Aeson.Success listParams -> do+ result <- handleListResourceTemplates listParams+ sendResponse (configOutput config) reqId result+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing -> do+ result <- handleListResourceTemplates (ListResourceTemplatesParams Nothing)+ sendResponse (configOutput config) reqId result+ "prompts/list" -> do+ if not (serverInitialized state)+ then+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32002) "Server not initialized" Nothing+ else case params of+ Just p -> case fromJSON p of+ Aeson.Success listParams -> do+ result <- handleListPrompts listParams+ sendResponse (configOutput config) reqId result+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing -> do+ result <- handleListPrompts (ListPromptsParams Nothing)+ sendResponse (configOutput config) reqId result+ "prompts/get" -> do+ if not (serverInitialized state)+ then+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32002) "Server not initialized" Nothing+ else case params of+ Just p -> case fromJSON p of+ Aeson.Success getParams -> do+ result <- handleGetPrompt getParams+ sendResponse (configOutput config) reqId result+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) "Missing params" Nothing+ "tools/list" -> do+ if not (serverInitialized state)+ then+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32002) "Server not initialized" Nothing+ else case params of+ Just p -> case fromJSON p of+ Aeson.Success listParams -> do+ result <- handleListTools listParams+ sendResponse (configOutput config) reqId result+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing -> do+ result <- handleListTools (ListToolsParams Nothing)+ sendResponse (configOutput config) reqId result+ "tools/call" -> do+ if not (serverInitialized state)+ then+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32002) "Server not initialized" Nothing+ else case params of+ Just p -> case fromJSON p of+ Aeson.Success callParams -> do+ result <- handleCallTool callParams+ sendResponse (configOutput config) reqId result+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) "Missing params" Nothing+ "completion/complete" -> do+ if not (serverInitialized state)+ then+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32002) "Server not initialized" Nothing+ else case params of+ Just p -> case fromJSON p of+ Aeson.Success completeParams -> do+ result <- handleComplete completeParams+ sendResponse (configOutput config) reqId result+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) "Missing params" Nothing+ "logging/setLevel" -> case params of+ Just p -> case fromJSON p of+ Aeson.Success setLevelParams -> do+ _ <- handleSetLevel setLevelParams+ -- SetLevel response is just an empty object+ sendResponse (configOutput config) reqId (object [])+ Aeson.Error e ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) ("Invalid params: " <> T.pack e) Nothing+ Nothing ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32602) "Missing params" Nothing+ _ ->+ sendError (configOutput config) reqId $+ JSONRPCErrorInfo (-32601) "Method not found" Nothing++handleInitialize :: RequestId -> InitializeParams -> MCPServerM ()+handleInitialize reqId params = do+ config <- ask+ state <- get++ let InitializeParams{capabilities = clientCaps} = params++ put+ state+ { serverInitialized = True+ , clientCapabilities = Just clientCaps+ , serverInfo = Just (configServerInfo config)+ }++ let result =+ InitializeResult+ { protocolVersion = "2024-11-05"+ , capabilities = serverCapabilities state+ , serverInfo = configServerInfo config+ , instructions = Nothing+ , _meta = Nothing+ }++ sendResponse (configOutput config) reqId result++handlePing :: RequestId -> MCPServerM ()+handlePing reqId = do+ config <- ask+ -- Ping response is just an empty object in MCP+ sendResponse (configOutput config) reqId (object [])++-- | Handle a JSON-RPC notification+handleNotification :: JSONRPCNotification -> MCPServerM ()+handleNotification _ = do+ return ()++-- | Run the MCP server with the given configuration+runServer :: (MCPServer MCPServerM) => ServerConfig -> IO ()+runServer config = do+ let initialState = initialServerState (configCapabilities config)++ let loop = do+ eofOrLine <-+ liftIO $+ catch+ (Right <$> BSC.hGetLine (configInput config))+ (\e -> if isEOFError e then return (Left ()) else throwIO e)+ case eofOrLine of+ Left () -> return () -- EOF reached, exit gracefully+ Right line -> do+ result <- handleMessage line+ case result of+ Just () -> loop+ Nothing -> return ()++ result <- runMCPServer config initialState loop+ case result of+ Left err -> putStrLn $ "Server error: " ++ T.unpack err+ Right _ -> return () -- Don't print "Server terminated" for clean EOF
+ src/MCP/Types.hs view
@@ -0,0 +1,614 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : MCP.Types+-- Description : Core types for the Model Context Protocol (MCP)+-- Copyright : (C) 2025 Matthias Pall Gissurarson+-- License : MIT+-- Maintainer : mpg@mpg.is+-- Stability : experimental+-- Portability : GHC+--+-- This module defines the core types used in the Model Context Protocol (MCP),+-- including JSON-RPC message types, client/server capabilities, resources,+-- tools, prompts, and various request/response types.+module MCP.Types (+ -- * Basic Types+ RequestId (..),+ Role (..),+ Cursor (..),+ ProgressToken (..),+ LoggingLevel (..),++ -- * Content Types+ Annotations (..),+ TextContent (..),+ ImageContent (..),+ AudioContent (..),+ EmbeddedResource (..),+ Content (..),++ -- * Resource Types+ ResourceContents (..),+ TextResourceContents (..),+ BlobResourceContents (..),+ Resource (..),+ ResourceTemplate (..),+ ResourceReference (..),++ -- * Tool Types+ ToolAnnotations (..),+ Tool (..),+ InputSchema (..),++ -- * Prompt Types+ PromptArgument (..),+ Prompt (..),+ PromptMessage (..),+ PromptReference (..),++ -- * Model Types+ ModelHint (..),+ ModelPreferences (..),+ IncludeContext (..),+ SamplingMessage (..),++ -- * Capability Types+ ClientCapabilities (..),+ ServerCapabilities (..),+ RootsCapability (..),+ PromptsCapability (..),+ ResourcesCapability (..),+ ToolsCapability (..),+ CompletionsCapability (..),+ LoggingCapability (..),+ SamplingCapability (..),+ ExperimentalCapability (..),++ -- * Implementation Info+ Implementation (..),++ -- * Roots+ Root (..),++ -- * Result Types+ Result (..),+ Metadata (..),+) where++import Control.Applicative (Alternative ((<|>)))+import Data.Aeson hiding (Error, Result)+import Data.Aeson.TH+import Data.Map (Map)+import Data.Text (Text)+import GHC.Generics++-- | A uniquely identifying ID for a request in JSON-RPC+newtype RequestId = RequestId Value+ deriving stock (Show, Eq)+ deriving newtype (ToJSON, FromJSON)++-- | The sender or recipient of messages and data in a conversation+data Role = User | Assistant+ deriving stock (Show, Eq, Generic)++instance ToJSON Role where+ toJSON User = "user"+ toJSON Assistant = "assistant"++instance FromJSON Role where+ parseJSON = withText "Role" $ \case+ "user" -> pure User+ "assistant" -> pure Assistant+ other -> fail $ "Unknown role: " <> show other++-- | An opaque token used to represent a cursor for pagination+newtype Cursor = Cursor Text+ deriving stock (Show, Eq)+ deriving newtype (ToJSON, FromJSON)++-- | A progress token, used to associate progress notifications with the original request+newtype ProgressToken = ProgressToken Value+ deriving stock (Show, Eq)+ deriving newtype (ToJSON, FromJSON)++-- | The severity of a log message+data LoggingLevel = Alert | Critical | Debug | Emergency | Error | Info | Notice | Warning+ deriving stock (Show, Eq, Generic)++instance ToJSON LoggingLevel where+ toJSON Alert = "alert"+ toJSON Critical = "critical"+ toJSON Debug = "debug"+ toJSON Emergency = "emergency"+ toJSON Error = "error"+ toJSON Info = "info"+ toJSON Notice = "notice"+ toJSON Warning = "warning"++instance FromJSON LoggingLevel where+ parseJSON = withText "LoggingLevel" $ \case+ "alert" -> pure Alert+ "critical" -> pure Critical+ "debug" -> pure Debug+ "emergency" -> pure Emergency+ "error" -> pure Error+ "info" -> pure Info+ "notice" -> pure Notice+ "warning" -> pure Warning+ other -> fail $ "Unknown logging level: " <> show other++-- | Optional annotations for the client+data Annotations = Annotations+ { audience :: Maybe [Role]+ , priority :: Maybe Double -- 0.0 to 1.0+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''Annotations)++-- | Text provided to or from an LLM+data TextContent = TextContent+ { textType :: Text -- Always "text"+ , text :: Text+ , annotations :: Maybe Annotations+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON TextContent where+ toJSON (TextContent _ txt anns) =+ object $+ [ "type" .= ("text" :: Text)+ , "text" .= txt+ ]+ ++ maybe [] (\a -> ["annotations" .= a]) anns++instance FromJSON TextContent where+ parseJSON = withObject "TextContent" $ \o -> do+ ty <- o .: "type"+ if ty == ("text" :: Text)+ then TextContent ty <$> o .: "text" <*> o .:? "annotations"+ else fail "Expected type 'text'"++-- | An image provided to or from an LLM+data ImageContent = ImageContent+ { imageType :: Text -- Always "image"+ , data' :: Text -- base64-encoded image data+ , mimeType :: Text+ , annotations :: Maybe Annotations+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ImageContent where+ toJSON (ImageContent _ dat mime anns) =+ object $+ [ "type" .= ("image" :: Text)+ , "data" .= dat+ , "mimeType" .= mime+ ]+ ++ maybe [] (\a -> ["annotations" .= a]) anns++instance FromJSON ImageContent where+ parseJSON = withObject "ImageContent" $ \o -> do+ ty <- o .: "type"+ if ty == ("image" :: Text)+ then ImageContent ty <$> o .: "data" <*> o .: "mimeType" <*> o .:? "annotations"+ else fail "Expected type 'image'"++-- | Audio provided to or from an LLM+data AudioContent = AudioContent+ { audioType :: Text -- Always "audio"+ , data' :: Text -- base64-encoded audio data+ , mimeType :: Text+ , annotations :: Maybe Annotations+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON AudioContent where+ toJSON (AudioContent _ dat mime anns) =+ object $+ [ "type" .= ("audio" :: Text)+ , "data" .= dat+ , "mimeType" .= mime+ ]+ ++ maybe [] (\a -> ["annotations" .= a]) anns++instance FromJSON AudioContent where+ parseJSON = withObject "AudioContent" $ \o -> do+ ty <- o .: "type"+ if ty == ("audio" :: Text)+ then AudioContent ty <$> o .: "data" <*> o .: "mimeType" <*> o .:? "annotations"+ else fail "Expected type 'audio'"++-- | Text resource contents+data TextResourceContents = TextResourceContents+ { uri :: Text+ , text :: Text+ , mimeType :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''TextResourceContents)++-- | Blob resource contents+data BlobResourceContents = BlobResourceContents+ { uri :: Text+ , blob :: Text -- base64-encoded+ , mimeType :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''BlobResourceContents)++-- | Resource contents (text or blob)+data ResourceContents+ = TextResource TextResourceContents+ | BlobResource BlobResourceContents+ deriving stock (Show, Eq, Generic)++instance ToJSON ResourceContents where+ toJSON (TextResource t) = toJSON t+ toJSON (BlobResource b) = toJSON b++instance FromJSON ResourceContents where+ parseJSON v =+ (TextResource <$> parseJSON v)+ <|> (BlobResource <$> parseJSON v)++-- | The contents of a resource, embedded into a prompt or tool call result+data EmbeddedResource = EmbeddedResource+ { resourceType :: Text -- Always "resource"+ , resource :: ResourceContents+ , annotations :: Maybe Annotations+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON EmbeddedResource where+ toJSON (EmbeddedResource _ res anns) =+ object $+ [ "type" .= ("resource" :: Text)+ , "resource" .= res+ ]+ ++ maybe [] (\a -> ["annotations" .= a]) anns++instance FromJSON EmbeddedResource where+ parseJSON = withObject "EmbeddedResource" $ \o -> do+ ty <- o .: "type"+ if ty == ("resource" :: Text)+ then EmbeddedResource ty <$> o .: "resource" <*> o .:? "annotations"+ else fail "Expected type 'resource'"++-- | Content that can be text, image, audio, or embedded resource+data Content+ = TextContentType TextContent+ | ImageContentType ImageContent+ | AudioContentType AudioContent+ | EmbeddedResourceType EmbeddedResource+ deriving stock (Show, Eq, Generic)++instance ToJSON Content where+ toJSON (TextContentType c) = toJSON c+ toJSON (ImageContentType c) = toJSON c+ toJSON (AudioContentType c) = toJSON c+ toJSON (EmbeddedResourceType c) = toJSON c++instance FromJSON Content where+ parseJSON v =+ (TextContentType <$> parseJSON v)+ <|> (ImageContentType <$> parseJSON v)+ <|> (AudioContentType <$> parseJSON v)+ <|> (EmbeddedResourceType <$> parseJSON v)++-- | A known resource that the server is capable of reading+data Resource = Resource+ { uri :: Text+ , name :: Text+ , description :: Maybe Text+ , mimeType :: Maybe Text+ , size :: Maybe Int+ , annotations :: Maybe Annotations+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''Resource)++-- | A template description for resources available on the server+data ResourceTemplate = ResourceTemplate+ { name :: Text+ , uriTemplate :: Text+ , description :: Maybe Text+ , mimeType :: Maybe Text+ , annotations :: Maybe Annotations+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ResourceTemplate)++-- | A reference to a resource or resource template definition+data ResourceReference = ResourceReference+ { refType :: Text -- Always "ref/resource"+ , uri :: Text+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON ResourceReference where+ toJSON (ResourceReference _ u) =+ object+ [ "type" .= ("ref/resource" :: Text)+ , "uri" .= u+ ]++instance FromJSON ResourceReference where+ parseJSON = withObject "ResourceReference" $ \o -> do+ ty <- o .: "type"+ if ty == ("ref/resource" :: Text)+ then ResourceReference ty <$> o .: "uri"+ else fail "Expected type 'ref/resource'"++-- | Additional properties describing a Tool to clients+data ToolAnnotations = ToolAnnotations+ { title :: Maybe Text+ , readOnlyHint :: Maybe Bool+ , destructiveHint :: Maybe Bool+ , idempotentHint :: Maybe Bool+ , openWorldHint :: Maybe Bool+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ToolAnnotations)++-- | Input schema for a tool+data InputSchema = InputSchema+ { schemaType :: Text -- Always "object"+ , properties :: Maybe (Map Text Value)+ , required :: Maybe [Text]+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON InputSchema where+ toJSON (InputSchema _ props req) =+ object $+ [ "type" .= ("object" :: Text)+ ]+ ++ maybe [] (\p -> ["properties" .= p]) props+ ++ maybe [] (\r -> ["required" .= r]) req++instance FromJSON InputSchema where+ parseJSON = withObject "InputSchema" $ \o -> do+ ty <- o .: "type"+ if ty == ("object" :: Text)+ then InputSchema ty <$> o .:? "properties" <*> o .:? "required"+ else fail "Expected type 'object'"++-- | Definition for a tool the client can call+data Tool = Tool+ { name :: Text+ , description :: Maybe Text+ , inputSchema :: InputSchema+ , annotations :: Maybe ToolAnnotations+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''Tool)++-- | Describes an argument that a prompt can accept+data PromptArgument = PromptArgument+ { name :: Text+ , description :: Maybe Text+ , required :: Maybe Bool+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''PromptArgument)++-- | A prompt or prompt template that the server offers+data Prompt = Prompt+ { name :: Text+ , description :: Maybe Text+ , arguments :: Maybe [PromptArgument]+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''Prompt)++-- | Describes a message returned as part of a prompt+data PromptMessage = PromptMessage+ { role :: Role+ , content :: Content+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''PromptMessage)++-- | Identifies a prompt+data PromptReference = PromptReference+ { refType :: Text -- Always "ref/prompt"+ , name :: Text+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON PromptReference where+ toJSON (PromptReference _ n) =+ object+ [ "type" .= ("ref/prompt" :: Text)+ , "name" .= n+ ]++instance FromJSON PromptReference where+ parseJSON = withObject "PromptReference" $ \o -> do+ ty <- o .: "type"+ if ty == ("ref/prompt" :: Text)+ then PromptReference ty <$> o .: "name"+ else fail "Expected type 'ref/prompt'"++-- | Hints to use for model selection+data ModelHint = ModelHint+ { name :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ModelHint)++-- | The server's preferences for model selection+data ModelPreferences = ModelPreferences+ { hints :: Maybe [ModelHint]+ , costPriority :: Maybe Double -- 0.0 to 1.0+ , speedPriority :: Maybe Double -- 0.0 to 1.0+ , intelligencePriority :: Maybe Double -- 0.0 to 1.0+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ModelPreferences)++-- | Include context options for sampling+data IncludeContext = AllServers | None | ThisServer+ deriving stock (Show, Eq, Generic)++instance ToJSON IncludeContext where+ toJSON AllServers = "allServers"+ toJSON None = "none"+ toJSON ThisServer = "thisServer"++instance FromJSON IncludeContext where+ parseJSON = withText "IncludeContext" $ \case+ "allServers" -> pure AllServers+ "none" -> pure None+ "thisServer" -> pure ThisServer+ other -> fail $ "Unknown include context: " <> show other++-- | Describes a message issued to or received from an LLM API+data SamplingMessage = SamplingMessage+ { role :: Role+ , content :: Content+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''SamplingMessage)++-- | Roots capability+data RootsCapability = RootsCapability+ { listChanged :: Maybe Bool+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''RootsCapability)++-- | Prompts capability+data PromptsCapability = PromptsCapability+ { listChanged :: Maybe Bool+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''PromptsCapability)++-- | Resources capability+data ResourcesCapability = ResourcesCapability+ { listChanged :: Maybe Bool+ , subscribe :: Maybe Bool+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ResourcesCapability)++-- | Tools capability+data ToolsCapability = ToolsCapability+ { listChanged :: Maybe Bool+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ToolsCapability)++-- | Completions capability+data CompletionsCapability = CompletionsCapability+ deriving stock (Show, Eq, Generic)++instance ToJSON CompletionsCapability where+ toJSON _ = object []++instance FromJSON CompletionsCapability where+ parseJSON = withObject "CompletionsCapability" $ \_ -> pure CompletionsCapability++-- | Logging capability+data LoggingCapability = LoggingCapability+ deriving stock (Show, Eq, Generic)++instance ToJSON LoggingCapability where+ toJSON _ = object []++instance FromJSON LoggingCapability where+ parseJSON = withObject "LoggingCapability" $ \_ -> pure LoggingCapability++-- | Sampling capability+data SamplingCapability = SamplingCapability+ deriving stock (Show, Eq, Generic)++instance ToJSON SamplingCapability where+ toJSON _ = object []++instance FromJSON SamplingCapability where+ parseJSON = withObject "SamplingCapability" $ \_ -> pure SamplingCapability++-- | Experimental capability+newtype ExperimentalCapability = ExperimentalCapability (Map Text Value)+ deriving stock (Show, Eq, Generic)+ deriving newtype (ToJSON, FromJSON)++-- | Capabilities a client may support+data ClientCapabilities = ClientCapabilities+ { roots :: Maybe RootsCapability+ , sampling :: Maybe SamplingCapability+ , experimental :: Maybe ExperimentalCapability+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ClientCapabilities)++-- | Capabilities that a server may support+data ServerCapabilities = ServerCapabilities+ { logging :: Maybe LoggingCapability+ , prompts :: Maybe PromptsCapability+ , resources :: Maybe ResourcesCapability+ , tools :: Maybe ToolsCapability+ , completions :: Maybe CompletionsCapability+ , experimental :: Maybe ExperimentalCapability+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''ServerCapabilities)++-- | Describes the name and version of an MCP implementation+data Implementation = Implementation+ { name :: Text+ , version :: Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions ''Implementation)++-- | Represents a root directory or file that the server can operate on+data Root = Root+ { uri :: Text+ , name :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True} ''Root)++-- | Metadata for results+newtype Metadata = Metadata (Map Text Value)+ deriving stock (Show, Eq, Generic)+ deriving newtype (ToJSON, FromJSON)++-- | Base result type+data Result = Result+ { _meta :: Maybe Metadata+ }+ deriving stock (Show, Eq, Generic)++$(deriveJSON defaultOptions{omitNothingFields = True, fieldLabelModifier = \case { "_meta" -> "_meta"; x -> x }} ''Result)
+ test/Main.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."