{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module MCP.Server
  ( -- * Server Runtime
    runMcpServer
  , runMcpServerStdIn
  , handleMcpMessage

    -- * Utility Functions
  , jsonValueToText

    -- * Re-exports
  , module MCP.Server.Types
  ) where

import           Control.Monad          (when)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Data.Aeson
import qualified Data.ByteString.Lazy   as BSL
import qualified Data.Map               as Map
import           Data.Text              (Text)
import qualified Data.Text              as T
import qualified Data.Text.Encoding     as TE
import qualified Data.Text.IO           as TIO
import           System.IO              (hFlush, hPutStrLn, stderr, stdout)

import           MCP.Server.JsonRpc
import           MCP.Server.Protocol
import           MCP.Server.Types

-- | Convert JSON Value to Text representation suitable for handlers
jsonValueToText :: Value -> Text
jsonValueToText :: Value -> Text
jsonValueToText (String Text
t) = Text
t
jsonValueToText (Number Scientific
n) = 
    -- Check if it's a whole number, if so format as integer
    if Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
n) Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
n
        then [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> [Char]
forall a. Show a => a -> [Char]
show (Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
n :: Integer)
        else [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Scientific -> [Char]
forall a. Show a => a -> [Char]
show Scientific
n
jsonValueToText (Bool Bool
True) = Text
"true"
jsonValueToText (Bool Bool
False) = Text
"false"
jsonValueToText Value
Null = Text
""
jsonValueToText Value
v = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Value -> [Char]
forall a. Show a => a -> [Char]
show Value
v

-- | Extract a brief summary of a JSON-RPC message for logging
getMessageSummary :: JsonRpcMessage -> String
getMessageSummary :: JsonRpcMessage -> [Char]
getMessageSummary (JsonRpcMessageRequest JsonRpcRequest
req) = 
  [Char]
"Request[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RequestId -> [Char]
forall a. Show a => a -> [Char]
show (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"] " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (JsonRpcRequest -> Text
requestMethod JsonRpcRequest
req)
getMessageSummary (JsonRpcMessageNotification JsonRpcNotification
notif) = 
  [Char]
"Notification " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (JsonRpcNotification -> Text
notificationMethod JsonRpcNotification
notif)
getMessageSummary (JsonRpcMessageResponse JsonRpcResponse
resp) = 
  [Char]
"Response[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RequestId -> [Char]
forall a. Show a => a -> [Char]
show (JsonRpcResponse -> RequestId
responseId JsonRpcResponse
resp) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"

-- | Validate protocol version and return negotiated version
validateProtocolVersion :: Text -> Either Text Text
validateProtocolVersion :: Text -> Either Text Text
validateProtocolVersion Text
clientVersion
  | Text
clientVersion Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
protocolVersion = Text -> Either Text Text
forall a b. b -> Either a b
Right Text
protocolVersion  -- Exact match
  | Text
clientVersion Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"2024-11-05" = Text -> Either Text Text
forall a b. b -> Either a b
Right Text
"2024-11-05"        -- Accept this version
  | Bool
otherwise = Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported protocol version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
clientVersion Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Server supports: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
protocolVersion

-- | Run an MCP server with custom input/output handlers
runMcpServer :: (MonadIO m)
             => McpServerInfo
             -> McpServerHandlers m
             -> (Text -> m ())      -- ^ Output handler
             -> m Text              -- ^ Input handler
             -> m ()
runMcpServer :: forall (m :: * -> *).
MonadIO m =>
McpServerInfo
-> McpServerHandlers m -> (Text -> m ()) -> m Text -> m ()
runMcpServer McpServerInfo
serverInfo McpServerHandlers m
handlers Text -> m ()
outputHandler m Text
inputHandler = do
  loop
  where
    loop :: m ()
loop = do
      input <- m Text
inputHandler
      when (not $ T.null $ T.strip input) $ do
        liftIO $ hPutStrLn stderr $ "Received request: " ++ T.unpack input
        case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 input) of
          Left [Char]
err -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Parse error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err
          Right Value
jsonValue -> do
            case Value -> Either [Char] JsonRpcMessage
parseJsonRpcMessage Value
jsonValue of
              Left [Char]
err -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"JSON-RPC parse error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err
              Right JsonRpcMessage
message -> do
                IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Processing message: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (JsonRpcMessage -> [Char]
getMessageSummary JsonRpcMessage
message)
                response <- McpServerInfo
-> McpServerHandlers m
-> JsonRpcMessage
-> m (Maybe JsonRpcMessage)
forall (m :: * -> *).
MonadIO m =>
McpServerInfo
-> McpServerHandlers m
-> JsonRpcMessage
-> m (Maybe JsonRpcMessage)
handleMcpMessage McpServerInfo
serverInfo McpServerHandlers m
handlers JsonRpcMessage
message
                case response of
                  Just JsonRpcMessage
responseMsg -> do
                    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Sending response for: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (JsonRpcMessage -> [Char]
getMessageSummary JsonRpcMessage
message)
                    Text -> m ()
outputHandler (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ StrictByteString -> Text
TE.decodeUtf8 (StrictByteString -> Text) -> StrictByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> StrictByteString
BSL.toStrict (ByteString -> StrictByteString) -> ByteString -> StrictByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonRpcMessage -> Value
encodeJsonRpcMessage JsonRpcMessage
responseMsg
                  Maybe JsonRpcMessage
Nothing -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"No response needed for: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (JsonRpcMessage -> [Char]
getMessageSummary JsonRpcMessage
message)
        loop

-- | Run an MCP server using stdin/stdout
runMcpServerStdIn :: McpServerInfo -> McpServerHandlers IO -> IO ()
runMcpServerStdIn :: McpServerInfo -> McpServerHandlers IO -> IO ()
runMcpServerStdIn McpServerInfo
serverInfo McpServerHandlers IO
handlers =
  McpServerInfo
-> McpServerHandlers IO -> (Text -> IO ()) -> IO Text -> IO ()
forall (m :: * -> *).
MonadIO m =>
McpServerInfo
-> McpServerHandlers m -> (Text -> m ()) -> m Text -> m ()
runMcpServer McpServerInfo
serverInfo McpServerHandlers IO
handlers Text -> IO ()
outputHandler IO Text
inputHandler
  where
    outputHandler :: Text -> IO ()
outputHandler Text
text = do
      Text -> IO ()
TIO.putStrLn Text
text
      Handle -> IO ()
hFlush Handle
stdout
    inputHandler :: IO Text
inputHandler = IO Text
TIO.getLine

-- | Handle an MCP message and return a response if needed
handleMcpMessage :: (MonadIO m)
                 => McpServerInfo
                 -> McpServerHandlers m
                 -> JsonRpcMessage
                 -> m (Maybe JsonRpcMessage)
handleMcpMessage :: forall (m :: * -> *).
MonadIO m =>
McpServerInfo
-> McpServerHandlers m
-> JsonRpcMessage
-> m (Maybe JsonRpcMessage)
handleMcpMessage McpServerInfo
serverInfo McpServerHandlers m
handlers (JsonRpcMessageRequest JsonRpcRequest
req) = do
  response <- case JsonRpcRequest -> Text
requestMethod JsonRpcRequest
req of
    Text
"initialize" -> McpServerInfo -> JsonRpcRequest -> m JsonRpcResponse
forall (m :: * -> *).
MonadIO m =>
McpServerInfo -> JsonRpcRequest -> m JsonRpcResponse
handleInitialize McpServerInfo
serverInfo JsonRpcRequest
req
    Text
"ping" -> JsonRpcRequest -> m JsonRpcResponse
forall (m :: * -> *).
MonadIO m =>
JsonRpcRequest -> m JsonRpcResponse
handlePing JsonRpcRequest
req
    Text
"prompts/list" -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handlePromptsList McpServerHandlers m
handlers JsonRpcRequest
req
    Text
"prompts/get" -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handlePromptsGet McpServerHandlers m
handlers JsonRpcRequest
req
    Text
"resources/list" -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleResourcesList McpServerHandlers m
handlers JsonRpcRequest
req
    Text
"resources/read" -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleResourcesRead McpServerHandlers m
handlers JsonRpcRequest
req
    Text
"tools/list" -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleToolsList McpServerHandlers m
handlers JsonRpcRequest
req
    Text
"tools/call" -> McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleToolsCall McpServerHandlers m
handlers JsonRpcRequest
req
    Text
method -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
      { errorCode :: Int
errorCode = -Int
32601
      , errorMessage :: Text
errorMessage = Text
"Method not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
method
      , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
      }
  return $ Just $ JsonRpcMessageResponse response

handleMcpMessage McpServerInfo
_ McpServerHandlers m
_ (JsonRpcMessageNotification JsonRpcNotification
notif) = do
  case JsonRpcNotification -> Text
notificationMethod JsonRpcNotification
notif of
    Text
"notifications/initialized" -> do
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"Received initialized notification - server is ready for operation"
      () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Text
_ -> do
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Received unknown notification: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (JsonRpcNotification -> Text
notificationMethod JsonRpcNotification
notif)
      () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Maybe JsonRpcMessage -> m (Maybe JsonRpcMessage)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JsonRpcMessage
forall a. Maybe a
Nothing

handleMcpMessage McpServerInfo
_ McpServerHandlers m
_ (JsonRpcMessageResponse JsonRpcResponse
_) =
  Maybe JsonRpcMessage -> m (Maybe JsonRpcMessage)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JsonRpcMessage
forall a. Maybe a
Nothing

-- | Handle initialize request
handleInitialize :: (MonadIO m) => McpServerInfo -> JsonRpcRequest -> m JsonRpcResponse
handleInitialize :: forall (m :: * -> *).
MonadIO m =>
McpServerInfo -> JsonRpcRequest -> m JsonRpcResponse
handleInitialize McpServerInfo
serverInfo JsonRpcRequest
req = do
  case JsonRpcRequest -> Maybe Value
requestParams JsonRpcRequest
req of
    Maybe Value
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
      { errorCode :: Int
errorCode = -Int
32602
      , errorMessage :: Text
errorMessage = Text
"Missing required parameters for initialize"
      , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
      }
    Just Value
params ->
      case Value -> Result InitializeRequest
forall a. FromJSON a => Value -> Result a
fromJSON Value
params of
        Error [Char]
err -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
          { errorCode :: Int
errorCode = -Int
32602
          , errorMessage :: Text
errorMessage = Text
"Invalid initialize parameters: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
err
          , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
          }
        Success InitializeRequest
initReq -> do
          -- Check protocol version compatibility
          let clientVersion :: Text
clientVersion = InitializeRequest -> Text
initProtocolVersion InitializeRequest
initReq
          case Text -> Either Text Text
validateProtocolVersion Text
clientVersion of
            Left Text
errorMsg -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
              { errorCode :: Int
errorCode = -Int
32602
              , errorMessage :: Text
errorMessage = Text
errorMsg
              , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
              }
            Right Text
negotiatedVersion -> do
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Client version: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
clientVersion [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", using: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
negotiatedVersion
              let capabilities :: ServerCapabilities
capabilities = ServerCapabilities
                    { capabilityPrompts :: Maybe PromptCapabilities
capabilityPrompts = PromptCapabilities -> Maybe PromptCapabilities
forall a. a -> Maybe a
Just (PromptCapabilities -> Maybe PromptCapabilities)
-> PromptCapabilities -> Maybe PromptCapabilities
forall a b. (a -> b) -> a -> b
$ PromptCapabilities { promptListChanged :: Maybe Bool
promptListChanged = Maybe Bool
forall a. Maybe a
Nothing }
                    , capabilityResources :: Maybe ResourceCapabilities
capabilityResources = ResourceCapabilities -> Maybe ResourceCapabilities
forall a. a -> Maybe a
Just (ResourceCapabilities -> Maybe ResourceCapabilities)
-> ResourceCapabilities -> Maybe ResourceCapabilities
forall a b. (a -> b) -> a -> b
$ ResourceCapabilities { resourceSubscribe :: Maybe Bool
resourceSubscribe = Maybe Bool
forall a. Maybe a
Nothing, resourceListChanged :: Maybe Bool
resourceListChanged = Maybe Bool
forall a. Maybe a
Nothing }
                    , capabilityTools :: Maybe ToolCapabilities
capabilityTools = ToolCapabilities -> Maybe ToolCapabilities
forall a. a -> Maybe a
Just (ToolCapabilities -> Maybe ToolCapabilities)
-> ToolCapabilities -> Maybe ToolCapabilities
forall a b. (a -> b) -> a -> b
$ ToolCapabilities { toolListChanged :: Maybe Bool
toolListChanged = Maybe Bool
forall a. Maybe a
Nothing }
                    , capabilityLogging :: Maybe LoggingCapabilities
capabilityLogging = Maybe LoggingCapabilities
forall a. Maybe a
Nothing  -- Not supported yet
                    }
              let response :: InitializeResponse
response = InitializeResponse
                    { initRespProtocolVersion :: Text
initRespProtocolVersion = Text
negotiatedVersion
                    , initRespCapabilities :: ServerCapabilities
initRespCapabilities = ServerCapabilities
capabilities
                    , initRespServerInfo :: McpServerInfo
initRespServerInfo = McpServerInfo
serverInfo
                    }
              JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> Value -> JsonRpcResponse
makeSuccessResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (InitializeResponse -> Value
forall a. ToJSON a => a -> Value
toJSON InitializeResponse
response)

-- | Handle ping request
handlePing :: (MonadIO m) => JsonRpcRequest -> m JsonRpcResponse
handlePing :: forall (m :: * -> *).
MonadIO m =>
JsonRpcRequest -> m JsonRpcResponse
handlePing JsonRpcRequest
req = JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> Value -> JsonRpcResponse
makeSuccessResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (PongResponse -> Value
forall a. ToJSON a => a -> Value
toJSON PongResponse
PongResponse)

-- | Handle prompts/list request
handlePromptsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handlePromptsList :: forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handlePromptsList McpServerHandlers m
handlers JsonRpcRequest
req =
  case McpServerHandlers m
-> Maybe (PromptListHandler m, PromptGetHandler m)
forall (m :: * -> *).
McpServerHandlers m
-> Maybe (PromptListHandler m, PromptGetHandler m)
prompts McpServerHandlers m
handlers of
    Maybe (PromptListHandler m, PromptGetHandler m)
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
      { errorCode :: Int
errorCode = -Int
32601
      , errorMessage :: Text
errorMessage = Text
"Prompts not supported"
      , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
      }
    Just (PromptListHandler m
listHandler, PromptGetHandler m
_) -> do
      promptsList <- PromptListHandler m
listHandler
      let response = PromptsListResponse
            { promptsListPrompts :: [PromptDefinition]
promptsListPrompts = [PromptDefinition]
promptsList
            }
      return $ makeSuccessResponse (requestId req) (toJSON response)

-- | Handle prompts/get request
handlePromptsGet :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handlePromptsGet :: forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handlePromptsGet McpServerHandlers m
handlers JsonRpcRequest
req =
  case McpServerHandlers m
-> Maybe (PromptListHandler m, PromptGetHandler m)
forall (m :: * -> *).
McpServerHandlers m
-> Maybe (PromptListHandler m, PromptGetHandler m)
prompts McpServerHandlers m
handlers of
    Maybe (PromptListHandler m, PromptGetHandler m)
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
      { errorCode :: Int
errorCode = -Int
32601
      , errorMessage :: Text
errorMessage = Text
"Prompts not supported"
      , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
      }
    Just (PromptListHandler m
_, PromptGetHandler m
getHandler) -> do
      case JsonRpcRequest -> Maybe Value
requestParams JsonRpcRequest
req of
        Maybe Value
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
          { errorCode :: Int
errorCode = -Int
32602
          , errorMessage :: Text
errorMessage = Text
"Missing parameters"
          , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
          }
        Just Value
params ->
          case Value -> Result PromptsGetRequest
forall a. FromJSON a => Value -> Result a
fromJSON Value
params of
            Error [Char]
err -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
              { errorCode :: Int
errorCode = -Int
32602
              , errorMessage :: Text
errorMessage = Text
"Invalid parameters: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
err
              , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
              }
            Success PromptsGetRequest
getReq -> do
              let args :: [(Text, Text)]
args = [(Text, Text)]
-> (Map Text Value -> [(Text, Text)])
-> Maybe (Map Text Value)
-> [(Text, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((Text, Value) -> (Text, Text))
-> [(Text, Value)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, Value
v) -> (Text
k, Value -> Text
jsonValueToText Value
v)) ([(Text, Value)] -> [(Text, Text)])
-> (Map Text Value -> [(Text, Value)])
-> Map Text Value
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList) (PromptsGetRequest -> Maybe (Map Text Value)
promptsGetArguments PromptsGetRequest
getReq)
              result <- PromptGetHandler m
getHandler (PromptsGetRequest -> Text
promptsGetName PromptsGetRequest
getReq) [(Text, Text)]
args
              case result of
                Left Error
err -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
                  { errorCode :: Int
errorCode = Error -> Int
errorCodeFromMcpError Error
err
                  , errorMessage :: Text
errorMessage = Error -> Text
errorMessageFromMcpError Error
err
                  , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
                  }
                Right Content
content -> do
                  let response :: PromptsGetResponse
response = PromptsGetResponse
                        { promptsGetDescription :: Maybe Text
promptsGetDescription = Maybe Text
forall a. Maybe a
Nothing
                        , promptsGetMessages :: [PromptMessage]
promptsGetMessages = [MessageRole -> Content -> PromptMessage
PromptMessage MessageRole
RoleUser Content
content]
                        }
                  JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> Value -> JsonRpcResponse
makeSuccessResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (PromptsGetResponse -> Value
forall a. ToJSON a => a -> Value
toJSON PromptsGetResponse
response)

-- | Handle resources/list request
handleResourcesList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleResourcesList :: forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleResourcesList McpServerHandlers m
handlers JsonRpcRequest
req =
  case McpServerHandlers m
-> Maybe (ResourceListHandler m, ResourceReadHandler m)
forall (m :: * -> *).
McpServerHandlers m
-> Maybe (ResourceListHandler m, ResourceReadHandler m)
resources McpServerHandlers m
handlers of
    Maybe (ResourceListHandler m, ResourceReadHandler m)
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
      { errorCode :: Int
errorCode = -Int
32601
      , errorMessage :: Text
errorMessage = Text
"Resources not supported"
      , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
      }
    Just (ResourceListHandler m
listHandler, ResourceReadHandler m
_) -> do
      resourcesList <- ResourceListHandler m
listHandler
      let response = ResourcesListResponse
            { resourcesListResources :: [ResourceDefinition]
resourcesListResources = [ResourceDefinition]
resourcesList
            }
      return $ makeSuccessResponse (requestId req) (toJSON response)

-- | Handle resources/read request
handleResourcesRead :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleResourcesRead :: forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleResourcesRead McpServerHandlers m
handlers JsonRpcRequest
req =
  case McpServerHandlers m
-> Maybe (ResourceListHandler m, ResourceReadHandler m)
forall (m :: * -> *).
McpServerHandlers m
-> Maybe (ResourceListHandler m, ResourceReadHandler m)
resources McpServerHandlers m
handlers of
    Maybe (ResourceListHandler m, ResourceReadHandler m)
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
      { errorCode :: Int
errorCode = -Int
32601
      , errorMessage :: Text
errorMessage = Text
"Resources not supported"
      , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
      }
    Just (ResourceListHandler m
_, ResourceReadHandler m
readHandler) -> do
      case JsonRpcRequest -> Maybe Value
requestParams JsonRpcRequest
req of
        Maybe Value
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
          { errorCode :: Int
errorCode = -Int
32602
          , errorMessage :: Text
errorMessage = Text
"Missing parameters"
          , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
          }
        Just Value
params ->
          case Value -> Result ResourcesReadRequest
forall a. FromJSON a => Value -> Result a
fromJSON Value
params of
            Error [Char]
err -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
              { errorCode :: Int
errorCode = -Int
32602
              , errorMessage :: Text
errorMessage = Text
"Invalid parameters: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
err
              , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
              }
            Success ResourcesReadRequest
readReq -> do
              result <- ResourceReadHandler m
readHandler (ResourcesReadRequest -> URI
resourcesReadUri ResourcesReadRequest
readReq)
              case result of
                Left Error
err -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
                  { errorCode :: Int
errorCode = Error -> Int
errorCodeFromMcpError Error
err
                  , errorMessage :: Text
errorMessage = Error -> Text
errorMessageFromMcpError Error
err
                  , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
                  }
                Right Content
content -> do
                  let response :: ResourcesReadResponse
response = ResourcesReadResponse
                        { resourcesReadContents :: [Content]
resourcesReadContents = [Content
content]
                        }
                  JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> Value -> JsonRpcResponse
makeSuccessResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (ResourcesReadResponse -> Value
forall a. ToJSON a => a -> Value
toJSON ResourcesReadResponse
response)

-- | Handle tools/list request
handleToolsList :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleToolsList :: forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleToolsList McpServerHandlers m
handlers JsonRpcRequest
req =
  case McpServerHandlers m -> Maybe (ToolListHandler m, ToolCallHandler m)
forall (m :: * -> *).
McpServerHandlers m -> Maybe (ToolListHandler m, ToolCallHandler m)
tools McpServerHandlers m
handlers of
    Maybe (ToolListHandler m, ToolCallHandler m)
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
      { errorCode :: Int
errorCode = -Int
32601
      , errorMessage :: Text
errorMessage = Text
"Tools not supported"
      , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
      }
    Just (ToolListHandler m
listHandler, ToolCallHandler m
_) -> do
      toolsList <- ToolListHandler m
listHandler
      let response = ToolsListResponse
            { toolsListTools :: [ToolDefinition]
toolsListTools = [ToolDefinition]
toolsList
            }
      return $ makeSuccessResponse (requestId req) (toJSON response)

-- | Handle tools/call request
handleToolsCall :: (MonadIO m) => McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleToolsCall :: forall (m :: * -> *).
MonadIO m =>
McpServerHandlers m -> JsonRpcRequest -> m JsonRpcResponse
handleToolsCall McpServerHandlers m
handlers JsonRpcRequest
req =
  case McpServerHandlers m -> Maybe (ToolListHandler m, ToolCallHandler m)
forall (m :: * -> *).
McpServerHandlers m -> Maybe (ToolListHandler m, ToolCallHandler m)
tools McpServerHandlers m
handlers of
    Maybe (ToolListHandler m, ToolCallHandler m)
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
      { errorCode :: Int
errorCode = -Int
32601
      , errorMessage :: Text
errorMessage = Text
"Tools not supported"
      , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
      }
    Just (ToolListHandler m
_, ToolCallHandler m
callHandler) -> do
      case JsonRpcRequest -> Maybe Value
requestParams JsonRpcRequest
req of
        Maybe Value
Nothing -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
          { errorCode :: Int
errorCode = -Int
32602
          , errorMessage :: Text
errorMessage = Text
"Missing parameters"
          , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
          }
        Just Value
params ->
          case Value -> Result ToolsCallRequest
forall a. FromJSON a => Value -> Result a
fromJSON Value
params of
            Error [Char]
err -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
              { errorCode :: Int
errorCode = -Int
32602
              , errorMessage :: Text
errorMessage = Text
"Invalid parameters: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
err
              , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
              }
            Success ToolsCallRequest
callReq -> do
              let args :: [(Text, Text)]
args = [(Text, Text)]
-> (Map Text Value -> [(Text, Text)])
-> Maybe (Map Text Value)
-> [(Text, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((Text, Value) -> (Text, Text))
-> [(Text, Value)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, Value
v) -> (Text
k, Value -> Text
jsonValueToText Value
v)) ([(Text, Value)] -> [(Text, Text)])
-> (Map Text Value -> [(Text, Value)])
-> Map Text Value
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList) (ToolsCallRequest -> Maybe (Map Text Value)
toolsCallArguments ToolsCallRequest
callReq)
              result <- ToolCallHandler m
callHandler (ToolsCallRequest -> Text
toolsCallName ToolsCallRequest
callReq) [(Text, Text)]
args
              case result of
                Left Error
err -> JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> JsonRpcError -> JsonRpcResponse
makeErrorResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (JsonRpcError -> JsonRpcResponse)
-> JsonRpcError -> JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ JsonRpcError
                  { errorCode :: Int
errorCode = Error -> Int
errorCodeFromMcpError Error
err
                  , errorMessage :: Text
errorMessage = Error -> Text
errorMessageFromMcpError Error
err
                  , errorData :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
                  }
                Right Content
content -> do
                  let response :: ToolsCallResponse
response = ToolsCallResponse
                        { toolsCallContent :: [Content]
toolsCallContent = [Content
content]
                        , toolsCallIsError :: Maybe Bool
toolsCallIsError = Maybe Bool
forall a. Maybe a
Nothing
                        }
                  JsonRpcResponse -> m JsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonRpcResponse -> m JsonRpcResponse)
-> JsonRpcResponse -> m JsonRpcResponse
forall a b. (a -> b) -> a -> b
$ RequestId -> Value -> JsonRpcResponse
makeSuccessResponse (JsonRpcRequest -> RequestId
requestId JsonRpcRequest
req) (ToolsCallResponse -> Value
forall a. ToJSON a => a -> Value
toJSON ToolsCallResponse
response)

-- | Convert MCP error to JSON-RPC error code
errorCodeFromMcpError :: Error -> Int
errorCodeFromMcpError :: Error -> Int
errorCodeFromMcpError (InvalidPromptName Text
_)     = -Int
32602
errorCodeFromMcpError (MissingRequiredParams Text
_) = -Int
32602
errorCodeFromMcpError (ResourceNotFound Text
_)      = -Int
32602
errorCodeFromMcpError (InternalError Text
_)         = -Int
32603
errorCodeFromMcpError (UnknownTool Text
_)           = -Int
32602
errorCodeFromMcpError (InvalidRequest Text
_)        = -Int
32600
errorCodeFromMcpError (MethodNotFound Text
_)        = -Int
32601
errorCodeFromMcpError (InvalidParams Text
_)         = -Int
32602

-- | Convert MCP error to JSON-RPC error message
errorMessageFromMcpError :: Error -> Text
errorMessageFromMcpError :: Error -> Text
errorMessageFromMcpError (InvalidPromptName Text
msg) = Text
"Invalid prompt name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
errorMessageFromMcpError (MissingRequiredParams Text
msg) = Text
"Missing required parameters: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
errorMessageFromMcpError (ResourceNotFound Text
msg) = Text
"Resource not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
errorMessageFromMcpError (InternalError Text
msg) = Text
"Internal error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
errorMessageFromMcpError (UnknownTool Text
msg) = Text
"Unknown tool: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
errorMessageFromMcpError (InvalidRequest Text
msg) = Text
"Invalid request: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
errorMessageFromMcpError (MethodNotFound Text
msg) = Text
"Method not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
errorMessageFromMcpError (InvalidParams Text
msg) = Text
"Invalid parameters: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg