{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{-|
Module      : Polytropos.MCP
Description : Model Context Protocol (MCP) server integration for Polytropos
Copyright   : (c) 2026 The Polytropos Authors
License     : EUPL-1.2 OR Apache-2.0
Maintainer  : nadia.yvette.chambers@ik.me
Stability   : experimental
Portability : non-portable (GHC extensions)

Model Context Protocol (MCP) tool integration and JSON-RPC dispatch for
@polytropos@ open records and variants.

= Architectural Overview & Rationale

== The MCP Schema Problem
In standard Model Context Protocol server implementations, defining tools requires
tedious manual duplication:
1. Declaring a nominal parameter data type.
2. Deriving or writing an OpenAPI / JSON Schema definition.
3. Writing a parser that inspects the tool name string and runs the appropriate decoder.
4. Writing an error-prone dispatcher branch that invokes the handler.

== The Polytropos Solution
@polytropos-mcp@ collapses this entire pipeline into row types:
* __Tool Schemas:__ A tool's parameters are just an open record row type @r@.
  'recordToTool' reifies @r@ into an OpenAPI schema directly via 'Polytropos.OpenApi'.
* __Tool Call Variant:__ The entire suite of registered tools forms an open sum
  variant @Variant s@, where constructor tags match tool names and constructor
  payloads match parameter rows.
* __\(O(1)\) Dispatch:__ Tool calls are parsed into @Variant s@ and dispatched
  using 'Polytropos.eliminateUniform', compiling to an indirect function call
  jump table without string comparisons or branch cascades.
* __Dynamic Extensibility:__ New tools can be added to the server by simply widening
  the variant with 'Polytropos.widenVariant'.

= When to Use This Module

* When exposing @polytropos@ data pipelines, compilers, or database query engines
  to AI coding assistants (such as Claude, Gemini, or custom agent frameworks)
  via the standard Model Context Protocol.

= Worked Example

> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE OverloadedRecordDot #-}
> {-# LANGUAGE TypeApplications #-}
>
> import Data.Proxy (Proxy (..))
> import Data.Text (Text)
> import Polytropos
> import Polytropos.MCP
>
> -- 1. Define parameter rows for tools:
> type SearchArgs = '["query" ':= Text, "limit" ':= Int]
> type EchoArgs   = '["message" ':= Text]
>
> -- 2. Define the tool registry as an open variant:
> type MyTools = Variant
>   '[ "search" ':= SearchArgs
>    , "echo"   := EchoArgs
>    ]
>
> -- 3. Generate tool manifests with OpenAPI schemas:
> toolList :: [McpTool]
> toolList =
>   [ recordToTool @"search" "Search indexed documents" (Proxy @SearchArgs)
>   , recordToTool @"echo"   "Echo back a message"      (Proxy @EchoArgs)
>   ]
>
> -- 4. Dispatch tool calls using O(1) jump tables:
> handleCall :: MyTools -> IO [McpContent]
> handleCall = eliminateUniform REC
>   { search = \args -> pure [TextContent ("Found hits for: " <> args.query)]
>   , echo   = \args -> pure [TextContent ("Echo: " <> args.message)]
>   }
-}
module Polytropos.MCP
  ( -- * MCP Protocol Data Types
    JsonRpcRequest (..)
  , JsonRpcResponse (..)
  , JsonRpcError (..)
  , McpTool (..)
  , CallToolParams (..)
  , CallToolResult (..)
  , McpContent (..)
  , ServerInfo (..)
  , ServerCapabilities (..)
  , InitializeResult (..)

    -- * Tool Schema Synthesis
  , recordToTool

    -- * Tool Call Parsing & Dispatch
  , toolCallToVariant
  , dispatchToolCall
  , handleJsonRpcMessage
  , runStdioServer
  ) where

import Control.Exception (SomeException, try)
import Data.Aeson
  ( FromJSON (..)
  , ToJSON (..)
  , Value (..)
  , eitherDecode
  , encode
  , fromJSON
  , object
  , withObject
  , (.:)
  , (.:?)
  , (.=)
  )
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Types as Aeson
import qualified Data.ByteString.Char8 as BSC8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBC8
import Data.OpenApi (toSchema)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import System.IO (hFlush, isEOF, stdin, stdout)

import Polytropos (Record, Variant)
import Polytropos.Aeson (AllCtorsFromJSON)
import Polytropos.OpenApi (AllToSchema)

{-------------------------------------------------------------------------------
  MCP Protocol Types
-------------------------------------------------------------------------------}

-- | A JSON-RPC 2.0 request or notification envelope.
data JsonRpcRequest = JsonRpcRequest
  { JsonRpcRequest -> Text
jsonrpcReqVersion :: !Text
  , JsonRpcRequest -> Text
jsonrpcReqMethod  :: !Text
  , JsonRpcRequest -> Maybe Value
jsonrpcReqId      :: !(Maybe Value)
  , JsonRpcRequest -> Maybe Value
jsonrpcReqParams  :: !(Maybe Value)
  } deriving (Int -> JsonRpcRequest -> ShowS
[JsonRpcRequest] -> ShowS
JsonRpcRequest -> String
(Int -> JsonRpcRequest -> ShowS)
-> (JsonRpcRequest -> String)
-> ([JsonRpcRequest] -> ShowS)
-> Show JsonRpcRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonRpcRequest -> ShowS
showsPrec :: Int -> JsonRpcRequest -> ShowS
$cshow :: JsonRpcRequest -> String
show :: JsonRpcRequest -> String
$cshowList :: [JsonRpcRequest] -> ShowS
showList :: [JsonRpcRequest] -> ShowS
Show, JsonRpcRequest -> JsonRpcRequest -> Bool
(JsonRpcRequest -> JsonRpcRequest -> Bool)
-> (JsonRpcRequest -> JsonRpcRequest -> Bool) -> Eq JsonRpcRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JsonRpcRequest -> JsonRpcRequest -> Bool
== :: JsonRpcRequest -> JsonRpcRequest -> Bool
$c/= :: JsonRpcRequest -> JsonRpcRequest -> Bool
/= :: JsonRpcRequest -> JsonRpcRequest -> Bool
Eq, (forall x. JsonRpcRequest -> Rep JsonRpcRequest x)
-> (forall x. Rep JsonRpcRequest x -> JsonRpcRequest)
-> Generic JsonRpcRequest
forall x. Rep JsonRpcRequest x -> JsonRpcRequest
forall x. JsonRpcRequest -> Rep JsonRpcRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JsonRpcRequest -> Rep JsonRpcRequest x
from :: forall x. JsonRpcRequest -> Rep JsonRpcRequest x
$cto :: forall x. Rep JsonRpcRequest x -> JsonRpcRequest
to :: forall x. Rep JsonRpcRequest x -> JsonRpcRequest
Generic)

instance FromJSON JsonRpcRequest where
  parseJSON :: Value -> Parser JsonRpcRequest
parseJSON = String
-> (Object -> Parser JsonRpcRequest)
-> Value
-> Parser JsonRpcRequest
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JsonRpcRequest" ((Object -> Parser JsonRpcRequest)
 -> Value -> Parser JsonRpcRequest)
-> (Object -> Parser JsonRpcRequest)
-> Value
-> Parser JsonRpcRequest
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text -> Text -> Maybe Value -> Maybe Value -> JsonRpcRequest
JsonRpcRequest
      (Text -> Text -> Maybe Value -> Maybe Value -> JsonRpcRequest)
-> Parser Text
-> Parser (Text -> Maybe Value -> Maybe Value -> JsonRpcRequest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"jsonrpc"
      Parser (Text -> Maybe Value -> Maybe Value -> JsonRpcRequest)
-> Parser Text
-> Parser (Maybe Value -> Maybe Value -> JsonRpcRequest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method"
      Parser (Maybe Value -> Maybe Value -> JsonRpcRequest)
-> Parser (Maybe Value) -> Parser (Maybe Value -> JsonRpcRequest)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"id"
      Parser (Maybe Value -> JsonRpcRequest)
-> Parser (Maybe Value) -> Parser JsonRpcRequest
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"params"

-- | A JSON-RPC 2.0 response envelope.
data JsonRpcResponse = JsonRpcResponse
  { JsonRpcResponse -> Text
jsonrpcRespVersion :: !Text
  , JsonRpcResponse -> Maybe Value
jsonrpcRespId      :: !(Maybe Value)
  , JsonRpcResponse -> Maybe Value
jsonrpcRespResult  :: !(Maybe Value)
  , JsonRpcResponse -> Maybe JsonRpcError
jsonrpcRespError   :: !(Maybe JsonRpcError)
  } deriving (Int -> JsonRpcResponse -> ShowS
[JsonRpcResponse] -> ShowS
JsonRpcResponse -> String
(Int -> JsonRpcResponse -> ShowS)
-> (JsonRpcResponse -> String)
-> ([JsonRpcResponse] -> ShowS)
-> Show JsonRpcResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonRpcResponse -> ShowS
showsPrec :: Int -> JsonRpcResponse -> ShowS
$cshow :: JsonRpcResponse -> String
show :: JsonRpcResponse -> String
$cshowList :: [JsonRpcResponse] -> ShowS
showList :: [JsonRpcResponse] -> ShowS
Show, JsonRpcResponse -> JsonRpcResponse -> Bool
(JsonRpcResponse -> JsonRpcResponse -> Bool)
-> (JsonRpcResponse -> JsonRpcResponse -> Bool)
-> Eq JsonRpcResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JsonRpcResponse -> JsonRpcResponse -> Bool
== :: JsonRpcResponse -> JsonRpcResponse -> Bool
$c/= :: JsonRpcResponse -> JsonRpcResponse -> Bool
/= :: JsonRpcResponse -> JsonRpcResponse -> Bool
Eq, (forall x. JsonRpcResponse -> Rep JsonRpcResponse x)
-> (forall x. Rep JsonRpcResponse x -> JsonRpcResponse)
-> Generic JsonRpcResponse
forall x. Rep JsonRpcResponse x -> JsonRpcResponse
forall x. JsonRpcResponse -> Rep JsonRpcResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JsonRpcResponse -> Rep JsonRpcResponse x
from :: forall x. JsonRpcResponse -> Rep JsonRpcResponse x
$cto :: forall x. Rep JsonRpcResponse x -> JsonRpcResponse
to :: forall x. Rep JsonRpcResponse x -> JsonRpcResponse
Generic)

instance ToJSON JsonRpcResponse where
  toJSON :: JsonRpcResponse -> Value
toJSON (JsonRpcResponse Text
v Maybe Value
i Maybe Value
res Maybe JsonRpcError
err) =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Key
"jsonrpc" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
v, Key
"id" Key -> Maybe Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Value
i ]
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Value -> [Pair]) -> Maybe Value -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Value
r -> [Key
"result" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
r]) Maybe Value
res
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (JsonRpcError -> [Pair]) -> Maybe JsonRpcError -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\JsonRpcError
e -> [Key
"error" Key -> JsonRpcError -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JsonRpcError
e]) Maybe JsonRpcError
err

instance FromJSON JsonRpcResponse where
  parseJSON :: Value -> Parser JsonRpcResponse
parseJSON = String
-> (Object -> Parser JsonRpcResponse)
-> Value
-> Parser JsonRpcResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JsonRpcResponse" ((Object -> Parser JsonRpcResponse)
 -> Value -> Parser JsonRpcResponse)
-> (Object -> Parser JsonRpcResponse)
-> Value
-> Parser JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text
-> Maybe Value
-> Maybe Value
-> Maybe JsonRpcError
-> JsonRpcResponse
JsonRpcResponse
      (Text
 -> Maybe Value
 -> Maybe Value
 -> Maybe JsonRpcError
 -> JsonRpcResponse)
-> Parser Text
-> Parser
     (Maybe Value
      -> Maybe Value -> Maybe JsonRpcError -> JsonRpcResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"jsonrpc"
      Parser
  (Maybe Value
   -> Maybe Value -> Maybe JsonRpcError -> JsonRpcResponse)
-> Parser (Maybe Value)
-> Parser (Maybe Value -> Maybe JsonRpcError -> JsonRpcResponse)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"id"
      Parser (Maybe Value -> Maybe JsonRpcError -> JsonRpcResponse)
-> Parser (Maybe Value)
-> Parser (Maybe JsonRpcError -> JsonRpcResponse)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"result"
      Parser (Maybe JsonRpcError -> JsonRpcResponse)
-> Parser (Maybe JsonRpcError) -> Parser JsonRpcResponse
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe JsonRpcError)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error"

-- | A JSON-RPC 2.0 protocol error object.
data JsonRpcError = JsonRpcError
  { JsonRpcError -> Int
jsonrpcErrorCode    :: !Int
  , JsonRpcError -> Text
jsonrpcErrorMessage :: !Text
  , JsonRpcError -> Maybe Value
jsonrpcErrorData    :: !(Maybe Value)
  } deriving (Int -> JsonRpcError -> ShowS
[JsonRpcError] -> ShowS
JsonRpcError -> String
(Int -> JsonRpcError -> ShowS)
-> (JsonRpcError -> String)
-> ([JsonRpcError] -> ShowS)
-> Show JsonRpcError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonRpcError -> ShowS
showsPrec :: Int -> JsonRpcError -> ShowS
$cshow :: JsonRpcError -> String
show :: JsonRpcError -> String
$cshowList :: [JsonRpcError] -> ShowS
showList :: [JsonRpcError] -> ShowS
Show, JsonRpcError -> JsonRpcError -> Bool
(JsonRpcError -> JsonRpcError -> Bool)
-> (JsonRpcError -> JsonRpcError -> Bool) -> Eq JsonRpcError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JsonRpcError -> JsonRpcError -> Bool
== :: JsonRpcError -> JsonRpcError -> Bool
$c/= :: JsonRpcError -> JsonRpcError -> Bool
/= :: JsonRpcError -> JsonRpcError -> Bool
Eq, (forall x. JsonRpcError -> Rep JsonRpcError x)
-> (forall x. Rep JsonRpcError x -> JsonRpcError)
-> Generic JsonRpcError
forall x. Rep JsonRpcError x -> JsonRpcError
forall x. JsonRpcError -> Rep JsonRpcError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JsonRpcError -> Rep JsonRpcError x
from :: forall x. JsonRpcError -> Rep JsonRpcError x
$cto :: forall x. Rep JsonRpcError x -> JsonRpcError
to :: forall x. Rep JsonRpcError x -> JsonRpcError
Generic)

instance ToJSON JsonRpcError where
  toJSON :: JsonRpcError -> Value
toJSON (JsonRpcError Int
c Text
m Maybe Value
d) =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Key
"code" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
c, Key
"message" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
m ]
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Value -> [Pair]) -> Maybe Value -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Value
x -> [Key
"data" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
x]) Maybe Value
d

instance FromJSON JsonRpcError where
  parseJSON :: Value -> Parser JsonRpcError
parseJSON = String
-> (Object -> Parser JsonRpcError) -> Value -> Parser JsonRpcError
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JsonRpcError" ((Object -> Parser JsonRpcError) -> Value -> Parser JsonRpcError)
-> (Object -> Parser JsonRpcError) -> Value -> Parser JsonRpcError
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Int -> Text -> Maybe Value -> JsonRpcError
JsonRpcError
      (Int -> Text -> Maybe Value -> JsonRpcError)
-> Parser Int -> Parser (Text -> Maybe Value -> JsonRpcError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code"
      Parser (Text -> Maybe Value -> JsonRpcError)
-> Parser Text -> Parser (Maybe Value -> JsonRpcError)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
      Parser (Maybe Value -> JsonRpcError)
-> Parser (Maybe Value) -> Parser JsonRpcError
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"data"

-- | An MCP content item returned by a tool execution.
data McpContent
  = TextContent !Text
  | ImageContent !Text !Text  -- ^ base64 data, mimeType
  | ResourceContent !Text !(Maybe Text) -- ^ uri, optional text
  deriving (Int -> McpContent -> ShowS
[McpContent] -> ShowS
McpContent -> String
(Int -> McpContent -> ShowS)
-> (McpContent -> String)
-> ([McpContent] -> ShowS)
-> Show McpContent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> McpContent -> ShowS
showsPrec :: Int -> McpContent -> ShowS
$cshow :: McpContent -> String
show :: McpContent -> String
$cshowList :: [McpContent] -> ShowS
showList :: [McpContent] -> ShowS
Show, McpContent -> McpContent -> Bool
(McpContent -> McpContent -> Bool)
-> (McpContent -> McpContent -> Bool) -> Eq McpContent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: McpContent -> McpContent -> Bool
== :: McpContent -> McpContent -> Bool
$c/= :: McpContent -> McpContent -> Bool
/= :: McpContent -> McpContent -> Bool
Eq, (forall x. McpContent -> Rep McpContent x)
-> (forall x. Rep McpContent x -> McpContent) -> Generic McpContent
forall x. Rep McpContent x -> McpContent
forall x. McpContent -> Rep McpContent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. McpContent -> Rep McpContent x
from :: forall x. McpContent -> Rep McpContent x
$cto :: forall x. Rep McpContent x -> McpContent
to :: forall x. Rep McpContent x -> McpContent
Generic)

instance ToJSON McpContent where
  toJSON :: McpContent -> Value
toJSON (TextContent Text
txt) =
    [Pair] -> Value
object [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"text" :: Text), Key
"text" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
txt ]
  toJSON (ImageContent Text
d Text
m) =
    [Pair] -> Value
object [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"image" :: Text), Key
"data" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
d, Key
"mimeType" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
m ]
  toJSON (ResourceContent Text
u Maybe Text
mt) =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"resource" :: Text), Key
"uri" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
u ]
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
t -> [Key
"text" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
t]) Maybe Text
mt

instance FromJSON McpContent where
  parseJSON :: Value -> Parser McpContent
parseJSON = String
-> (Object -> Parser McpContent) -> Value -> Parser McpContent
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"McpContent" ((Object -> Parser McpContent) -> Value -> Parser McpContent)
-> (Object -> Parser McpContent) -> Value -> Parser McpContent
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    t <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
    case (t :: Text) of
      Text
"text"     -> Text -> McpContent
TextContent (Text -> McpContent) -> Parser Text -> Parser McpContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"text"
      Text
"image"    -> Text -> Text -> McpContent
ImageContent (Text -> Text -> McpContent)
-> Parser Text -> Parser (Text -> McpContent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data" Parser (Text -> McpContent) -> Parser Text -> Parser McpContent
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"mimeType"
      Text
"resource" -> Text -> Maybe Text -> McpContent
ResourceContent (Text -> Maybe Text -> McpContent)
-> Parser Text -> Parser (Maybe Text -> McpContent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"uri" Parser (Maybe Text -> McpContent)
-> Parser (Maybe Text) -> Parser McpContent
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"text"
      Text
_          -> String -> Parser McpContent
forall a. HasCallStack => String -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail (String
"unknown McpContent type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t)

-- | Result of an MCP @tools/call@ execution.
data CallToolResult = CallToolResult
  { CallToolResult -> [McpContent]
callToolContent :: ![McpContent]
  , CallToolResult -> Maybe Bool
callToolIsError :: !(Maybe Bool)
  } deriving (Int -> CallToolResult -> ShowS
[CallToolResult] -> ShowS
CallToolResult -> String
(Int -> CallToolResult -> ShowS)
-> (CallToolResult -> String)
-> ([CallToolResult] -> ShowS)
-> Show CallToolResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CallToolResult -> ShowS
showsPrec :: Int -> CallToolResult -> ShowS
$cshow :: CallToolResult -> String
show :: CallToolResult -> String
$cshowList :: [CallToolResult] -> ShowS
showList :: [CallToolResult] -> ShowS
Show, CallToolResult -> CallToolResult -> Bool
(CallToolResult -> CallToolResult -> Bool)
-> (CallToolResult -> CallToolResult -> Bool) -> Eq CallToolResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CallToolResult -> CallToolResult -> Bool
== :: CallToolResult -> CallToolResult -> Bool
$c/= :: CallToolResult -> CallToolResult -> Bool
/= :: CallToolResult -> CallToolResult -> Bool
Eq, (forall x. CallToolResult -> Rep CallToolResult x)
-> (forall x. Rep CallToolResult x -> CallToolResult)
-> Generic CallToolResult
forall x. Rep CallToolResult x -> CallToolResult
forall x. CallToolResult -> Rep CallToolResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CallToolResult -> Rep CallToolResult x
from :: forall x. CallToolResult -> Rep CallToolResult x
$cto :: forall x. Rep CallToolResult x -> CallToolResult
to :: forall x. Rep CallToolResult x -> CallToolResult
Generic)

instance ToJSON CallToolResult where
  toJSON :: CallToolResult -> Value
toJSON (CallToolResult [McpContent]
c Maybe Bool
e) =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Key
"content" Key -> [McpContent] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [McpContent]
c ]
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (Bool -> [Pair]) -> Maybe Bool -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Bool
b -> [Key
"isError" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
b]) Maybe Bool
e

instance FromJSON CallToolResult where
  parseJSON :: Value -> Parser CallToolResult
parseJSON = String
-> (Object -> Parser CallToolResult)
-> Value
-> Parser CallToolResult
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"CallToolResult" ((Object -> Parser CallToolResult)
 -> Value -> Parser CallToolResult)
-> (Object -> Parser CallToolResult)
-> Value
-> Parser CallToolResult
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [McpContent] -> Maybe Bool -> CallToolResult
CallToolResult
      ([McpContent] -> Maybe Bool -> CallToolResult)
-> Parser [McpContent] -> Parser (Maybe Bool -> CallToolResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [McpContent]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"content"
      Parser (Maybe Bool -> CallToolResult)
-> Parser (Maybe Bool) -> Parser CallToolResult
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"isError"

-- | Parameters passed in an MCP @tools/call@ request.
data CallToolParams = CallToolParams
  { CallToolParams -> Text
callToolName      :: !Text
  , CallToolParams -> Maybe Value
callToolArguments :: !(Maybe Value)
  } deriving (Int -> CallToolParams -> ShowS
[CallToolParams] -> ShowS
CallToolParams -> String
(Int -> CallToolParams -> ShowS)
-> (CallToolParams -> String)
-> ([CallToolParams] -> ShowS)
-> Show CallToolParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CallToolParams -> ShowS
showsPrec :: Int -> CallToolParams -> ShowS
$cshow :: CallToolParams -> String
show :: CallToolParams -> String
$cshowList :: [CallToolParams] -> ShowS
showList :: [CallToolParams] -> ShowS
Show, CallToolParams -> CallToolParams -> Bool
(CallToolParams -> CallToolParams -> Bool)
-> (CallToolParams -> CallToolParams -> Bool) -> Eq CallToolParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CallToolParams -> CallToolParams -> Bool
== :: CallToolParams -> CallToolParams -> Bool
$c/= :: CallToolParams -> CallToolParams -> Bool
/= :: CallToolParams -> CallToolParams -> Bool
Eq, (forall x. CallToolParams -> Rep CallToolParams x)
-> (forall x. Rep CallToolParams x -> CallToolParams)
-> Generic CallToolParams
forall x. Rep CallToolParams x -> CallToolParams
forall x. CallToolParams -> Rep CallToolParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CallToolParams -> Rep CallToolParams x
from :: forall x. CallToolParams -> Rep CallToolParams x
$cto :: forall x. Rep CallToolParams x -> CallToolParams
to :: forall x. Rep CallToolParams x -> CallToolParams
Generic)

instance FromJSON CallToolParams where
  parseJSON :: Value -> Parser CallToolParams
parseJSON = String
-> (Object -> Parser CallToolParams)
-> Value
-> Parser CallToolParams
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"CallToolParams" ((Object -> Parser CallToolParams)
 -> Value -> Parser CallToolParams)
-> (Object -> Parser CallToolParams)
-> Value
-> Parser CallToolParams
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text -> Maybe Value -> CallToolParams
CallToolParams
      (Text -> Maybe Value -> CallToolParams)
-> Parser Text -> Parser (Maybe Value -> CallToolParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
      Parser (Maybe Value -> CallToolParams)
-> Parser (Maybe Value) -> Parser CallToolParams
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"arguments"

-- | An MCP Tool specification describing a callable tool.
data McpTool = McpTool
  { McpTool -> Text
toolName        :: !Text
  , McpTool -> Text
toolDescription :: !Text
  , McpTool -> Value
toolInputSchema :: !Value
  } deriving (Int -> McpTool -> ShowS
[McpTool] -> ShowS
McpTool -> String
(Int -> McpTool -> ShowS)
-> (McpTool -> String) -> ([McpTool] -> ShowS) -> Show McpTool
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> McpTool -> ShowS
showsPrec :: Int -> McpTool -> ShowS
$cshow :: McpTool -> String
show :: McpTool -> String
$cshowList :: [McpTool] -> ShowS
showList :: [McpTool] -> ShowS
Show, McpTool -> McpTool -> Bool
(McpTool -> McpTool -> Bool)
-> (McpTool -> McpTool -> Bool) -> Eq McpTool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: McpTool -> McpTool -> Bool
== :: McpTool -> McpTool -> Bool
$c/= :: McpTool -> McpTool -> Bool
/= :: McpTool -> McpTool -> Bool
Eq, (forall x. McpTool -> Rep McpTool x)
-> (forall x. Rep McpTool x -> McpTool) -> Generic McpTool
forall x. Rep McpTool x -> McpTool
forall x. McpTool -> Rep McpTool x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. McpTool -> Rep McpTool x
from :: forall x. McpTool -> Rep McpTool x
$cto :: forall x. Rep McpTool x -> McpTool
to :: forall x. Rep McpTool x -> McpTool
Generic)

instance ToJSON McpTool where
  toJSON :: McpTool -> Value
toJSON (McpTool Text
n Text
d Value
s) =
    [Pair] -> Value
object [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
n, Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
d, Key
"inputSchema" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
s ]

instance FromJSON McpTool where
  parseJSON :: Value -> Parser McpTool
parseJSON = String -> (Object -> Parser McpTool) -> Value -> Parser McpTool
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"McpTool" ((Object -> Parser McpTool) -> Value -> Parser McpTool)
-> (Object -> Parser McpTool) -> Value -> Parser McpTool
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text -> Text -> Value -> McpTool
McpTool
      (Text -> Text -> Value -> McpTool)
-> Parser Text -> Parser (Text -> Value -> McpTool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
      Parser (Text -> Value -> McpTool)
-> Parser Text -> Parser (Value -> McpTool)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"description"
      Parser (Value -> McpTool) -> Parser Value -> Parser McpTool
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"inputSchema"

-- | Server information reported during the @initialize@ handshake.
data ServerInfo = ServerInfo
  { ServerInfo -> Text
serverName    :: !Text
  , ServerInfo -> Text
serverVersion :: !Text
  } deriving (Int -> ServerInfo -> ShowS
[ServerInfo] -> ShowS
ServerInfo -> String
(Int -> ServerInfo -> ShowS)
-> (ServerInfo -> String)
-> ([ServerInfo] -> ShowS)
-> Show ServerInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerInfo -> ShowS
showsPrec :: Int -> ServerInfo -> ShowS
$cshow :: ServerInfo -> String
show :: ServerInfo -> String
$cshowList :: [ServerInfo] -> ShowS
showList :: [ServerInfo] -> ShowS
Show, ServerInfo -> ServerInfo -> Bool
(ServerInfo -> ServerInfo -> Bool)
-> (ServerInfo -> ServerInfo -> Bool) -> Eq ServerInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerInfo -> ServerInfo -> Bool
== :: ServerInfo -> ServerInfo -> Bool
$c/= :: ServerInfo -> ServerInfo -> Bool
/= :: ServerInfo -> ServerInfo -> Bool
Eq, (forall x. ServerInfo -> Rep ServerInfo x)
-> (forall x. Rep ServerInfo x -> ServerInfo) -> Generic ServerInfo
forall x. Rep ServerInfo x -> ServerInfo
forall x. ServerInfo -> Rep ServerInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ServerInfo -> Rep ServerInfo x
from :: forall x. ServerInfo -> Rep ServerInfo x
$cto :: forall x. Rep ServerInfo x -> ServerInfo
to :: forall x. Rep ServerInfo x -> ServerInfo
Generic)

instance ToJSON ServerInfo where
  toJSON :: ServerInfo -> Value
toJSON (ServerInfo Text
n Text
v) =
    [Pair] -> Value
object [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
n, Key
"version" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
v ]

-- | Server capabilities announced during initialization.
data ServerCapabilities = ServerCapabilities
  { ServerCapabilities -> Maybe Value
capTools :: !(Maybe Value)
  } deriving (Int -> ServerCapabilities -> ShowS
[ServerCapabilities] -> ShowS
ServerCapabilities -> String
(Int -> ServerCapabilities -> ShowS)
-> (ServerCapabilities -> String)
-> ([ServerCapabilities] -> ShowS)
-> Show ServerCapabilities
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerCapabilities -> ShowS
showsPrec :: Int -> ServerCapabilities -> ShowS
$cshow :: ServerCapabilities -> String
show :: ServerCapabilities -> String
$cshowList :: [ServerCapabilities] -> ShowS
showList :: [ServerCapabilities] -> ShowS
Show, ServerCapabilities -> ServerCapabilities -> Bool
(ServerCapabilities -> ServerCapabilities -> Bool)
-> (ServerCapabilities -> ServerCapabilities -> Bool)
-> Eq ServerCapabilities
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerCapabilities -> ServerCapabilities -> Bool
== :: ServerCapabilities -> ServerCapabilities -> Bool
$c/= :: ServerCapabilities -> ServerCapabilities -> Bool
/= :: ServerCapabilities -> ServerCapabilities -> Bool
Eq, (forall x. ServerCapabilities -> Rep ServerCapabilities x)
-> (forall x. Rep ServerCapabilities x -> ServerCapabilities)
-> Generic ServerCapabilities
forall x. Rep ServerCapabilities x -> ServerCapabilities
forall x. ServerCapabilities -> Rep ServerCapabilities x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ServerCapabilities -> Rep ServerCapabilities x
from :: forall x. ServerCapabilities -> Rep ServerCapabilities x
$cto :: forall x. Rep ServerCapabilities x -> ServerCapabilities
to :: forall x. Rep ServerCapabilities x -> ServerCapabilities
Generic)

instance ToJSON ServerCapabilities where
  toJSON :: ServerCapabilities -> Value
toJSON (ServerCapabilities Maybe Value
t) =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> (Value -> [Pair]) -> Maybe Value -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Value
x -> [Key
"tools" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
x]) Maybe Value
t

-- | The payload returned to the client upon a successful @initialize@ handshake.
data InitializeResult = InitializeResult
  { InitializeResult -> Text
initProtocolVersion :: !Text
  , InitializeResult -> ServerCapabilities
initCapabilities    :: !ServerCapabilities
  , InitializeResult -> ServerInfo
initServerInfo      :: !ServerInfo
  } deriving (Int -> InitializeResult -> ShowS
[InitializeResult] -> ShowS
InitializeResult -> String
(Int -> InitializeResult -> ShowS)
-> (InitializeResult -> String)
-> ([InitializeResult] -> ShowS)
-> Show InitializeResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitializeResult -> ShowS
showsPrec :: Int -> InitializeResult -> ShowS
$cshow :: InitializeResult -> String
show :: InitializeResult -> String
$cshowList :: [InitializeResult] -> ShowS
showList :: [InitializeResult] -> ShowS
Show, InitializeResult -> InitializeResult -> Bool
(InitializeResult -> InitializeResult -> Bool)
-> (InitializeResult -> InitializeResult -> Bool)
-> Eq InitializeResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InitializeResult -> InitializeResult -> Bool
== :: InitializeResult -> InitializeResult -> Bool
$c/= :: InitializeResult -> InitializeResult -> Bool
/= :: InitializeResult -> InitializeResult -> Bool
Eq, (forall x. InitializeResult -> Rep InitializeResult x)
-> (forall x. Rep InitializeResult x -> InitializeResult)
-> Generic InitializeResult
forall x. Rep InitializeResult x -> InitializeResult
forall x. InitializeResult -> Rep InitializeResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InitializeResult -> Rep InitializeResult x
from :: forall x. InitializeResult -> Rep InitializeResult x
$cto :: forall x. Rep InitializeResult x -> InitializeResult
to :: forall x. Rep InitializeResult x -> InitializeResult
Generic)

instance ToJSON InitializeResult where
  toJSON :: InitializeResult -> Value
toJSON (InitializeResult Text
p ServerCapabilities
c ServerInfo
s) =
    [Pair] -> Value
object
      [ Key
"protocolVersion" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
p
      , Key
"capabilities"    Key -> ServerCapabilities -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ServerCapabilities
c
      , Key
"serverInfo"      Key -> ServerInfo -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ServerInfo
s
      ]

{-------------------------------------------------------------------------------
  Tool Schema Synthesis
-------------------------------------------------------------------------------}

-- | Synthesizes an MCP @t'McpTool'@ definition from an open record row type @r@.
-- The tool's parameter schema is generated via 'Polytropos.OpenApi.toSchema'.
recordToTool
  :: forall (name :: Symbol) r.
     (KnownSymbol name, Typeable r, AllToSchema r)
  => Text                -- ^ Human-readable tool description
  -> Proxy r             -- ^ Parameter row proxy
  -> McpTool
recordToTool :: forall (name :: Symbol) (r :: Row).
(KnownSymbol name, Typeable r, AllToSchema r) =>
Text -> Proxy r -> McpTool
recordToTool Text
desc Proxy r
_ =
  McpTool
    { toolName :: Text
toolName        = String -> Text
T.pack (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name))
    , toolDescription :: Text
toolDescription = Text
desc
    , toolInputSchema :: Value
toolInputSchema = Schema -> Value
forall a. ToJSON a => a -> Value
toJSON (Proxy (Record r) -> Schema
forall a. ToSchema a => Proxy a -> Schema
toSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Record r)))
    }

{-------------------------------------------------------------------------------
  Tool Call Parsing & Dispatch
-------------------------------------------------------------------------------}

-- | Parses tool call arguments into a Polytropos 'Variant' sum row @s@.
-- Constructs a tagged singleton object @{"toolName": arguments}@ and decodes
-- via 'Polytropos.Aeson.AllCtorsFromJSON'.
toolCallToVariant
  :: forall s. (AllCtorsFromJSON s)
  => Text               -- ^ Invoked tool name
  -> Value              -- ^ JSON argument object
  -> Either String (Variant s)
toolCallToVariant :: forall (s :: SumRow).
AllCtorsFromJSON s =>
Text -> Value -> Either String (Variant s)
toolCallToVariant Text
tName Value
args =
  let taggedObj :: Value
taggedObj = Object -> Value
Object (Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KM.singleton (Text -> Key
Key.fromText Text
tName) Value
args)
  in case Value -> Result (Variant s)
forall a. FromJSON a => Value -> Result a
fromJSON Value
taggedObj of
       Aeson.Success Variant s
v -> Variant s -> Either String (Variant s)
forall a b. b -> Either a b
Right Variant s
v
       Aeson.Error String
err -> String -> Either String (Variant s)
forall a b. a -> Either a b
Left (String
"Invalid arguments for tool '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
tName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"': " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err)

-- | Dispatches a tool execution request by decoding into @Variant s@ and
-- invoking the provided handler (typically constructed via 'Polytropos.eliminateUniform').
dispatchToolCall
  :: forall s. (AllCtorsFromJSON s)
  => (Variant s -> IO [McpContent])
  -> Text
  -> Value
  -> IO CallToolResult
dispatchToolCall :: forall (s :: SumRow).
AllCtorsFromJSON s =>
(Variant s -> IO [McpContent])
-> Text -> Value -> IO CallToolResult
dispatchToolCall Variant s -> IO [McpContent]
handler Text
tName Value
args =
  case forall (s :: SumRow).
AllCtorsFromJSON s =>
Text -> Value -> Either String (Variant s)
toolCallToVariant @s Text
tName Value
args of
    Left String
parseErr ->
      CallToolResult -> IO CallToolResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CallToolResult
        { callToolContent :: [McpContent]
callToolContent = [Text -> McpContent
TextContent (String -> Text
T.pack String
parseErr)]
        , callToolIsError :: Maybe Bool
callToolIsError = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        }
    Right Variant s
variantVal -> do
      res <- IO [McpContent] -> IO (Either SomeException [McpContent])
forall e a. Exception e => IO a -> IO (Either e a)
try (Variant s -> IO [McpContent]
handler Variant s
variantVal)
      case res of
        Left (SomeException
ex :: SomeException) ->
          CallToolResult -> IO CallToolResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CallToolResult
            { callToolContent :: [McpContent]
callToolContent = [Text -> McpContent
TextContent (Text
"Tool execution failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
ex))]
            , callToolIsError :: Maybe Bool
callToolIsError = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            }
        Right [McpContent]
contents ->
          CallToolResult -> IO CallToolResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CallToolResult
            { callToolContent :: [McpContent]
callToolContent = [McpContent]
contents
            , callToolIsError :: Maybe Bool
callToolIsError = Maybe Bool
forall a. Maybe a
Nothing
            }

-- | Handles a single incoming JSON-RPC raw message line, producing a response
-- (or 'Nothing' for notifications that expect no reply).
handleJsonRpcMessage
  :: ServerInfo
  -> [McpTool]
  -> (Text -> Value -> IO CallToolResult)
  -> LBS.ByteString
  -> IO (Maybe LBS.ByteString)
handleJsonRpcMessage :: ServerInfo
-> [McpTool]
-> (Text -> Value -> IO CallToolResult)
-> ByteString
-> IO (Maybe ByteString)
handleJsonRpcMessage ServerInfo
sInfo [McpTool]
tools Text -> Value -> IO CallToolResult
toolDispatcher ByteString
rawMsg =
  case ByteString -> Either String JsonRpcRequest
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
rawMsg of
    Left String
parseErr ->
      Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode (JsonRpcResponse -> ByteString) -> JsonRpcResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse
        { jsonrpcRespVersion :: Text
jsonrpcRespVersion = Text
"2.0"
        , jsonrpcRespId :: Maybe Value
jsonrpcRespId      = Maybe Value
forall a. Maybe a
Nothing
        , jsonrpcRespResult :: Maybe Value
jsonrpcRespResult  = Maybe Value
forall a. Maybe a
Nothing
        , jsonrpcRespError :: Maybe JsonRpcError
jsonrpcRespError   = JsonRpcError -> Maybe JsonRpcError
forall a. a -> Maybe a
Just (JsonRpcError -> Maybe JsonRpcError)
-> JsonRpcError -> Maybe JsonRpcError
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Maybe Value -> JsonRpcError
JsonRpcError (-Int
32700) (Text
"Parse error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
parseErr) Maybe Value
forall a. Maybe a
Nothing
        }
    Right (JsonRpcRequest Text
_ Text
"initialize" Maybe Value
reqId Maybe Value
_) ->
      Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode (JsonRpcResponse -> ByteString) -> JsonRpcResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse
        { jsonrpcRespVersion :: Text
jsonrpcRespVersion = Text
"2.0"
        , jsonrpcRespId :: Maybe Value
jsonrpcRespId      = Maybe Value
reqId
        , jsonrpcRespResult :: Maybe Value
jsonrpcRespResult  = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ InitializeResult -> Value
forall a. ToJSON a => a -> Value
toJSON (InitializeResult -> Value) -> InitializeResult -> Value
forall a b. (a -> b) -> a -> b
$ InitializeResult
            { initProtocolVersion :: Text
initProtocolVersion = Text
"2024-11-05"
            , initCapabilities :: ServerCapabilities
initCapabilities    = Maybe Value -> ServerCapabilities
ServerCapabilities (Value -> Maybe Value
forall a. a -> Maybe a
Just ([Pair] -> Value
object [Key
"listChanged" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False]))
            , initServerInfo :: ServerInfo
initServerInfo      = ServerInfo
sInfo
            }
        , jsonrpcRespError :: Maybe JsonRpcError
jsonrpcRespError   = Maybe JsonRpcError
forall a. Maybe a
Nothing
        }
    Right (JsonRpcRequest Text
_ Text
"notifications/initialized" Maybe Value
_ Maybe Value
_) ->
      Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
    Right (JsonRpcRequest Text
_ Text
"ping" Maybe Value
reqId Maybe Value
_) ->
      Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode (JsonRpcResponse -> ByteString) -> JsonRpcResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse
        { jsonrpcRespVersion :: Text
jsonrpcRespVersion = Text
"2.0"
        , jsonrpcRespId :: Maybe Value
jsonrpcRespId      = Maybe Value
reqId
        , jsonrpcRespResult :: Maybe Value
jsonrpcRespResult  = Value -> Maybe Value
forall a. a -> Maybe a
Just ([Pair] -> Value
object [])
        , jsonrpcRespError :: Maybe JsonRpcError
jsonrpcRespError   = Maybe JsonRpcError
forall a. Maybe a
Nothing
        }
    Right (JsonRpcRequest Text
_ Text
"tools/list" Maybe Value
reqId Maybe Value
_) ->
      Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode (JsonRpcResponse -> ByteString) -> JsonRpcResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse
        { jsonrpcRespVersion :: Text
jsonrpcRespVersion = Text
"2.0"
        , jsonrpcRespId :: Maybe Value
jsonrpcRespId      = Maybe Value
reqId
        , jsonrpcRespResult :: Maybe Value
jsonrpcRespResult  = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"tools" Key -> [McpTool] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [McpTool]
tools ]
        , jsonrpcRespError :: Maybe JsonRpcError
jsonrpcRespError   = Maybe JsonRpcError
forall a. Maybe a
Nothing
        }
    Right (JsonRpcRequest Text
_ Text
"tools/call" Maybe Value
reqId Maybe Value
mParams) -> do
      case Maybe Value
mParams of
        Just Value
pVal ->
          case Value -> Result CallToolParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
pVal of
            Aeson.Success (CallToolParams Text
tName Maybe Value
mArgs) -> do
              let args :: Value
args = Value -> (Value -> Value) -> Maybe Value -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Object -> Value
Object Object
forall v. KeyMap v
KM.empty) Value -> Value
forall a. a -> a
id Maybe Value
mArgs
              res <- Text -> Value -> IO CallToolResult
toolDispatcher Text
tName Value
args
              pure $ Just $ encode $ JsonRpcResponse
                { jsonrpcRespVersion = "2.0"
                , jsonrpcRespId      = reqId
                , jsonrpcRespResult  = Just (toJSON res)
                , jsonrpcRespError   = Nothing
                }
            Aeson.Error String
err ->
              Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode (JsonRpcResponse -> ByteString) -> JsonRpcResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse
                { jsonrpcRespVersion :: Text
jsonrpcRespVersion = Text
"2.0"
                , jsonrpcRespId :: Maybe Value
jsonrpcRespId      = Maybe Value
reqId
                , jsonrpcRespResult :: Maybe Value
jsonrpcRespResult  = Maybe Value
forall a. Maybe a
Nothing
                , jsonrpcRespError :: Maybe JsonRpcError
jsonrpcRespError   = JsonRpcError -> Maybe JsonRpcError
forall a. a -> Maybe a
Just (JsonRpcError -> Maybe JsonRpcError)
-> JsonRpcError -> Maybe JsonRpcError
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Maybe Value -> JsonRpcError
JsonRpcError (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err) Maybe Value
forall a. Maybe a
Nothing
                }
        Maybe Value
Nothing ->
          Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode (JsonRpcResponse -> ByteString) -> JsonRpcResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse
            { jsonrpcRespVersion :: Text
jsonrpcRespVersion = Text
"2.0"
            , jsonrpcRespId :: Maybe Value
jsonrpcRespId      = Maybe Value
reqId
            , jsonrpcRespResult :: Maybe Value
jsonrpcRespResult  = Maybe Value
forall a. Maybe a
Nothing
            , jsonrpcRespError :: Maybe JsonRpcError
jsonrpcRespError   = JsonRpcError -> Maybe JsonRpcError
forall a. a -> Maybe a
Just (JsonRpcError -> Maybe JsonRpcError)
-> JsonRpcError -> Maybe JsonRpcError
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Maybe Value -> JsonRpcError
JsonRpcError (-Int
32602) Text
"Missing params for tools/call" Maybe Value
forall a. Maybe a
Nothing
            }
    Right (JsonRpcRequest Text
_ Text
method Maybe Value
reqId Maybe Value
_) ->
      Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode (JsonRpcResponse -> ByteString) -> JsonRpcResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcResponse
        { jsonrpcRespVersion :: Text
jsonrpcRespVersion = Text
"2.0"
        , jsonrpcRespId :: Maybe Value
jsonrpcRespId      = Maybe Value
reqId
        , jsonrpcRespResult :: Maybe Value
jsonrpcRespResult  = Maybe Value
forall a. Maybe a
Nothing
        , jsonrpcRespError :: Maybe JsonRpcError
jsonrpcRespError   = JsonRpcError -> Maybe JsonRpcError
forall a. a -> Maybe a
Just (JsonRpcError -> Maybe JsonRpcError)
-> JsonRpcError -> Maybe JsonRpcError
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Maybe Value -> JsonRpcError
JsonRpcError (-Int
32601) (Text
"Method not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
method) Maybe Value
forall a. Maybe a
Nothing
        }

-- | Runs an MCP server over standard input/output using newline-delimited JSON-RPC messages.
runStdioServer
  :: ServerInfo
  -> [McpTool]
  -> (Text -> Value -> IO CallToolResult)
  -> IO ()
runStdioServer :: ServerInfo
-> [McpTool] -> (Text -> Value -> IO CallToolResult) -> IO ()
runStdioServer ServerInfo
sInfo [McpTool]
tools Text -> Value -> IO CallToolResult
toolDispatcher = IO ()
loop
  where
    loop :: IO ()
loop = do
      done <- IO Bool
isEOF
      if done
        then pure ()
        else do
          raw <- BSC8.hGetLine stdin
          let line = ByteString -> ByteString
LBS.fromStrict ByteString
raw
          if LBS.null line
            then loop
            else do
              mResp <- handleJsonRpcMessage sInfo tools toolDispatcher line
              case mResp of
                Just ByteString
resp -> do
                  ByteString -> IO ()
LBC8.putStrLn ByteString
resp
                  Handle -> IO ()
hFlush Handle
stdout
                Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              loop