diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,16 @@ +# Changelog + +## 0.1.0 + +### Added +- Initial release, split from the `mcp` package. +- `MCP.Types`: Core MCP data types (Content, Resource, Tool, Prompt, Capability, etc.) +- `MCP.Protocol`: JSON-RPC 2.0 message wrappers and all client/server request/response types. +- `MCP.Aeson`: Custom Aeson parsing options. + +### Fixed +- Make `params` optional in `JSONRPCRequest`, `JSONRPCNotification`, + `ViaJSONRPCRequest`, and `ViaJSONRPCNotification` `FromJSON` instances. + JSON-RPC 2.0 allows omitting the `params` field; previously a missing + `params` caused requests to be silently misparsed as notifications + (losing the `id` and never receiving a response). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/mcp-types.cabal b/mcp-types.cabal new file mode 100644 --- /dev/null +++ b/mcp-types.cabal @@ -0,0 +1,96 @@ +cabal-version: 2.2 +name: mcp-types +version: 0.1.0 +license: MPL-2.0 +license-file: LICENSE +copyright: (c) 2025 DPella AB +author: DPella AB +tested-with: ghc ==9.12.2 +extra-doc-files: + CHANGELOG.md + +maintainer: + matti@dpella.io, + lobo@dpella.io + +synopsis: Core types and protocol definitions for the Model Context Protocol (MCP) +description: + This library provides the core type definitions and JSON-RPC protocol layer + for the Model Context Protocol (MCP). MCP is a protocol that enables seamless + communication between AI models and external tools, resources, and services. + . + This package contains only the pure protocol types with minimal dependencies, + making it suitable for building both clients and servers on any framework. + For a ready-made Servant-based server, see the @mcp@ package. + +homepage: https://github.com/DPella/mcp +bug-reports: https://github.com/DPella/mcp/issues +category: Web, AI + +source-repository head + type: git + location: https://github.com/DPella/mcp.git + +library + default-language: + Haskell2010 + + default-extensions: + DataKinds + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + OverloadedStrings + PolyKinds + RankNTypes + TypeApplications + TypeFamilies + + hs-source-dirs: + src + + exposed-modules: + MCP.Aeson + MCP.Protocol + MCP.Types + + build-depends: + aeson >=2.1 && <2.3, + base >=4.18 && <4.22, + containers >=0.6 && <0.8, + jsonrpc >=0.2.0 && <0.3, + text >=2.0 && <2.2, + +test-suite test-mcp-types + type: exitcode-stdio-1.0 + default-language: + Haskell2010 + + default-extensions: + DataKinds + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + OverloadedStrings + PolyKinds + RankNTypes + TypeApplications + TypeFamilies + + hs-source-dirs: + test + + main-is: + Main.hs + + build-depends: + aeson >=2.1 && <2.3, + base >=4.18 && <4.22, + containers >=0.6 && <0.8, + hspec >=2.10 && <2.12, + jsonrpc >=0.2.0 && <0.3, + mcp-types, diff --git a/src/MCP/Aeson.hs b/src/MCP/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/MCP/Aeson.hs @@ -0,0 +1,27 @@ +{- | +Module: MCP.Aeson +Copyright: (c) DPella AB 2025 +License: MPL-2.0 +Maintainer: , +-} +module MCP.Aeson where + +import Data.Aeson +import Data.List (stripPrefix) + +-- | Custom Aeson parsing options for MCP types. +mcpParseOpts :: Options +mcpParseOpts = + defaultOptions + { omitNothingFields = True + , fieldLabelModifier = flm + } + where + -- Custom field label modifier to handle "_meta" field + flm :: String -> String + flm "_meta" = "_meta" + -- Handle duplicate record fields + flm fl + | Just with_sel <- stripPrefix "$sel:" fl = + takeWhile (/= ':') with_sel + flm fl = fl 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,1303 @@ +{-# HLINT ignore "Use newtype instead of data" #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{- | +Module : MCP.Protocol +Description : MCP protocol types built on JSON-RPC 2.0 +Copyright : (C) 2025 DPella AB +License : MPL-2.0 +Maintainer : matti@dpella.io, lobo@dpella.io +Stability : experimental +Portability : GHC + +This module defines the Model Context Protocol (MCP) request, response, +and notification types. The underlying JSON-RPC 2.0 transport types are +re-exported from the @jsonrpc@ package. +-} +module MCP.Protocol ( + -- * JSON-RPC types (re-exported from "JSONRPC") + module JSONRPC, + + -- * 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 (..), + CompletionContext (..), + CompletionArgument (..), + Reference (..), + + -- * Server Request Types + CreateMessageRequest (..), + CreateMessageParams (..), + ListRootsRequest (..), + ListRootsParams (..), + ElicitRequest (..), + ElicitParams (..), + PrimitiveSchemaDefinition (..), + + -- * Response Types + InitializeResult (..), + ListResourcesResult (..), + ListResourceTemplatesResult (..), + ReadResourceResult (..), + ListPromptsResult (..), + GetPromptResult (..), + ListToolsResult (..), + CallToolResult (..), + CompleteResult (..), + CompletionResult (..), + CreateMessageResult (..), + ListRootsResult (..), + ElicitResult (..), + + -- * Notification Types + CancelledNotification (..), + CancelledParams (..), + InitializedNotification (..), + InitializedParams (..), + ProgressNotification (..), + ProgressParams (..), + ResourceListChangedNotification (..), + ResourceUpdatedNotification (..), + ResourceUpdatedParams (..), + PromptListChangedNotification (..), + ToolListChangedNotification (..), + LoggingMessageNotification (..), + LoggingMessageParams (..), + RootsListChangedNotification (..), + + -- * Union Types + ClientRequest (..), + ServerRequest (..), + ClientNotification (..), + ServerNotification (..), + + -- * MCP Constants + pROTOCOL_VERSION, +) where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Aeson.TH +import Data.Map (Map) +import Data.Text (Text) +import GHC.Generics +import JSONRPC +import MCP.Aeson +import MCP.Types + +-- * Client Request Types + +{- | Initialize request parameters. + +Parameters sent by the client during initialization. +-} +data InitializeParams = InitializeParams + { protocolVersion :: Text + {- ^ The latest version of the Model Context Protocol that the client supports. + The client MAY decide to support older versions as well. + -} + , capabilities :: ClientCapabilities + , clientInfo :: Implementation + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''InitializeParams) + +{- | This request is sent from the client to the server when it first connects, +asking it to begin initialization. +-} +data InitializeRequest = InitializeRequest + { id :: RequestId + , params :: InitializeParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest InitializeRequest + +instance IsJSONRPCRequest InitializeRequest where + requestMethod _ = "initialize" + +{- | Ping request parameters. + +Parameters for a ping request (typically just metadata). +-} +data PingParams where + PingParams :: {_meta :: Maybe Metadata} -> PingParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''PingParams) + +{- | A ping, issued by either the server or the client, to check that the other +party is still alive. + +The receiver must promptly respond, or else may be disconnected. +-} +data PingRequest = PingRequest + { id :: RequestId + , params :: Maybe PingParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest PingRequest + +instance IsJSONRPCRequest PingRequest where + requestMethod _ = "ping" + +{- | List resources request parameters. + +Parameters for requesting a paginated list of resources. +-} +data ListResourcesParams where + ListResourcesParams :: + { cursor :: Maybe Cursor + {- ^ An opaque token representing the current pagination position. + If provided, the server should return results starting after this cursor. + -} + } -> + ListResourcesParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListResourcesParams) + +-- | Sent from the client to request a list of resources the server has. +data ListResourcesRequest = ListResourcesRequest + { id :: RequestId + , params :: Maybe ListResourcesParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest ListResourcesRequest + +instance IsJSONRPCRequest ListResourcesRequest where + requestMethod _ = "resources/list" + +{- | List resource templates request parameters. + +Parameters for requesting a paginated list of resource templates. +-} +data ListResourceTemplatesParams where + ListResourceTemplatesParams :: + { cursor :: Maybe Cursor + {- ^ An opaque token representing the current pagination position. + If provided, the server should return results starting after this cursor. + -} + } -> + ListResourceTemplatesParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListResourceTemplatesParams) + +-- | Sent from the client to request a list of resource templates the server has. +data ListResourceTemplatesRequest = ListResourceTemplatesRequest + { id :: RequestId + , params :: Maybe ListResourceTemplatesParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest ListResourceTemplatesRequest + +instance IsJSONRPCRequest ListResourceTemplatesRequest where + requestMethod _ = "resources/templates/list" + +{- | Read resource request parameters. + +Parameters for reading a specific resource. +-} +data ReadResourceParams where + ReadResourceParams :: + { uri :: Text + {- ^ The URI of the resource to read. The URI can use any protocol; + it is up to the server how to interpret it. + -} + } -> + ReadResourceParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ReadResourceParams) + +-- | Sent from the client to the server, to read a specific resource URI. +data ReadResourceRequest = ReadResourceRequest + { id :: RequestId + , params :: ReadResourceParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest ReadResourceRequest + +instance IsJSONRPCRequest ReadResourceRequest where + requestMethod _ = "resources/read" + +{- | Subscribe request parameters. + +Parameters for subscribing to resource updates. +-} +data SubscribeParams where + SubscribeParams :: + { uri :: Text + {- ^ The URI of the resource to subscribe to. The URI can use any protocol; + it is up to the server how to interpret it. + -} + } -> + SubscribeParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''SubscribeParams) + +{- | Sent from the client to request resources/updated notifications from the server +whenever a particular resource changes. +-} +data SubscribeRequest = SubscribeRequest + { id :: RequestId + , params :: SubscribeParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest SubscribeRequest + +instance IsJSONRPCRequest SubscribeRequest where + requestMethod _ = "resources/subscribe" + +{- | Unsubscribe request parameters. + +Parameters for unsubscribing from resource updates. +-} +data UnsubscribeParams where + UnsubscribeParams :: + { uri :: Text + -- ^ The URI of the resource to unsubscribe from. + } -> + UnsubscribeParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''UnsubscribeParams) + +{- | Sent from the client to request cancellation of resources/updated +notifications from the server. This should follow a previous resources/subscribe request. +-} +data UnsubscribeRequest = UnsubscribeRequest + { id :: RequestId + , params :: UnsubscribeParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest UnsubscribeRequest + +instance IsJSONRPCRequest UnsubscribeRequest where + requestMethod _ = "resources/unsubscribe" + +{- | List prompts request parameters. + +Parameters for requesting a paginated list of prompts. +-} +data ListPromptsParams where + ListPromptsParams :: + { cursor :: Maybe Cursor + {- ^ An opaque token representing the current pagination position. + If provided, the server should return results starting after this cursor. + -} + } -> + ListPromptsParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListPromptsParams) + +-- | Sent from the client to request a list of prompts and prompt templates the server has. +data ListPromptsRequest = ListPromptsRequest + { id :: RequestId + , params :: Maybe ListPromptsParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest ListPromptsRequest + +instance IsJSONRPCRequest ListPromptsRequest where + requestMethod _ = "prompts/list" + +{- | Get prompt request parameters. + +Parameters for retrieving a specific prompt with optional arguments. +-} +data GetPromptParams = GetPromptParams + { name :: Text + -- ^ The name of the prompt or prompt template. + , arguments :: Maybe (Map Text Text) + -- ^ Arguments to use for templating the prompt. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''GetPromptParams) + +-- | Used by the client to get a prompt provided by the server. +data GetPromptRequest = GetPromptRequest + { id :: RequestId + , params :: GetPromptParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest GetPromptRequest + +instance IsJSONRPCRequest GetPromptRequest where + requestMethod _ = "prompts/get" + +{- | List tools request parameters. + +Parameters for requesting a paginated list of tools. +-} +data ListToolsParams where + ListToolsParams :: + { cursor :: Maybe Cursor + {- ^ An opaque token representing the current pagination position. + If provided, the server should return results starting after this cursor. + -} + } -> + ListToolsParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListToolsParams) + +-- | Sent from the client to request a list of tools the server has. +data ListToolsRequest = ListToolsRequest + { id :: RequestId + , params :: Maybe ListToolsParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest ListToolsRequest + +instance IsJSONRPCRequest ListToolsRequest where + requestMethod _ = "tools/list" + +{- | Call tool request parameters. + +Parameters for invoking a specific tool with arguments. +-} +data CallToolParams = CallToolParams + { name :: Text + , arguments :: Maybe (Map Text Value) + } + deriving stock (Show, Eq, Generic, Ord) + +$(deriveJSON mcpParseOpts ''CallToolParams) + +-- | Used by the client to invoke a tool provided by the server. +data CallToolRequest = CallToolRequest + { id :: RequestId + , params :: CallToolParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest CallToolRequest + +instance IsJSONRPCRequest CallToolRequest where + requestMethod _ = "tools/call" + +{- | Set level request parameters. + +Parameters for setting the logging level. +-} +data SetLevelParams where + SetLevelParams :: + { level :: LoggingLevel + {- ^ The level of logging that the client wants to receive from the server. + The server should send all logs at this level and higher (i.e., more severe) + to the client as notifications/message. + -} + } -> + SetLevelParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''SetLevelParams) + +-- | A request from the client to the server, to enable or adjust logging. +data SetLevelRequest = SetLevelRequest + { id :: RequestId + , params :: SetLevelParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest SetLevelRequest + +instance IsJSONRPCRequest SetLevelRequest where + requestMethod _ = "logging/setLevel" + +{- | Completion argument. + +Represents an argument for completion requests. +-} +data CompletionArgument = CompletionArgument + { name :: Text + -- ^ The name of the argument. + , value :: Text + -- ^ The value of the argument to use for completion matching. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CompletionArgument) + +{- | Reference to either a prompt or resource template. + +Used in completion requests to specify what is being completed. +-} +data Reference + = PromptRef PromptReference + | ResourceTemplateRef ResourceTemplateReference + deriving stock (Show, Eq, Generic) + +instance ToJSON Reference where + toJSON (PromptRef p) = toJSON p + toJSON (ResourceTemplateRef r) = toJSON r + +instance FromJSON Reference where + parseJSON v = + (PromptRef <$> parseJSON v) + <|> (ResourceTemplateRef <$> parseJSON v) + +-- | Context for completion requests +data CompletionContext = CompletionContext + { arguments :: Maybe (Map Text Text) + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CompletionContext) + +{- | Complete request parameters. + +Parameters for requesting completion options. +-} +data CompleteParams = CompleteParams + { ref :: Reference + , argument :: CompletionArgument + -- ^ The argument's information. + , context :: Maybe CompletionContext + {- ^ Additional, optional context for completions. + Previously-resolved variables in a URI template or prompt. + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CompleteParams) + +-- | A request from the client to the server, to ask for completion options. +data CompleteRequest = CompleteRequest + { id :: RequestId + , params :: CompleteParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest CompleteRequest + +instance IsJSONRPCRequest CompleteRequest where + requestMethod _ = "completion/complete" + +-- * Server Request Types + +{- | Create message request parameters. + +Parameters for requesting LLM sampling from the client. +-} +data CreateMessageParams = CreateMessageParams + { maxTokens :: Int + {- ^ The maximum number of tokens to sample, as requested by the server. + The client MAY choose to sample fewer tokens than requested. + -} + , messages :: [SamplingMessage] + , modelPreferences :: Maybe ModelPreferences + -- ^ The server's preferences for which model to select. The client MAY ignore these preferences. + , systemPrompt :: Maybe Text + {- ^ An optional system prompt the server wants to use for sampling. + The client MAY modify or omit this prompt. + -} + , includeContext :: Maybe IncludeContext + {- ^ A request to include context from one or more MCP servers (including the caller), + to be attached to the prompt. The client MAY ignore this request. + -} + , temperature :: Maybe Double + , stopSequences :: Maybe [Text] + , metadata :: Maybe (Map Text Value) + {- ^ Optional metadata to pass through to the LLM provider. + The format of this metadata is provider-specific. + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CreateMessageParams) + +{- | A request from the server to sample an LLM via the client. + +The client has full discretion over which model to select. The client should also +inform the user before beginning sampling, to allow them to inspect the request +(human in the loop) and decide whether to approve it. +-} +data CreateMessageRequest = CreateMessageRequest + { id :: RequestId + , params :: CreateMessageParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest CreateMessageRequest + +instance IsJSONRPCRequest CreateMessageRequest where + requestMethod _ = "sampling/createMessage" + +{- | List roots request parameters. + +Parameters for requesting the list of root directories or files. +-} +data ListRootsParams where + ListRootsParams :: {_meta :: Maybe Metadata} -> ListRootsParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListRootsParams) + +{- | Sent from the server to request a list of root URIs from the client. + +Roots allow servers to ask for specific directories or files to operate on. +A common example for roots is providing a set of repositories or directories +a server should operate on. + +This request is typically used when the server needs to understand the file system +structure or access specific locations that the client has permission to read from. +-} +data ListRootsRequest = ListRootsRequest + { id :: RequestId + , params :: Maybe ListRootsParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest ListRootsRequest + +instance IsJSONRPCRequest ListRootsRequest where + requestMethod _ = "roots/list" + +-- * Response Types + +-- | After receiving an initialize request from the client, the server sends this response. +data InitializeResult = InitializeResult + { protocolVersion :: Text + {- ^ The version of the Model Context Protocol that the server wants to use. + This may not match the version that the client requested. If the client + cannot support this version, it MUST disconnect. + -} + , capabilities :: ServerCapabilities + , serverInfo :: Implementation + , instructions :: Maybe Text + {- ^ Instructions describing how to use the server and its features. + This can be used by clients to improve the LLM's understanding of available + tools, resources, etc. It can be thought of like a "hint" to the model. + For example, this information MAY be added to the system prompt. + -} + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''InitializeResult) + +-- | The server's response to a resources/list request from the client. +data ListResourcesResult = ListResourcesResult + { resources :: [Resource] + , nextCursor :: Maybe Cursor + {- ^ An opaque token representing the pagination position after the last returned result. + If present, there may be more results available. + -} + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListResourcesResult) + +-- | The server's response to a resources/templates/list request from the client. +data ListResourceTemplatesResult = ListResourceTemplatesResult + { resourceTemplates :: [ResourceTemplate] + , nextCursor :: Maybe Cursor + {- ^ An opaque token representing the pagination position after the last returned result. + If present, there may be more results available. + -} + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListResourceTemplatesResult) + +-- | The server's response to a resources/read request from the client. +data ReadResourceResult = ReadResourceResult + { contents :: [ResourceContents] + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ReadResourceResult) + +-- | The server's response to a prompts/list request from the client. +data ListPromptsResult = ListPromptsResult + { prompts :: [Prompt] + , nextCursor :: Maybe Cursor + {- ^ An opaque token representing the pagination position after the last returned result. + If present, there may be more results available. + -} + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListPromptsResult) + +-- | The server's response to a prompts/get request from the client. +data GetPromptResult = GetPromptResult + { description :: Maybe Text + -- ^ An optional description for the prompt. + , messages :: [PromptMessage] + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''GetPromptResult) + +-- | The server's response to a tools/list request from the client. +data ListToolsResult = ListToolsResult + { tools :: [Tool] + , nextCursor :: Maybe Cursor + {- ^ An opaque token representing the pagination position after the last returned result. + If present, there may be more results available. + -} + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListToolsResult) + +{- | The server's response to a tool call. + +Any errors that originate from the tool SHOULD be reported inside the result +object, with `isError` set to true, _not_ as an MCP protocol-level error +response. Otherwise, the LLM would not be able to see that an error occurred +and self-correct. + +However, any errors in _finding_ the tool, an error indicating that the +server does not support tool calls, or any other exceptional conditions, +should be reported as an MCP error response. +-} +data CallToolResult = CallToolResult + { content :: [ContentBlock] + -- ^ A list of content objects that represent the unstructured result of the tool call. + , structuredContent :: Maybe (Map Text Value) + -- ^ An optional JSON object that represents the structured result of the tool call. + , isError :: Maybe Bool + {- ^ Whether the tool call ended in an error. + If not set, this is assumed to be false (the call was successful). + -} + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CallToolResult) + +{- | Completion result inner type. + +Contains the actual completion data. +-} +data CompletionResult = CompletionResult + { values :: [Text] + -- ^ An array of completion values. Must not exceed 100 items. + , total :: Maybe Int + {- ^ The total number of completion options available. + This can exceed the number of values actually sent in the response. + -} + , hasMore :: Maybe Bool + {- ^ Indicates whether there are additional completion options beyond those + provided in the current response, even if the exact total is unknown. + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CompletionResult) + +-- | The server's response to a completion/complete request. +data CompleteResult = CompleteResult + { completion :: CompletionResult + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CompleteResult) + +{- | The client's response to a sampling/createMessage request from the server. + +The client should inform the user before returning the sampled message, to allow them +to inspect the response (human in the loop) and decide whether to allow the server to see it. +-} +data CreateMessageResult = CreateMessageResult + { role :: Role + , content :: Content -- This stays as Content for sampling, not ContentBlock + , model :: Text + -- ^ The name of the model that generated the message. + , stopReason :: Maybe Text + -- ^ The reason why sampling stopped, if known. + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CreateMessageResult) + +{- | The client's response to a roots/list request from the server. + +This result contains an array of Root objects, each representing a root directory +or file that the server can operate on. +-} +data ListRootsResult = ListRootsResult + { roots :: [Root] + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ListRootsResult) + +-- * Notification Types + +{- | Cancelled notification parameters. + +Parameters for a cancellation notification. +-} +data CancelledParams = CancelledParams + { requestId :: RequestId + {- ^ The ID of the request to cancel. + This MUST correspond to the ID of a request previously issued in the same direction. + -} + , reason :: Maybe Text + {- ^ An optional string describing the reason for the cancellation. + This MAY be logged or presented to the user. + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''CancelledParams) + +{- | This notification can be sent by either side to indicate that it is cancelling +a previously-issued request. + +The request SHOULD still be in-flight, but due to communication latency, it is always +possible that this notification MAY arrive after the request has already finished. + +This notification indicates that the result will be unused, so any associated +processing SHOULD cease. + +A client MUST NOT attempt to cancel its `initialize` request. +-} +data CancelledNotification = CancelledNotification + { params :: CancelledParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification CancelledNotification + +instance IsJSONRPCNotification CancelledNotification where + notificationsMethod _ = "notifications/cancelled" + +{- | Initialized notification parameters. + +Parameters for the initialized notification (typically just metadata). +-} +data InitializedParams where + InitializedParams :: {_meta :: Maybe Metadata} -> InitializedParams + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''InitializedParams) + +-- | This notification is sent from the client to the server after initialization has finished. +data InitializedNotification = InitializedNotification + { params :: Maybe EmptyParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification InitializedNotification + +instance IsJSONRPCNotification InitializedNotification where + notificationsMethod _ = "notifications/initialized" + +{- | Progress notification parameters. + +Parameters for progress update notifications. +-} +data ProgressParams = ProgressParams + { progressToken :: ProgressToken + {- ^ The progress token which was given in the initial request, used to associate + this notification with the request that is proceeding. + -} + , progress :: Double + {- ^ The progress thus far. This should increase every time progress is made, + even if the total is unknown. + -} + , total :: Maybe Double + -- ^ Total number of items to process (or total progress required), if known. + , message :: Maybe Text + -- ^ An optional message describing the current progress. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ProgressParams) + +{- | An out-of-band notification used to inform the receiver of a progress update +for a long-running request. +-} +data ProgressNotification = ProgressNotification + { params :: ProgressParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification ProgressNotification + +instance IsJSONRPCNotification ProgressNotification where + notificationsMethod _ = "notifications/progress" + +{- | An optional notification from the server to the client, informing it that the list +of resources it can read from has changed. + +This may be issued by servers without any previous subscription from the client. +-} +data ResourceListChangedNotification = ResourceListChangedNotification + { params :: Maybe EmptyParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification ResourceListChangedNotification + +instance IsJSONRPCNotification ResourceListChangedNotification where + notificationsMethod _ = "notifications/resources/list_changed" + +{- | Resource updated notification parameters. + +Parameters for resource update notifications. +-} +data ResourceUpdatedParams = ResourceUpdatedParams + { uri :: Text + {- ^ The URI of the resource that has been updated. This might be a sub-resource + of the one that the client actually subscribed to. + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ResourceUpdatedParams) + +{- | A notification from the server to the client, informing it that a resource +has changed and may need to be read again. + +This should only be sent if the client previously sent a resources/subscribe request. +-} +data ResourceUpdatedNotification = ResourceUpdatedNotification + { params :: ResourceUpdatedParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification ResourceUpdatedNotification + +instance IsJSONRPCNotification ResourceUpdatedNotification where + notificationsMethod _ = "notifications/resources/updated" + +{- | An optional notification from the server to the client, informing it that the list +of prompts it offers has changed. + +This may be issued by servers without any previous subscription from the client. +-} +data PromptListChangedNotification = PromptListChangedNotification + { params :: Maybe EmptyParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification PromptListChangedNotification + +instance IsJSONRPCNotification PromptListChangedNotification where + notificationsMethod _ = "notifications/prompts/list_changed" + +{- | An optional notification from the server to the client, informing it that the list +of tools it offers has changed. + +This may be issued by servers without any previous subscription from the client. +-} +data ToolListChangedNotification = ToolListChangedNotification + { params :: Maybe EmptyParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification ToolListChangedNotification + +instance IsJSONRPCNotification ToolListChangedNotification where + notificationsMethod _ = "notifications/tools/list_changed" + +{- | Logging message notification parameters. + +Parameters for log message notifications. +-} +data LoggingMessageParams = LoggingMessageParams + { level :: LoggingLevel + -- ^ The severity of this log message. + , data' :: Value + {- ^ The data to be logged, such as a string message or an object. + Any JSON serializable type is allowed here. + -} + , logger :: Maybe Text + -- ^ An optional name of the logger issuing this message. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''LoggingMessageParams) + +{- | Notification of a log message passed from server to client. + +If no logging/setLevel request has been sent from the client, the server MAY decide +which messages to send automatically. +-} +data LoggingMessageNotification = LoggingMessageNotification + { params :: LoggingMessageParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification LoggingMessageNotification + +instance IsJSONRPCNotification LoggingMessageNotification where + notificationsMethod _ = "notifications/message" + +{- | A notification from the client to the server, informing it that the list of roots has changed. + +This notification should be sent whenever the client adds, removes, or modifies any root. +The server should then request an updated list of roots using the ListRootsRequest. +-} +data RootsListChangedNotification = RootsListChangedNotification + { params :: Maybe EmptyParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCNotification RootsListChangedNotification + +instance IsJSONRPCNotification RootsListChangedNotification where + notificationsMethod _ = "notifications/roots/list_changed" + +-- * Union Types + +{- | Any request that can be sent from a client to a server. + +This union type encompasses all possible client-to-server requests in the MCP protocol. +-} +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 request that can be sent from a server to a client. + +This union type encompasses all possible server-to-client requests in the MCP protocol. +-} +data ServerRequest + = PingServerReq PingRequest + | CreateMessageReq CreateMessageRequest + | ListRootsReq ListRootsRequest + | ElicitReq ElicitRequest + deriving stock (Show, Eq, Generic) + +instance ToJSON ServerRequest where + toJSON (PingServerReq r) = toJSON r + toJSON (CreateMessageReq r) = toJSON r + toJSON (ListRootsReq r) = toJSON r + toJSON (ElicitReq r) = toJSON r + +instance FromJSON ServerRequest where + parseJSON v = + (PingServerReq <$> parseJSON v) + <|> (CreateMessageReq <$> parseJSON v) + <|> (ListRootsReq <$> parseJSON v) + <|> (ElicitReq <$> parseJSON v) + +{- | Any notification that can be sent from a client to a server. + +This union type encompasses all possible client-to-server notifications in the MCP protocol. +-} +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 notification that can be sent from a server to a client. + +This union type encompasses all possible server-to-client notifications in the MCP protocol. +-} +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) + +{- | MCP protocol version string. + +Indicates the version of the Model Context Protocol +that this implementation supports. +-} +pROTOCOL_VERSION :: Text +pROTOCOL_VERSION = "2025-06-18" + +{- | Primitive schema definitions that only allow primitive types without nested objects or arrays. + +Restricted schema definitions for elicitation requests. +-} +data PrimitiveSchemaDefinition + = StringSchema + { schemaType :: Text -- Always "string" + , title :: Maybe Text + , description :: Maybe Text + , minLength :: Maybe Int + , maxLength :: Maybe Int + , format :: Maybe Text -- "email" | "uri" | "date" | "date-time" + } + | NumberSchema + { schemaType :: Text -- "number" or "integer" + , title :: Maybe Text + , description :: Maybe Text + , minimum :: Maybe Double + , maximum :: Maybe Double + } + | BooleanSchema + { schemaType :: Text -- Always "boolean" + , title :: Maybe Text + , description :: Maybe Text + , defaultValue :: Maybe Bool + } + | EnumSchema + { schemaType :: Text -- Always "string" + , title :: Maybe Text + , description :: Maybe Text + , enum :: [Text] + , enumNames :: Maybe [Text] -- Display names for enum values + } + deriving stock (Show, Eq, Generic) + +instance ToJSON PrimitiveSchemaDefinition where + toJSON (StringSchema ty ttl desc minL maxL fmt) = + object $ + ["type" .= ty] + <> maybe [] (\t -> ["title" .= t]) ttl + <> maybe [] (\d -> ["description" .= d]) desc + <> maybe [] (\ml -> ["minLength" .= ml]) minL + <> maybe [] (\mx -> ["maxLength" .= mx]) maxL + <> maybe [] (\f -> ["format" .= f]) fmt + toJSON (NumberSchema ty ttl desc minV maxV) = + object $ + ["type" .= ty] + <> maybe [] (\t -> ["title" .= t]) ttl + <> maybe [] (\d -> ["description" .= d]) desc + <> maybe [] (\mn -> ["minimum" .= mn]) minV + <> maybe [] (\mx -> ["maximum" .= mx]) maxV + toJSON (BooleanSchema ty ttl desc defVal) = + object $ + ["type" .= ty] + <> maybe [] (\t -> ["title" .= t]) ttl + <> maybe [] (\d -> ["description" .= d]) desc + <> maybe [] (\dv -> ["default" .= dv]) defVal + toJSON (EnumSchema ty ttl desc vals names) = + object $ + [ "type" .= ty + , "enum" .= vals + ] + <> maybe [] (\t -> ["title" .= t]) ttl + <> maybe [] (\d -> ["description" .= d]) desc + <> maybe [] (\en -> ["enumNames" .= en]) names + +instance FromJSON PrimitiveSchemaDefinition where + parseJSON = withObject "PrimitiveSchemaDefinition" $ \o -> do + ty <- o .: "type" + case ty of + "string" -> do + enums <- o .:? "enum" + case enums of + Just vals -> + EnumSchema ty + <$> o .:? "title" + <*> o .:? "description" + <*> pure vals + <*> o .:? "enumNames" + Nothing -> + StringSchema ty + <$> o .:? "title" + <*> o .:? "description" + <*> o .:? "minLength" + <*> o .:? "maxLength" + <*> o .:? "format" + "number" -> + NumberSchema ty + <$> o .:? "title" + <*> o .:? "description" + <*> o .:? "minimum" + <*> o .:? "maximum" + "integer" -> + NumberSchema ty + <$> o .:? "title" + <*> o .:? "description" + <*> o .:? "minimum" + <*> o .:? "maximum" + "boolean" -> + BooleanSchema ty + <$> o .:? "title" + <*> o .:? "description" + <*> o .:? "default" + _ -> fail $ "Unknown schema type: " <> show ty + +{- | Elicit request parameters. + +Parameters for requesting additional information from the user via the client. +-} +data ElicitParams = ElicitParams + { message :: Text + -- ^ The message to present to the user. + , requestedSchema :: Map Text PrimitiveSchemaDefinition + {- ^ A restricted subset of JSON Schema. Only top-level properties are allowed, + without nesting. The schema type is always "object" with properties. + -} + , requiredFields :: Maybe [Text] + -- ^ Required fields in the schema. + } + deriving stock (Show, Eq, Generic) + +instance ToJSON ElicitParams where + toJSON (ElicitParams msg schema reqFields) = + object $ + [ "message" .= msg + , "requestedSchema" + .= object + ( [ "type" .= ("object" :: Text) + , "properties" .= schema + ] + <> maybe [] (\rf -> ["required" .= rf]) reqFields + ) + ] + +instance FromJSON ElicitParams where + parseJSON = withObject "ElicitParams" $ \o -> do + msg <- o .: "message" + schema <- o .: "requestedSchema" + schemaProps <- + withObject + "requestedSchema" + ( \so -> do + ty <- so .: "type" + if ty == ("object" :: Text) + then do + props <- so .: "properties" + reqFields <- so .:? "required" + pure (props, reqFields) + else fail "Expected requestedSchema type to be 'object'" + ) + schema + pure $ ElicitParams msg (fst schemaProps) (snd schemaProps) + +-- | A request from the server to elicit additional information from the user via the client. +data ElicitRequest = ElicitRequest + { id :: RequestId + , params :: ElicitParams + } + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via ViaJSONRPCRequest ElicitRequest + +instance IsJSONRPCRequest ElicitRequest where + requestMethod _ = "elicitation/create" + +-- | The client's response to an elicitation request. +data ElicitResult = ElicitResult + { action :: Text + {- ^ The user action in response to the elicitation. + - "accept": User submitted the form/confirmed the action + - "decline": User explicitly declined the action + - "cancel": User dismissed without making an explicit choice + -} + , content :: Maybe (Map Text Value) + {- ^ The submitted form data, only present when action is "accept". + Contains values matching the requested schema. + -} + , _meta :: Maybe Metadata + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ElicitResult) 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,1130 @@ +{-# 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 DPella AB +License : MPL-2.0 +Maintainer : matti@dpella.io, lobo@dpella.io +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 (re-exported from JSONRPC) + RequestId (..), + -- * Basic Types + Role (..), + Cursor (..), + ProgressToken (..), + LoggingLevel (..), + + -- * Content Types + Annotations (..), + TextContent (..), + ImageContent (..), + AudioContent (..), + EmbeddedResource (..), + ResourceLink (..), + Content (..), + ContentBlock (..), + + -- * Resource Types + ResourceContents (..), + TextResourceContents (..), + BlobResourceContents (..), + Resource (..), + ResourceTemplate (..), + ResourceReference (..), + ResourceTemplateReference, + + -- * 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 (..), + ElicitationCapability (..), + ExperimentalCapability (..), + + -- * Implementation Info + BaseMetadata (..), + 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 +import JSONRPC (RequestId (..)) +import MCP.Aeson + +{- | The sender or recipient of messages and data in a conversation. + +This is used to identify whether content comes from the user or the assistant +in prompt messages and sampling requests. +-} +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. + +Used in paginated requests to indicate the starting position for the next +set of results. If provided, the server should return results starting +after this cursor. +-} +newtype Cursor = Cursor Text + deriving stock (Show, Eq) + deriving newtype (ToJSON, FromJSON) + +{- | A progress token, used to associate progress notifications with the original request. + +If specified in a request, the caller is requesting out-of-band progress +notifications (as represented by notifications/progress). The value is an +opaque token that will be attached to any subsequent notifications. +The receiver is not obligated to provide these notifications. +-} +newtype ProgressToken = ProgressToken Value + deriving stock (Show, Eq) + deriving newtype (ToJSON, FromJSON) + +{- | The severity of a log message. + +These map to syslog message severities, as specified in RFC-5424: +https://datatracker.ietf.org/doc/html/rfc5424#section-6.2.1 +-} +data LoggingLevel + = Emergency + | Alert + | Critical + | Error + | Warning + | Notice + | Info + | Debug + deriving stock (Show, Ord, Eq, Generic) + +instance ToJSON LoggingLevel where + toJSON Emergency = "emergency" + toJSON Alert = "alert" + toJSON Critical = "critical" + toJSON Error = "error" + toJSON Warning = "warning" + toJSON Notice = "notice" + toJSON Info = "info" + toJSON Debug = "debug" + +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. + +The client can use annotations to inform how objects are used or displayed. +-} +data Annotations = Annotations + { audience :: Maybe [Role] + {- ^ Describes who the intended customer of this object or data is. + It can include multiple entries to indicate content useful for + multiple audiences (e.g., ["user", "assistant"]). + -} + , priority :: Maybe Double + {- ^ Describes how important this data is for operating the server. + A value of 1 means "most important," and indicates that the data is + effectively required, while 0 means "least important," and indicates + that the data is entirely optional. Range: 0.0 to 1.0 + -} + , lastModified :: Maybe Text + {- ^ The moment the resource was last modified, as an ISO 8601 formatted string. + Should be an ISO 8601 formatted string (e.g., "2025-01-12T15:00:58Z"). + Examples: last activity timestamp in an open file, timestamp when the resource + was attached, etc. + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''Annotations) + +{- | Metadata for results. + +This result property is reserved by the protocol to allow clients and servers +to attach additional metadata to their responses. +-} +newtype Metadata = Metadata (Map Text Value) + deriving stock (Show, Eq, Generic) + deriving newtype (ToJSON, FromJSON) + +{- | Text provided to or from an LLM. + +This represents textual content that can be sent to or received from +a language model during conversations. +-} +data TextContent = TextContent + { textType :: Text -- Always "text" + , text :: Text + -- ^ The text content of the message. + , annotations :: Maybe Annotations + -- ^ Optional annotations for the client. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +instance ToJSON TextContent where + toJSON (TextContent _ txt anns m) = + object $ + [ "type" .= ("text" :: Text) + , "text" .= txt + ] + <> maybe [] (\a -> ["annotations" .= a]) anns + <> maybe [] (\meta -> ["_meta" .= meta]) m + +instance FromJSON TextContent where + parseJSON = withObject "TextContent" $ \o -> do + ty <- o .: "type" + if ty == ("text" :: Text) + then TextContent ty <$> o .: "text" <*> o .:? "annotations" <*> o .:? "_meta" + else fail "Expected type 'text'" + +{- | An image provided to or from an LLM. + +Represents image data that can be included in messages to language models +that support multimodal input. +-} +data ImageContent = ImageContent + { imageType :: Text -- Always "image" + , data' :: Text + -- ^ The base64-encoded image data. + , mimeType :: Text + -- ^ The MIME type of the image. Different providers may support different image types. + , annotations :: Maybe Annotations + -- ^ Optional annotations for the client. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +instance ToJSON ImageContent where + toJSON (ImageContent _ dat mime anns m) = + object $ + [ "type" .= ("image" :: Text) + , "data" .= dat + , "mimeType" .= mime + ] + <> maybe [] (\a -> ["annotations" .= a]) anns + <> maybe [] (\meta -> ["_meta" .= meta]) m + +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" <*> o .:? "_meta" + else fail "Expected type 'image'" + +{- | Audio provided to or from an LLM. + +Represents audio data that can be included in messages to language models +that support audio input. +-} +data AudioContent = AudioContent + { audioType :: Text -- Always "audio" + , data' :: Text + -- ^ The base64-encoded audio data. + , mimeType :: Text + -- ^ The MIME type of the audio. Different providers may support different audio types. + , annotations :: Maybe Annotations + -- ^ Optional annotations for the client. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +instance ToJSON AudioContent where + toJSON (AudioContent _ dat mime anns m) = + object $ + [ "type" .= ("audio" :: Text) + , "data" .= dat + , "mimeType" .= mime + ] + <> maybe [] (\a -> ["annotations" .= a]) anns + <> maybe [] (\meta -> ["_meta" .= meta]) m + +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" <*> o .:? "_meta" + else fail "Expected type 'audio'" + +{- | Text resource contents. + +Represents the contents of a resource that can be represented as text +(not binary data). +-} +data TextResourceContents = TextResourceContents + { uri :: Text + -- ^ The URI of this resource. + , text :: Text + {- ^ The text of the item. This must only be set if the item can + actually be represented as text (not binary data). + -} + , mimeType :: Maybe Text + -- ^ The MIME type of this resource, if known. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +$( deriveJSON + mcpParseOpts + ''TextResourceContents + ) + +{- | Blob resource contents. + +Represents the contents of a resource as binary data, encoded in base64. +-} +data BlobResourceContents = BlobResourceContents + { uri :: Text + -- ^ The URI of this resource. + , blob :: Text + -- ^ A base64-encoded string representing the binary data of the item. + , mimeType :: Maybe Text + -- ^ The MIME type of this resource, if known. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +$( deriveJSON + mcpParseOpts + ''BlobResourceContents + ) + +{- | The contents of a specific resource or sub-resource. + +A resource can contain either text or binary data. +-} +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. + +It is up to the client how best to render embedded resources for the benefit +of the LLM and/or the user. +-} +data EmbeddedResource = EmbeddedResource + { resourceType :: Text -- Always "resource" + , resource :: ResourceContents + , annotations :: Maybe Annotations + -- ^ Optional annotations for the client. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +instance ToJSON EmbeddedResource where + toJSON (EmbeddedResource _ res anns m) = + object $ + [ "type" .= ("resource" :: Text) + , "resource" .= res + ] + <> maybe [] (\a -> ["annotations" .= a]) anns + <> maybe [] (\meta -> ["_meta" .= meta]) m + +instance FromJSON EmbeddedResource where + parseJSON = withObject "EmbeddedResource" $ \o -> do + ty <- o .: "type" + if ty == ("resource" :: Text) + then EmbeddedResource ty <$> o .: "resource" <*> o .:? "annotations" <*> o .:? "_meta" + else fail "Expected type 'resource'" + +{- | A resource that the server is capable of reading, included in a prompt or tool call result. + +Note: resource links returned by tools are not guaranteed to appear in the results of `resources/list` requests. +-} +data ResourceLink = ResourceLink + { linkType :: Text -- Always "resource_link" + , uri :: Text + -- ^ The URI of this resource. + , name :: Text + -- ^ A human-readable name for this resource. + , title :: Maybe Text + -- ^ Optional title for display purposes. + , description :: Maybe Text + -- ^ A description of what this resource represents. + , mimeType :: Maybe Text + -- ^ The MIME type of this resource, if known. + , size :: Maybe Int + -- ^ The size of the raw resource content, in bytes. + , annotations :: Maybe Annotations + -- ^ Optional annotations for the client. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +instance ToJSON ResourceLink where + toJSON (ResourceLink _ u n t d mt s a m) = + object $ + [ "type" .= ("resource_link" :: Text) + , "uri" .= u + , "name" .= n + ] + <> maybe [] (\ttl -> ["title" .= ttl]) t + <> maybe [] (\desc -> ["description" .= desc]) d + <> maybe [] (\mime -> ["mimeType" .= mime]) mt + <> maybe [] (\sz -> ["size" .= sz]) s + <> maybe [] (\ann -> ["annotations" .= ann]) a + <> maybe [] (\meta -> ["_meta" .= meta]) m + +instance FromJSON ResourceLink where + parseJSON = withObject "ResourceLink" $ \o -> do + ty <- o .: "type" + if ty == ("resource_link" :: Text) + then + ResourceLink ty + <$> o .: "uri" + <*> o .: "name" + <*> o .:? "title" + <*> o .:? "description" + <*> o .:? "mimeType" + <*> o .:? "size" + <*> o .:? "annotations" + <*> o .:? "_meta" + else fail "Expected type 'resource_link'" + +{- | Content that can be text, image, audio, or embedded resource. + +This union type represents the different kinds of content that can be +included in messages, prompts, and tool results. +-} +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) + +{- | ContentBlock union type that includes ResourceLink. + +This is the unified content type used in new schema version. +-} +data ContentBlock + = TextBlock TextContent + | ImageBlock ImageContent + | AudioBlock AudioContent + | ResourceLinkBlock ResourceLink + | EmbeddedResourceBlock EmbeddedResource + deriving stock (Show, Eq, Generic) + +instance ToJSON ContentBlock where + toJSON (TextBlock c) = toJSON c + toJSON (ImageBlock c) = toJSON c + toJSON (AudioBlock c) = toJSON c + toJSON (ResourceLinkBlock c) = toJSON c + toJSON (EmbeddedResourceBlock c) = toJSON c + +instance FromJSON ContentBlock where + parseJSON v = + (TextBlock <$> parseJSON v) + <|> (ImageBlock <$> parseJSON v) + <|> (AudioBlock <$> parseJSON v) + <|> (ResourceLinkBlock <$> parseJSON v) + <|> (EmbeddedResourceBlock <$> parseJSON v) + +{- | A known resource that the server is capable of reading. + +Resources represent files, documents, or other data sources that the +server can provide to clients. +-} +data Resource = Resource + { uri :: Text + -- ^ The URI of this resource. + , name :: Text + {- ^ A human-readable name for this resource. + This can be used by clients to populate UI elements. + -} + , title :: Maybe Text + -- ^ Optional title for display purposes. + , description :: Maybe Text + {- ^ A description of what this resource represents. + This can be used by clients to improve the LLM's understanding + of available resources. It can be thought of like a "hint" to the model. + -} + , mimeType :: Maybe Text + -- ^ The MIME type of this resource, if known. + , size :: Maybe Int + {- ^ The size of the raw resource content, in bytes (i.e., before base64 + encoding or any tokenization), if known. This can be used by Hosts + to display file sizes and estimate context window usage. + -} + , annotations :: Maybe Annotations + -- ^ Optional annotations for the client. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +$( deriveJSON + mcpParseOpts + ''Resource + ) + +{- | A template description for resources available on the server. + +Resource templates allow servers to describe parameterized resources +that can be instantiated with specific values. +-} +data ResourceTemplate = ResourceTemplate + { name :: Text + {- ^ A human-readable name for the type of resource this template refers to. + This can be used by clients to populate UI elements. + -} + , title :: Maybe Text + -- ^ Optional title for display purposes. + , uriTemplate :: Text + -- ^ A URI template (according to RFC 6570) that can be used to construct resource URIs. + , description :: Maybe Text + {- ^ A description of what this template is for. + This can be used by clients to improve the LLM's understanding + of available resources. It can be thought of like a "hint" to the model. + -} + , mimeType :: Maybe Text + {- ^ The MIME type for all resources that match this template. + This should only be included if all resources matching this + template have the same type. + -} + , annotations :: Maybe Annotations + -- ^ Optional annotations for the client. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +$( deriveJSON + mcpParseOpts + ''ResourceTemplate + ) + +{- | A reference to a resource or resource template definition. + +Used in completion requests and other contexts where a resource +needs to be referenced. +-} +data ResourceReference = ResourceReference + { refType :: Text -- Always "ref/resource" + , uri :: Text + -- ^ The URI or URI template of the resource. + } + 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'" + +{- | A reference to a resource template definition. + +This is an alias for ResourceReference in the new schema. +-} +type ResourceTemplateReference = ResourceReference + +{- | Additional properties describing a Tool to clients. + +NOTE: all properties in ToolAnnotations are **hints**. +They are not guaranteed to provide a faithful description of +tool behavior (including descriptive properties like `title`). + +Clients should never make tool use decisions based on ToolAnnotations +received from untrusted servers. +-} +data ToolAnnotations = ToolAnnotations + { title :: Maybe Text + -- ^ A human-readable title for the tool. + , readOnlyHint :: Maybe Bool + -- ^ If true, the tool does not modify its environment. Default: false + , destructiveHint :: Maybe Bool + {- ^ If true, the tool may perform destructive updates to its environment. + If false, the tool performs only additive updates. + (This property is meaningful only when `readOnlyHint == false`) + Default: true + -} + , idempotentHint :: Maybe Bool + {- ^ If true, calling the tool repeatedly with the same arguments + will have no additional effect on its environment. + (This property is meaningful only when `readOnlyHint == false`) + Default: false + -} + , openWorldHint :: Maybe Bool + {- ^ If true, this tool may interact with an "open world" of external + entities. If false, the tool's domain of interaction is closed. + For example, the world of a web search tool is open, whereas that + of a memory tool is not. Default: true + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ToolAnnotations) + +{- | Input schema for a tool. + +A JSON Schema object defining the expected parameters for the 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. + +Tools are functions that the MCP server exposes to clients, +allowing the client to perform specific actions or retrieve information. +-} +data Tool = Tool + { name :: Text + -- ^ The name of the tool. + , title :: Maybe Text + -- ^ Optional title for display purposes. + , description :: Maybe Text + {- ^ A human-readable description of the tool. + This can be used by clients to improve the LLM's understanding + of available tools. It can be thought of like a "hint" to the model. + -} + , inputSchema :: InputSchema + -- ^ A JSON Schema object defining the expected parameters for the tool. + , outputSchema :: Maybe InputSchema + {- ^ An optional JSON Schema object defining the structure of the tool's output + returned in the structuredContent field of a CallToolResult. + -} + , annotations :: Maybe ToolAnnotations + {- ^ Optional additional tool information. + Display name precedence order is: title, annotations.title, then name. + -} + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''Tool) + +{- | Describes an argument that a prompt can accept. + +Prompt arguments allow prompts to be parameterized with user-provided values. +-} +data PromptArgument = PromptArgument + { name :: Text + -- ^ The name of the argument. + , title :: Maybe Text + -- ^ Optional title for display purposes. + , description :: Maybe Text + -- ^ A human-readable description of the argument. + , required :: Maybe Bool + -- ^ Whether this argument must be provided. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''PromptArgument) + +{- | A prompt or prompt template that the server offers. + +Prompts are reusable message templates that can be parameterized +with arguments to generate specific conversations. +-} +data Prompt = Prompt + { name :: Text + -- ^ The name of the prompt or prompt template. + , title :: Maybe Text + -- ^ Optional title for display purposes. + , description :: Maybe Text + -- ^ An optional description of what this prompt provides. + , arguments :: Maybe [PromptArgument] + -- ^ A list of arguments to use for templating the prompt. + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''Prompt) + +{- | Describes a message returned as part of a prompt. + +This is similar to `SamplingMessage`, but also supports the embedding of +resources from the MCP server. +-} +data PromptMessage = PromptMessage + { role :: Role + , content :: ContentBlock + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''PromptMessage) + +{- | Identifies a prompt. + +Used in completion requests and other contexts where a prompt +needs to be referenced. +-} +data PromptReference = PromptReference + { refType :: Text -- Always "ref/prompt" + , name :: Text + -- ^ The name of the prompt or prompt template. + , title :: Maybe Text + -- ^ Optional title for display purposes. + } + deriving stock (Show, Eq, Generic) + +instance ToJSON PromptReference where + toJSON (PromptReference _ n t) = + object $ + [ "type" .= ("ref/prompt" :: Text) + , "name" .= n + ] + <> maybe [] (\ttl -> ["title" .= ttl]) t + +instance FromJSON PromptReference where + parseJSON = withObject "PromptReference" $ \o -> do + ty <- o .: "type" + if ty == ("ref/prompt" :: Text) + then PromptReference ty <$> o .: "name" <*> o .:? "title" + else fail "Expected type 'ref/prompt'" + +{- | Hints to use for model selection. + +Keys not declared here are currently left unspecified by the spec and are up +to the client to interpret. +-} +data ModelHint where + ModelHint :: + { name :: Maybe Text + {- ^ A hint for a model name. + The client SHOULD treat this as a substring of a model name; for example: + - `claude-3-5-sonnet` should match `claude-3-5-sonnet-20241022` + - `sonnet` should match `claude-3-5-sonnet-20241022`, `claude-3-sonnet-20240229`, etc. + - `claude` should match any Claude model + The client MAY also map the string to a different provider's model name + or a different model family, as long as it fills a similar niche. + -} + } -> + ModelHint + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ModelHint) + +{- | The server's preferences for model selection, requested of the client during sampling. + +Because LLMs can vary along multiple dimensions, choosing the "best" model is +rarely straightforward. Different models excel in different areas—some are +faster but less capable, others are more capable but more expensive, and so +on. This interface allows servers to express their priorities across multiple +dimensions to help clients make an appropriate selection for their use case. + +These preferences are always advisory. The client MAY ignore them. It is also +up to the client to decide how to interpret these preferences and how to +balance them against other considerations. +-} +data ModelPreferences = ModelPreferences + { hints :: Maybe [ModelHint] + {- ^ Optional hints to use for model selection. + If multiple hints are specified, the client MUST evaluate them in order + (such that the first match is taken). + The client SHOULD prioritize these hints over the numeric priorities, but + MAY still use the priorities to select from ambiguous matches. + -} + , costPriority :: Maybe Double + {- ^ How much to prioritize cost when selecting a model. A value of 0 means cost + is not important, while a value of 1 means cost is the most important + factor. Range: 0.0 to 1.0 + -} + , speedPriority :: Maybe Double + {- ^ How much to prioritize sampling speed (latency) when selecting a model. A + value of 0 means speed is not important, while a value of 1 means speed is + the most important factor. Range: 0.0 to 1.0 + -} + , intelligencePriority :: Maybe Double + {- ^ How much to prioritize intelligence and capabilities when selecting a + model. A value of 0 means intelligence is not important, while a value of 1 + means intelligence is the most important factor. Range: 0.0 to 1.0 + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ModelPreferences) + +{- | Include context options for sampling. + +A request to include context from one or more MCP servers (including the caller), +to be attached to the prompt. The client MAY ignore this request. +-} +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. + +Used in sampling requests to represent the conversation history +that should be sent to the language model. +-} +data SamplingMessage = SamplingMessage + { role :: Role + , content :: Content + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''SamplingMessage) + +{- | Client capability for root directory management. + +Present if the client supports listing roots (directories or files +that the server can operate on). +-} +data RootsCapability where + RootsCapability :: + { listChanged :: Maybe Bool + -- ^ Whether the client supports notifications for changes to the roots list. + } -> + RootsCapability + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''RootsCapability) + +{- | Server capability for prompt management. + +Present if the server offers any prompt templates. +-} +data PromptsCapability where + PromptsCapability :: + { listChanged :: Maybe Bool + -- ^ Whether this server supports notifications for changes to the prompt list. + } -> + PromptsCapability + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''PromptsCapability) + +{- | Server capability for resource management. + +Present if the server offers any resources to read. +-} +data ResourcesCapability = ResourcesCapability + { listChanged :: Maybe Bool + -- ^ Whether this server supports notifications for changes to the resource list. + , subscribe :: Maybe Bool + -- ^ Whether this server supports subscribing to resource updates. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ResourcesCapability) + +{- | Server capability for tool management. + +Present if the server offers any tools to call. +-} +data ToolsCapability where + ToolsCapability :: + { listChanged :: Maybe Bool + -- ^ Whether this server supports notifications for changes to the tool list. + } -> + ToolsCapability + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ToolsCapability) + +{- | Server capability for argument autocompletion. + +Present if the server supports argument autocompletion suggestions. +-} +data CompletionsCapability = CompletionsCapability + deriving stock (Show, Eq, Generic) + +instance ToJSON CompletionsCapability where + toJSON _ = object [] + +instance FromJSON CompletionsCapability where + parseJSON = withObject "CompletionsCapability" $ \_ -> pure CompletionsCapability + +{- | Server capability for logging. + +Present if the server supports sending log messages to the client. +-} +data LoggingCapability = LoggingCapability + deriving stock (Show, Eq, Generic) + +instance ToJSON LoggingCapability where + toJSON _ = object [] + +instance FromJSON LoggingCapability where + parseJSON = withObject "LoggingCapability" $ \_ -> pure LoggingCapability + +{- | Client capability for LLM sampling. + +Present if the client supports sampling from an LLM. +-} +data SamplingCapability = SamplingCapability + deriving stock (Show, Eq, Generic) + +instance ToJSON SamplingCapability where + toJSON _ = object [] + +instance FromJSON SamplingCapability where + parseJSON = withObject "SamplingCapability" $ \_ -> pure SamplingCapability + +{- | Experimental, non-standard capabilities. + +Experimental capabilities that the client or server supports. +This is not a closed set: any client or server can define its own, +additional capabilities. +-} +newtype ExperimentalCapability = ExperimentalCapability (Map Text Value) + deriving stock (Show, Eq, Generic) + deriving newtype (ToJSON, FromJSON) + +{- | Client capability for elicitation. + +Present if the client supports elicitation from the server. +-} +data ElicitationCapability = ElicitationCapability + deriving stock (Show, Eq, Generic) + +instance ToJSON ElicitationCapability where + toJSON _ = object [] + +instance FromJSON ElicitationCapability where + parseJSON = withObject "ElicitationCapability" $ \_ -> pure ElicitationCapability + +{- | Capabilities a client may support. + +Known capabilities are defined here, in this schema, but this is not a closed set: +any client can define its own, additional capabilities. +-} +data ClientCapabilities = ClientCapabilities + { roots :: Maybe RootsCapability + -- ^ Present if the client supports listing roots. + , sampling :: Maybe SamplingCapability + -- ^ Present if the client supports sampling from an LLM. + , elicitation :: Maybe ElicitationCapability + -- ^ Present if the client supports elicitation from the server. + , experimental :: Maybe ExperimentalCapability + -- ^ Experimental, non-standard capabilities that the client supports. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ClientCapabilities) + +{- | Capabilities that a server may support. + +Known capabilities are defined here, in this schema, but this is not a closed set: +any server can define its own, additional capabilities. +-} +data ServerCapabilities = ServerCapabilities + { logging :: Maybe LoggingCapability + -- ^ Present if the server supports sending log messages to the client. + , prompts :: Maybe PromptsCapability + -- ^ Present if the server offers any prompt templates. + , resources :: Maybe ResourcesCapability + -- ^ Present if the server offers any resources to read. + , tools :: Maybe ToolsCapability + -- ^ Present if the server offers any tools to call. + , completions :: Maybe CompletionsCapability + -- ^ Present if the server supports argument autocompletion suggestions. + , experimental :: Maybe ExperimentalCapability + -- ^ Experimental, non-standard capabilities that the server supports. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''ServerCapabilities) + +{- | Base interface for metadata with name (identifier) and title (display name) properties. + +This is the base type for various entities that need both programmatic +identifiers and human-readable names. +-} +data BaseMetadata = BaseMetadata + { name :: Text + {- ^ Intended for programmatic or logical use, but used as a display name in past specs + or fallback (if title isn't present). + -} + , title :: Maybe Text + {- ^ Intended for UI and end-user contexts — optimized to be human-readable and easily understood, + even by those unfamiliar with domain-specific terminology. + If not provided, the name should be used for display (except for Tool, + where `annotations.title` should be given precedence over using `name`, + if present). + -} + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''BaseMetadata) + +{- | Describes the name and version of an MCP implementation. + +Used to identify the client or server software in initialization. +-} +data Implementation = Implementation + { name :: Text + , version :: Text + , title :: Maybe Text + -- ^ Optional title for UI representation. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''Implementation) + +{- | Represents a root directory or file that the server can operate on. + +Roots allow servers to ask for specific directories or files to operate on. +A common example for roots is providing a set of repositories or directories +a server should operate on. +-} +data Root = Root + { uri :: Text + {- ^ The URI identifying the root. This *must* start with file:// for now. + This restriction may be relaxed in future versions of the protocol to allow + other URI schemes. + -} + , name :: Maybe Text + {- ^ An optional name for the root. This can be used to provide a human-readable + identifier for the root, which may be useful for display purposes or for + referencing the root in other parts of the application. + -} + , _meta :: Maybe Metadata + -- ^ Optional metadata field. + } + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''Root) + +{- | Base result type. + +All MCP result types include optional metadata that can be used +to attach additional information to responses. +-} +data Result where + Result :: + { _meta :: Maybe Metadata + {- ^ This result property is reserved by the protocol to allow clients and servers + to attach additional metadata to their responses. + -} + } -> + Result + deriving stock (Show, Eq, Generic) + +$(deriveJSON mcpParseOpts ''Result) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,494 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.Aeson hiding (Error, Result) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as Map +import Data.Maybe (isNothing) +import JSONRPC () +import MCP.Protocol +import MCP.Types +import Test.Hspec +import Prelude hiding (error, id, minimum, maximum) +import Prelude qualified + +-- | Helper to extract a JSON Object, failing on non-objects. +asObject :: Value -> KM.KeyMap Value +asObject (Object o) = o +asObject _ = Prelude.error "expected object" + +main :: IO () +main = hspec $ do + -- ----------------------------------------------------------------- + -- MCP.Types + -- ----------------------------------------------------------------- + describe "MCP.Types" $ do + describe "Role" $ do + it "serialises User as \"user\"" $ + toJSON User `shouldBe` String "user" + it "serialises Assistant as \"assistant\"" $ + toJSON Assistant `shouldBe` String "assistant" + it "round-trips User" $ + decode (encode User) `shouldBe` Just User + it "round-trips Assistant" $ + decode (encode Assistant) `shouldBe` Just Assistant + it "rejects unknown role" $ + (decode "\"admin\"" :: Maybe Role) `shouldBe` Nothing + + describe "LoggingLevel" $ do + it "round-trips all levels" $ do + let levels = [Emergency, Alert, Critical, Error, Warning, Notice, Info, Debug] + mapM_ (\l -> decode (encode l) `shouldBe` Just l) levels + it "preserves ordering" $ + Emergency < Debug `shouldBe` True + it "serialises Debug as \"debug\"" $ + toJSON Debug `shouldBe` String "debug" + + describe "Cursor" $ do + it "round-trips" $ do + let c = Cursor "abc123" + decode (encode c) `shouldBe` Just c + + describe "ProgressToken" $ do + it "round-trips a string token" $ do + let t = ProgressToken (String "tok-1") + decode (encode t) `shouldBe` Just t + it "round-trips a numeric token" $ do + let t = ProgressToken (Number 42) + decode (encode t) `shouldBe` Just t + + describe "Annotations" $ do + it "round-trips with all fields" $ do + let ann = Annotations (Just [User, Assistant]) (Just 0.8) (Just "2025-01-12T15:00:58Z") + decode (encode ann) `shouldBe` Just ann + it "omits Nothing fields" $ do + let ann = Annotations Nothing Nothing Nothing + obj = asObject (toJSON ann) + KM.member "audience" obj `shouldBe` False + KM.member "priority" obj `shouldBe` False + + describe "TextContent" $ do + it "round-trips" $ do + let tc = TextContent "text" "hello" Nothing Nothing + decode (encode tc) `shouldBe` Just tc + it "serialises type as \"text\"" $ do + let tc = TextContent "text" "hello" Nothing Nothing + obj = asObject (toJSON tc) + KM.lookup "type" obj `shouldBe` Just (String "text") + it "rejects wrong type tag" $ + (decode "{\"type\":\"image\",\"text\":\"x\"}" :: Maybe TextContent) `shouldBe` Nothing + + describe "ImageContent" $ do + it "round-trips" $ do + let ic = ImageContent "image" "base64data" "image/png" Nothing Nothing + decode (encode ic) `shouldBe` Just ic + it "serialises data field (not data')" $ do + let ic = ImageContent "image" "base64data" "image/png" Nothing Nothing + obj = asObject (toJSON ic) + KM.member "data" obj `shouldBe` True + KM.member "data'" obj `shouldBe` False + + describe "AudioContent" $ do + it "round-trips" $ do + let ac = AudioContent "audio" "base64audio" "audio/wav" Nothing Nothing + decode (encode ac) `shouldBe` Just ac + + describe "ResourceContents" $ do + it "round-trips TextResource" $ do + let rc = TextResource (TextResourceContents "file:///a.txt" "contents" (Just "text/plain") Nothing) + decode (encode rc) `shouldBe` Just rc + it "round-trips BlobResource" $ do + let rc = BlobResource (BlobResourceContents "file:///b.bin" "AQID" (Just "application/octet-stream") Nothing) + decode (encode rc) `shouldBe` Just rc + + describe "EmbeddedResource" $ do + it "round-trips" $ do + let er = EmbeddedResource "resource" (TextResource (TextResourceContents "uri" "txt" Nothing Nothing)) Nothing Nothing + decode (encode er) `shouldBe` Just er + it "rejects wrong type tag" $ + (decode "{\"type\":\"text\",\"resource\":{}}" :: Maybe EmbeddedResource) `shouldBe` Nothing + + describe "ResourceLink" $ do + it "round-trips with minimal fields" $ do + let rl = ResourceLink "resource_link" "file:///x" "myfile" Nothing Nothing Nothing Nothing Nothing Nothing + decode (encode rl) `shouldBe` Just rl + it "round-trips with all fields" $ do + let ann = Annotations (Just [User]) Nothing Nothing + rl = ResourceLink "resource_link" "file:///x" "myfile" (Just "My File") (Just "A file") (Just "text/plain") (Just 1024) (Just ann) Nothing + decode (encode rl) `shouldBe` Just rl + + describe "Content (union)" $ do + it "parses text content" $ do + let js = "{\"type\":\"text\",\"text\":\"hello\"}" + case decode js :: Maybe Content of + Just (TextContentType _) -> pure () + other -> expectationFailure $ "Expected TextContentType, got: " <> show other + it "parses image content" $ do + let js = "{\"type\":\"image\",\"data\":\"abc\",\"mimeType\":\"image/png\"}" + case decode js :: Maybe Content of + Just (ImageContentType _) -> pure () + other -> expectationFailure $ "Expected ImageContentType, got: " <> show other + + describe "ContentBlock (union)" $ do + it "parses resource_link as ResourceLinkBlock" $ do + let js = "{\"type\":\"resource_link\",\"uri\":\"file:///x\",\"name\":\"f\"}" + case decode js :: Maybe ContentBlock of + Just (ResourceLinkBlock _) -> pure () + other -> expectationFailure $ "Expected ResourceLinkBlock, got: " <> show other + + describe "Resource" $ do + it "round-trips with minimal fields" $ do + let r = Resource "file:///a" "a" Nothing Nothing Nothing Nothing Nothing Nothing + decode (encode r) `shouldBe` Just r + it "omits Nothing fields" $ do + let r = Resource "file:///a" "a" Nothing Nothing Nothing Nothing Nothing Nothing + obj = asObject (toJSON r) + KM.member "description" obj `shouldBe` False + KM.member "mimeType" obj `shouldBe` False + + describe "ResourceTemplate" $ do + it "round-trips" $ do + let rt = ResourceTemplate "tmpl" Nothing "file:///{path}" Nothing Nothing Nothing Nothing + decode (encode rt) `shouldBe` Just rt + + describe "ResourceReference" $ do + it "serialises type as \"ref/resource\"" $ do + let rr = ResourceReference "ref/resource" "file:///a" + obj = asObject (toJSON rr) + KM.lookup "type" obj `shouldBe` Just (String "ref/resource") + it "round-trips" $ do + let rr = ResourceReference "ref/resource" "file:///a" + decode (encode rr) `shouldBe` Just rr + it "rejects wrong type" $ + (decode "{\"type\":\"ref/prompt\",\"uri\":\"x\"}" :: Maybe ResourceReference) `shouldBe` Nothing + + describe "Tool" $ do + it "round-trips" $ do + let sch = InputSchema "object" (Just (Map.fromList [("x", object ["type" .= ("integer" :: String)])])) (Just ["x"]) + t = Tool "add" Nothing (Just "Add numbers") sch Nothing Nothing Nothing + decode (encode t) `shouldBe` Just t + + describe "InputSchema" $ do + it "serialises type as \"object\"" $ do + let s = InputSchema "object" Nothing Nothing + obj = asObject (toJSON s) + KM.lookup "type" obj `shouldBe` Just (String "object") + it "round-trips with properties" $ do + let s = InputSchema "object" (Just (Map.singleton "a" (String "test"))) (Just ["a"]) + decode (encode s) `shouldBe` Just s + + describe "Prompt" $ do + it "round-trips" $ do + let p = Prompt "greet" Nothing (Just "A greeting") (Just [PromptArgument "name" Nothing Nothing (Just True)]) Nothing + decode (encode p) `shouldBe` Just p + + describe "PromptReference" $ do + it "serialises type as \"ref/prompt\"" $ do + let pr = PromptReference "ref/prompt" "greet" Nothing + obj = asObject (toJSON pr) + KM.lookup "type" obj `shouldBe` Just (String "ref/prompt") + it "round-trips" $ do + let pr = PromptReference "ref/prompt" "greet" (Just "Greeting") + decode (encode pr) `shouldBe` Just pr + + describe "IncludeContext" $ do + it "round-trips AllServers" $ + decode (encode AllServers) `shouldBe` Just AllServers + it "round-trips None" $ + decode (encode None) `shouldBe` Just None + it "round-trips ThisServer" $ + decode (encode ThisServer) `shouldBe` Just ThisServer + + describe "ModelHint" $ do + it "round-trips" $ do + let h = ModelHint (Just "claude-3-5-sonnet") + decode (encode h) `shouldBe` Just h + + describe "ModelPreferences" $ do + it "round-trips" $ do + let mp = ModelPreferences (Just [ModelHint (Just "sonnet")]) (Just 0.5) (Just 0.8) (Just 0.9) + decode (encode mp) `shouldBe` Just mp + + describe "Capabilities" $ do + it "round-trips ClientCapabilities" $ do + let cc = ClientCapabilities (Just (RootsCapability (Just True))) (Just SamplingCapability) Nothing Nothing + decode (encode cc) `shouldBe` Just cc + it "round-trips ServerCapabilities" $ do + let sc = ServerCapabilities (Just LoggingCapability) (Just (PromptsCapability (Just True))) Nothing (Just (ToolsCapability Nothing)) (Just CompletionsCapability) Nothing + decode (encode sc) `shouldBe` Just sc + it "empty capabilities round-trip" $ do + let cc = ClientCapabilities Nothing Nothing Nothing Nothing + decode (encode cc) `shouldBe` Just cc + + describe "Implementation" $ do + it "round-trips" $ do + let impl = Implementation "test-server" "1.0.0" (Just "Test Server") + decode (encode impl) `shouldBe` Just impl + it "omits Nothing title" $ do + let impl = Implementation "srv" "0.1" Nothing + obj = asObject (toJSON impl) + KM.member "title" obj `shouldBe` False + + describe "Root" $ do + it "round-trips" $ do + let r = Root "file:///home/user" (Just "Home") Nothing + decode (encode r) `shouldBe` Just r + + describe "Result" $ do + it "round-trips with no metadata" $ do + let r = Result Nothing + decode (encode r) `shouldBe` Just r + it "round-trips with metadata" $ do + let m = Metadata (Map.singleton "key" (String "val")) + r = Result (Just m) + decode (encode r) `shouldBe` Just r + + -- ----------------------------------------------------------------- + -- MCP.Protocol + -- ----------------------------------------------------------------- + describe "MCP.Protocol" $ do + describe "pROTOCOL_VERSION" $ do + it "is \"2025-06-18\"" $ + pROTOCOL_VERSION `shouldBe` "2025-06-18" + + describe "InitializeRequest" $ do + it "round-trips" $ do + let initParams = InitializeParams "2025-06-18" (ClientCapabilities Nothing Nothing Nothing Nothing) (Implementation "client" "1.0" Nothing) + initReq = InitializeRequest (RequestId (Number 1)) initParams + decode (encode initReq) `shouldBe` Just initReq + it "serialises with method \"initialize\"" $ do + let initParams = InitializeParams "2025-06-18" (ClientCapabilities Nothing Nothing Nothing Nothing) (Implementation "c" "1" Nothing) + initReq = InitializeRequest (RequestId (Number 1)) initParams + obj = asObject (toJSON initReq) + KM.lookup "method" obj `shouldBe` Just (String "initialize") + + describe "PingRequest" $ do + it "round-trips" $ do + let pingReq = PingRequest (RequestId (Number 2)) Nothing + decode (encode pingReq) `shouldBe` Just pingReq + it "has method \"ping\"" $ do + let obj = asObject (toJSON (PingRequest (RequestId (Number 1)) Nothing)) + KM.lookup "method" obj `shouldBe` Just (String "ping") + + describe "ListToolsRequest" $ do + it "has method \"tools/list\"" $ do + let obj = asObject (toJSON (ListToolsRequest (RequestId (Number 1)) Nothing)) + KM.lookup "method" obj `shouldBe` Just (String "tools/list") + + describe "CallToolRequest" $ do + it "round-trips" $ do + let callParams = CallToolParams "add" (Just (Map.fromList [("a", Number 1), ("b", Number 2)])) + callReq = CallToolRequest (RequestId (Number 3)) callParams + decode (encode callReq) `shouldBe` Just callReq + it "has method \"tools/call\"" $ do + let callParams = CallToolParams "echo" Nothing + obj = asObject (toJSON (CallToolRequest (RequestId (Number 1)) callParams)) + KM.lookup "method" obj `shouldBe` Just (String "tools/call") + + describe "ListResourcesRequest" $ do + it "has method \"resources/list\"" $ do + let obj = asObject (toJSON (ListResourcesRequest (RequestId (Number 1)) Nothing)) + KM.lookup "method" obj `shouldBe` Just (String "resources/list") + + describe "ReadResourceRequest" $ do + it "round-trips" $ do + let readReq = ReadResourceRequest (RequestId (Number 4)) (ReadResourceParams "file:///a.txt") + decode (encode readReq) `shouldBe` Just readReq + + describe "ListPromptsRequest" $ do + it "has method \"prompts/list\"" $ do + let obj = asObject (toJSON (ListPromptsRequest (RequestId (Number 1)) Nothing)) + KM.lookup "method" obj `shouldBe` Just (String "prompts/list") + + describe "GetPromptRequest" $ do + it "round-trips" $ do + let gpParams = GetPromptParams "greet" (Just (Map.singleton "name" "Alice")) + gpReq = GetPromptRequest (RequestId (Number 5)) gpParams + decode (encode gpReq) `shouldBe` Just gpReq + + describe "SetLevelRequest" $ do + it "round-trips" $ do + let slReq = SetLevelRequest (RequestId (Number 6)) (SetLevelParams Warning) + decode (encode slReq) `shouldBe` Just slReq + + describe "CompleteRequest" $ do + it "round-trips" $ do + let compParams = CompleteParams (PromptRef (PromptReference "ref/prompt" "greet" Nothing)) (CompletionArgument "name" "Al") Nothing + compReq = CompleteRequest (RequestId (Number 7)) compParams + decode (encode compReq) `shouldBe` Just compReq + + describe "Response types" $ do + it "InitializeResult round-trips" $ do + let sc = ServerCapabilities Nothing Nothing Nothing (Just (ToolsCapability Nothing)) Nothing Nothing + res = InitializeResult "2025-06-18" sc (Implementation "srv" "1.0" Nothing) (Just "Use tools") Nothing + decode (encode res) `shouldBe` Just res + + it "ListToolsResult round-trips" $ do + let sch = InputSchema "object" Nothing Nothing + t = Tool "echo" Nothing (Just "Echo back") sch Nothing Nothing Nothing + res = ListToolsResult [t] Nothing Nothing + decode (encode res) `shouldBe` Just res + + it "CallToolResult round-trips" $ do + let res = CallToolResult [TextBlock (TextContent "text" "ok" Nothing Nothing)] Nothing Nothing Nothing + decode (encode res) `shouldBe` Just res + + it "CallToolResult with isError round-trips" $ do + let res = CallToolResult [TextBlock (TextContent "text" "fail" Nothing Nothing)] Nothing (Just True) Nothing + decode (encode res) `shouldBe` Just res + + it "ListResourcesResult round-trips" $ do + let r = Resource "file:///a" "a" Nothing Nothing Nothing Nothing Nothing Nothing + res = ListResourcesResult [r] Nothing Nothing + decode (encode res) `shouldBe` Just res + + it "ReadResourceResult round-trips" $ do + let rc = TextResource (TextResourceContents "file:///a" "hello" Nothing Nothing) + res = ReadResourceResult [rc] Nothing + decode (encode res) `shouldBe` Just res + + it "CompleteResult round-trips" $ do + let cr = CompletionResult ["Alice", "Alex"] (Just 2) Nothing + res = CompleteResult cr Nothing + decode (encode res) `shouldBe` Just res + + it "GetPromptResult round-trips" $ do + let pm = PromptMessage User (TextBlock (TextContent "text" "Hello!" Nothing Nothing)) + res = GetPromptResult (Just "A prompt") [pm] Nothing + decode (encode res) `shouldBe` Just res + + describe "Notification types" $ do + it "InitializedNotification round-trips" $ do + let n = InitializedNotification Nothing + decode (encode n) `shouldBe` Just n + it "InitializedNotification has correct method" $ do + let obj = asObject (toJSON (InitializedNotification Nothing)) + KM.lookup "method" obj `shouldBe` Just (String "notifications/initialized") + + it "CancelledNotification round-trips" $ do + let n = CancelledNotification (CancelledParams (RequestId (Number 5)) (Just "no longer needed")) + decode (encode n) `shouldBe` Just n + + it "ProgressNotification round-trips" $ do + let n = ProgressNotification (ProgressParams (ProgressToken (String "tok-1")) 0.5 (Just 1.0) (Just "halfway")) + decode (encode n) `shouldBe` Just n + + it "LoggingMessageNotification round-trips" $ do + let n = LoggingMessageNotification (LoggingMessageParams Info (String "server started") (Just "main")) + decode (encode n) `shouldBe` Just n + + it "ResourceUpdatedNotification round-trips" $ do + let n = ResourceUpdatedNotification (ResourceUpdatedParams "file:///a.txt") + decode (encode n) `shouldBe` Just n + + describe "ClientRequest (union)" $ do + it "parses an initialize request" $ do + let initParams = InitializeParams "2025-06-18" (ClientCapabilities Nothing Nothing Nothing Nothing) (Implementation "c" "1" Nothing) + initReq = InitializeReq (InitializeRequest (RequestId (Number 1)) initParams) + case decode (encode initReq) :: Maybe ClientRequest of + Just (InitializeReq _) -> pure () + other -> expectationFailure $ "Expected InitializeReq, got: " <> show other + + it "parses a ping request" $ do + let pingReq = PingReq (PingRequest (RequestId (Number 2)) Nothing) + case decode (encode pingReq) :: Maybe ClientRequest of + Just (PingReq _) -> pure () + other -> expectationFailure $ "Expected PingReq, got: " <> show other + + it "parses a tools/call request" $ do + let callReq = CallToolReq (CallToolRequest (RequestId (Number 3)) (CallToolParams "echo" Nothing)) + case decode (encode callReq) :: Maybe ClientRequest of + Just (CallToolReq _) -> pure () + other -> expectationFailure $ "Expected CallToolReq, got: " <> show other + + describe "ClientNotification (union)" $ do + it "parses an initialized notification" $ do + let n = InitializedNotif (InitializedNotification Nothing) + case decode (encode n) :: Maybe ClientNotification of + Just (InitializedNotif _) -> pure () + other -> expectationFailure $ "Expected InitializedNotif, got: " <> show other + + describe "ServerNotification (union)" $ do + it "parses a logging message notification" $ do + let n = LoggingMessageNotif (LoggingMessageNotification (LoggingMessageParams Debug (String "msg") Nothing)) + case decode (encode n) :: Maybe ServerNotification of + Just (LoggingMessageNotif _) -> pure () + other -> expectationFailure $ "Expected LoggingMessageNotif, got: " <> show other + + describe "PrimitiveSchemaDefinition" $ do + it "round-trips StringSchema" $ do + let s = StringSchema "string" (Just "Name") Nothing Nothing (Just 100) (Just "email") + decode (encode s) `shouldBe` Just s + it "round-trips NumberSchema" $ do + let s = NumberSchema "number" Nothing (Just "A number") (Just 0) (Just 100) + decode (encode s) `shouldBe` Just s + it "round-trips integer NumberSchema" $ do + let s = NumberSchema "integer" Nothing Nothing Nothing Nothing + decode (encode s) `shouldBe` Just s + it "round-trips BooleanSchema" $ do + let s = BooleanSchema "boolean" Nothing Nothing (Just True) + decode (encode s) `shouldBe` Just s + it "round-trips EnumSchema" $ do + let s = EnumSchema "string" Nothing Nothing ["a", "b", "c"] (Just ["Alpha", "Beta", "Charlie"]) + decode (encode s) `shouldBe` Just s + + describe "ElicitParams" $ do + it "round-trips" $ do + let sch = Map.singleton "name" (StringSchema "string" (Just "Name") Nothing Nothing Nothing Nothing) + ep = ElicitParams "Enter your name" sch (Just ["name"]) + decode (encode ep) `shouldBe` Just ep + it "wraps schema in object with type and properties" $ do + let sch = Map.singleton "age" (NumberSchema "integer" Nothing Nothing Nothing Nothing) + ep = ElicitParams "Age?" sch Nothing + obj = asObject (toJSON ep) + case KM.lookup "requestedSchema" obj of + Just (Object so) -> do + KM.lookup "type" so `shouldBe` Just (String "object") + KM.member "properties" so `shouldBe` True + other -> expectationFailure $ "Expected requestedSchema object, got: " <> show other + + describe "ElicitResult" $ do + it "round-trips accept with content" $ do + let res = ElicitResult "accept" (Just (Map.singleton "name" (String "Alice"))) Nothing + decode (encode res) `shouldBe` Just res + it "round-trips decline without content" $ do + let res = ElicitResult "decline" Nothing Nothing + decode (encode res) `shouldBe` Just res + + -- ----------------------------------------------------------------- + -- MCP.Aeson + -- ----------------------------------------------------------------- + describe "MCP.Aeson" $ do + describe "omitNothingFields" $ do + it "omits Nothing fields from TH-derived types" $ do + let impl = Implementation "srv" "1.0" Nothing + obj = asObject (toJSON impl) + KM.member "title" obj `shouldBe` False + it "includes Just fields" $ do + let impl = Implementation "srv" "1.0" (Just "Server") + obj = asObject (toJSON impl) + KM.lookup "title" obj `shouldBe` Just (String "Server") + + describe "_meta field" $ do + it "serialises _meta as \"_meta\" (not modified)" $ do + let r = Root "file:///a" Nothing (Just (Metadata (Map.singleton "k" (String "v")))) + obj = asObject (toJSON r) + KM.member "_meta" obj `shouldBe` True + it "omits _meta when Nothing" $ do + let r = Root "file:///a" Nothing Nothing + obj = asObject (toJSON r) + KM.member "_meta" obj `shouldBe` False + it "parses _meta from JSON" $ do + let js = "{\"uri\":\"file:///a\",\"_meta\":{\"k\":\"v\"}}" + case decode js :: Maybe Root of + Just (Root _ _ meta) -> isNothing meta `shouldBe` False + Nothing -> expectationFailure "Failed to parse Root" + + describe "$sel: prefix stripping" $ do + it "strips $sel: prefix for DuplicateRecordFields" $ do + let sch = InputSchema "object" Nothing Nothing + t = Tool "echo" Nothing Nothing sch Nothing Nothing Nothing + obj = asObject (toJSON t) + KM.member "name" obj `shouldBe` True