diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for mcp + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/mcp.cabal b/mcp.cabal new file mode 100644 --- /dev/null +++ b/mcp.cabal @@ -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 diff --git a/src/MCP/Protocol.hs b/src/MCP/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Protocol.hs @@ -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) diff --git a/src/MCP/Server.hs b/src/MCP/Server.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Server.hs @@ -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 diff --git a/src/MCP/Types.hs b/src/MCP/Types.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Types.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."