{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : MCP.Server
-- Description : MCP server implementation
-- Copyright   : (C) 2025 Matthias Pall Gissurarson
-- License     : MIT
-- Maintainer  : mpg@mpg.is
-- Stability   : experimental
-- Portability : GHC
--
-- This module provides a complete MCP server implementation, including
-- message handling, state management, and JSON-RPC communication over
-- standard input/output streams.
module MCP.Server (
    -- * Server Interface
    MCPServer (..),
    ServerState (..),
    MCPServerM,
    runMCPServer,

    -- * Message Handling
    handleMessage,
    handleRequest,
    handleNotification,

    -- * Server Runner
    runServer,
    ServerConfig (..),

    -- * Utilities
    sendResponse,
    sendNotification,
    sendError,
) where

import Control.Exception (catch, throwIO)
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.State.Strict (StateT, get, put, runStateT)
import Data.Aeson (ToJSON, decode, encode, fromJSON, object, toJSON)
import Data.Aeson qualified as Aeson
import Data.ByteString.Char8 qualified as BSC
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBSC
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import System.IO (Handle, hFlush)
import System.IO.Error (isEOFError)

import MCP.Protocol hiding (capabilities)
import MCP.Protocol qualified as Protocol
import MCP.Types

-- | Server state tracking initialization, capabilities, and subscriptions
data ServerState = ServerState
    { ServerState -> Bool
serverInitialized :: Bool
    , ServerState -> ServerCapabilities
serverCapabilities :: ServerCapabilities
    , ServerState -> Maybe ClientCapabilities
clientCapabilities :: Maybe ClientCapabilities
    , ServerState -> Maybe Implementation
serverInfo :: Maybe Implementation
    , ServerState -> Map Text ()
subscriptions :: Map Text ()
    }
    deriving (Int -> ServerState -> ShowS
[ServerState] -> ShowS
ServerState -> String
(Int -> ServerState -> ShowS)
-> (ServerState -> String)
-> ([ServerState] -> ShowS)
-> Show ServerState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerState -> ShowS
showsPrec :: Int -> ServerState -> ShowS
$cshow :: ServerState -> String
show :: ServerState -> String
$cshowList :: [ServerState] -> ShowS
showList :: [ServerState] -> ShowS
Show)

-- | Configuration for running an MCP server
data ServerConfig = ServerConfig
    { ServerConfig -> Handle
configInput :: Handle
    , ServerConfig -> Handle
configOutput :: Handle
    , ServerConfig -> Implementation
configServerInfo :: Implementation
    , ServerConfig -> ServerCapabilities
configCapabilities :: ServerCapabilities
    }
    deriving (Int -> ServerConfig -> ShowS
[ServerConfig] -> ShowS
ServerConfig -> String
(Int -> ServerConfig -> ShowS)
-> (ServerConfig -> String)
-> ([ServerConfig] -> ShowS)
-> Show ServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerConfig -> ShowS
showsPrec :: Int -> ServerConfig -> ShowS
$cshow :: ServerConfig -> String
show :: ServerConfig -> String
$cshowList :: [ServerConfig] -> ShowS
showList :: [ServerConfig] -> ShowS
Show)

-- | The monad stack for MCP server operations
type MCPServerM = ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))

-- | Run an MCPServerM computation with the given config and initial state
runMCPServer :: ServerConfig -> ServerState -> MCPServerM a -> IO (Either Text (a, ServerState))
runMCPServer :: forall a.
ServerConfig
-> ServerState -> MCPServerM a -> IO (Either Text (a, ServerState))
runMCPServer ServerConfig
config ServerState
state MCPServerM a
action = ExceptT Text IO (a, ServerState)
-> IO (Either Text (a, ServerState))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO (a, ServerState)
 -> IO (Either Text (a, ServerState)))
-> ExceptT Text IO (a, ServerState)
-> IO (Either Text (a, ServerState))
forall a b. (a -> b) -> a -> b
$ StateT ServerState (ExceptT Text IO) a
-> ServerState -> ExceptT Text IO (a, ServerState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (MCPServerM a
-> ServerConfig -> StateT ServerState (ExceptT Text IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT MCPServerM a
action ServerConfig
config) ServerState
state

initialServerState :: ServerCapabilities -> ServerState
initialServerState :: ServerCapabilities -> ServerState
initialServerState ServerCapabilities
caps =
    ServerState
        { $sel:serverInitialized:ServerState :: Bool
serverInitialized = Bool
False
        , $sel:serverCapabilities:ServerState :: ServerCapabilities
serverCapabilities = ServerCapabilities
caps
        , $sel:clientCapabilities:ServerState :: Maybe ClientCapabilities
clientCapabilities = Maybe ClientCapabilities
forall a. Maybe a
Nothing
        , $sel:serverInfo:ServerState :: Maybe Implementation
serverInfo = Maybe Implementation
forall a. Maybe a
Nothing
        , $sel:subscriptions:ServerState :: Map Text ()
subscriptions = Map Text ()
forall k a. Map k a
Map.empty
        }

-- | Type class for implementing MCP server handlers
class (Monad m) => MCPServer m where
    handleListResources :: ListResourcesParams -> m ListResourcesResult
    handleReadResource :: ReadResourceParams -> m ReadResourceResult
    handleListResourceTemplates :: ListResourceTemplatesParams -> m ListResourceTemplatesResult
    handleListPrompts :: ListPromptsParams -> m ListPromptsResult
    handleGetPrompt :: GetPromptParams -> m GetPromptResult
    handleListTools :: ListToolsParams -> m ListToolsResult
    handleCallTool :: CallToolParams -> m CallToolResult
    handleComplete :: CompleteParams -> m CompleteResult
    handleSetLevel :: SetLevelParams -> m ()

-- | Send a JSON-RPC response
sendResponse :: (MonadIO m, ToJSON a) => Handle -> RequestId -> a -> m ()
sendResponse :: forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse Handle
handle RequestId
reqId a
result = 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
$ do
    let response :: JSONRPCResponse
response = Text -> RequestId -> Value -> JSONRPCResponse
JSONRPCResponse Text
"2.0" RequestId
reqId (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
result)
    Handle -> ByteString -> IO ()
LBSC.hPutStrLn Handle
handle (JSONRPCResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode JSONRPCResponse
response)
    Handle -> IO ()
hFlush Handle
handle

-- | Send a JSON-RPC error response
sendError :: (MonadIO m) => Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError :: forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError Handle
handle RequestId
reqId JSONRPCErrorInfo
errorInfo = 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
$ do
    let response :: JSONRPCError
response = Text -> RequestId -> JSONRPCErrorInfo -> JSONRPCError
JSONRPCError Text
"2.0" RequestId
reqId JSONRPCErrorInfo
errorInfo
    Handle -> ByteString -> IO ()
LBSC.hPutStrLn Handle
handle (JSONRPCError -> ByteString
forall a. ToJSON a => a -> ByteString
encode JSONRPCError
response)
    Handle -> IO ()
hFlush Handle
handle

-- | Send a JSON-RPC notification
sendNotification :: (MonadIO m, ToJSON a) => Handle -> Text -> a -> m ()
sendNotification :: forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> Text -> a -> m ()
sendNotification Handle
handle Text
method a
params = 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
$ do
    let notification :: JSONRPCNotification
notification = Text -> Text -> Maybe Value -> JSONRPCNotification
JSONRPCNotification Text
"2.0" Text
method (Value -> Maybe Value
forall a. a -> Maybe a
Just (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
params))
    Handle -> ByteString -> IO ()
LBSC.hPutStrLn Handle
handle (JSONRPCNotification -> ByteString
forall a. ToJSON a => a -> ByteString
encode JSONRPCNotification
notification)
    Handle -> IO ()
hFlush Handle
handle

-- | Handle an incoming JSON-RPC message
handleMessage :: (MCPServer MCPServerM) => BSC.ByteString -> MCPServerM (Maybe ())
handleMessage :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
ByteString -> MCPServerM (Maybe ())
handleMessage ByteString
input = do
    case ByteString -> Maybe JSONRPCMessage
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> ByteString
LBS.fromStrict ByteString
input) :: Maybe JSONRPCMessage of
        Maybe JSONRPCMessage
Nothing -> do
            ServerConfig
config <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) (Value -> RequestId
RequestId (Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"unknown" :: Text))) (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32700) Text
"Parse error" Maybe Value
forall a. Maybe a
Nothing
            Maybe () -> MCPServerM (Maybe ())
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ()
forall a. Maybe a
Nothing
        Just JSONRPCMessage
msg -> case JSONRPCMessage
msg of
            RequestMessage JSONRPCRequest
req -> do
                JSONRPCRequest
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
JSONRPCRequest
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
handleRequest JSONRPCRequest
req
                Maybe () -> MCPServerM (Maybe ())
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just ())
            NotificationMessage JSONRPCNotification
notif -> do
                JSONRPCNotification
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
handleNotification JSONRPCNotification
notif
                Maybe () -> MCPServerM (Maybe ())
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just ())
            JSONRPCMessage
_ -> do
                ServerConfig
config <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
                Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) (Value -> RequestId
RequestId (Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"unknown" :: Text))) (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                    Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32600) Text
"Invalid Request" Maybe Value
forall a. Maybe a
Nothing
                Maybe () -> MCPServerM (Maybe ())
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ()
forall a. Maybe a
Nothing

-- | Handle a JSON-RPC request
handleRequest :: (MCPServer MCPServerM) => JSONRPCRequest -> MCPServerM ()
handleRequest :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
JSONRPCRequest
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
handleRequest (JSONRPCRequest Text
_ RequestId
reqId Text
method Maybe Value
params) = do
    ServerConfig
config <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ServerState
state <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerState
forall s (m :: * -> *). MonadState s m => m s
get

    case Text
method of
        Text
"initialize" -> case Maybe Value
params of
            Just Value
p -> case Value -> Result InitializeParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                Aeson.Success InitializeParams
initParams -> RequestId
-> InitializeParams
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
handleInitialize RequestId
reqId InitializeParams
initParams
                Aeson.Error String
e ->
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
            Maybe Value
Nothing ->
                Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                    Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"ping" -> RequestId
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
handlePing RequestId
reqId
        Text
"resources/list" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ListResourcesParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ListResourcesParams
listParams -> do
                            ListResourcesResult
result <- ListResourcesParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListResourcesResult
forall (m :: * -> *).
MCPServer m =>
ListResourcesParams -> m ListResourcesResult
handleListResources ListResourcesParams
listParams
                            Handle
-> RequestId
-> ListResourcesResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ListResourcesResult
result
                        Aeson.Error String
e ->
                            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing -> do
                        ListResourcesResult
result <- ListResourcesParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListResourcesResult
forall (m :: * -> *).
MCPServer m =>
ListResourcesParams -> m ListResourcesResult
handleListResources (Maybe Cursor -> ListResourcesParams
ListResourcesParams Maybe Cursor
forall a. Maybe a
Nothing)
                        Handle
-> RequestId
-> ListResourcesResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ListResourcesResult
result
        Text
"resources/read" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ReadResourceParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ReadResourceParams
readParams -> do
                            ReadResourceResult
result <- ReadResourceParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ReadResourceResult
forall (m :: * -> *).
MCPServer m =>
ReadResourceParams -> m ReadResourceResult
handleReadResource ReadResourceParams
readParams
                            Handle
-> RequestId
-> ReadResourceResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ReadResourceResult
result
                        Aeson.Error String
e ->
                            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing ->
                        Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                            Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"resources/templates/list" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ListResourceTemplatesParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ListResourceTemplatesParams
listParams -> do
                            ListResourceTemplatesResult
result <- ListResourceTemplatesParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListResourceTemplatesResult
forall (m :: * -> *).
MCPServer m =>
ListResourceTemplatesParams -> m ListResourceTemplatesResult
handleListResourceTemplates ListResourceTemplatesParams
listParams
                            Handle
-> RequestId
-> ListResourceTemplatesResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ListResourceTemplatesResult
result
                        Aeson.Error String
e ->
                            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing -> do
                        ListResourceTemplatesResult
result <- ListResourceTemplatesParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListResourceTemplatesResult
forall (m :: * -> *).
MCPServer m =>
ListResourceTemplatesParams -> m ListResourceTemplatesResult
handleListResourceTemplates (Maybe Cursor -> ListResourceTemplatesParams
ListResourceTemplatesParams Maybe Cursor
forall a. Maybe a
Nothing)
                        Handle
-> RequestId
-> ListResourceTemplatesResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ListResourceTemplatesResult
result
        Text
"prompts/list" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ListPromptsParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ListPromptsParams
listParams -> do
                            ListPromptsResult
result <- ListPromptsParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListPromptsResult
forall (m :: * -> *).
MCPServer m =>
ListPromptsParams -> m ListPromptsResult
handleListPrompts ListPromptsParams
listParams
                            Handle
-> RequestId
-> ListPromptsResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ListPromptsResult
result
                        Aeson.Error String
e ->
                            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing -> do
                        ListPromptsResult
result <- ListPromptsParams
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     ListPromptsResult
forall (m :: * -> *).
MCPServer m =>
ListPromptsParams -> m ListPromptsResult
handleListPrompts (Maybe Cursor -> ListPromptsParams
ListPromptsParams Maybe Cursor
forall a. Maybe a
Nothing)
                        Handle
-> RequestId
-> ListPromptsResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ListPromptsResult
result
        Text
"prompts/get" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result GetPromptParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success GetPromptParams
getParams -> do
                            GetPromptResult
result <- GetPromptParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) GetPromptResult
forall (m :: * -> *).
MCPServer m =>
GetPromptParams -> m GetPromptResult
handleGetPrompt GetPromptParams
getParams
                            Handle
-> RequestId
-> GetPromptResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId GetPromptResult
result
                        Aeson.Error String
e ->
                            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing ->
                        Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                            Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"tools/list" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result ListToolsParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success ListToolsParams
listParams -> do
                            ListToolsResult
result <- ListToolsParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) ListToolsResult
forall (m :: * -> *).
MCPServer m =>
ListToolsParams -> m ListToolsResult
handleListTools ListToolsParams
listParams
                            Handle
-> RequestId
-> ListToolsResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ListToolsResult
result
                        Aeson.Error String
e ->
                            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing -> do
                        ListToolsResult
result <- ListToolsParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) ListToolsResult
forall (m :: * -> *).
MCPServer m =>
ListToolsParams -> m ListToolsResult
handleListTools (Maybe Cursor -> ListToolsParams
ListToolsParams Maybe Cursor
forall a. Maybe a
Nothing)
                        Handle
-> RequestId
-> ListToolsResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ListToolsResult
result
        Text
"tools/call" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result CallToolParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success CallToolParams
callParams -> do
                            CallToolResult
result <- CallToolParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) CallToolResult
forall (m :: * -> *).
MCPServer m =>
CallToolParams -> m CallToolResult
handleCallTool CallToolParams
callParams
                            Handle
-> RequestId
-> CallToolResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId CallToolResult
result
                        Aeson.Error String
e ->
                            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing ->
                        Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                            Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"completion/complete" -> do
            if Bool -> Bool
not (ServerState -> Bool
serverInitialized ServerState
state)
                then
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32002) Text
"Server not initialized" Maybe Value
forall a. Maybe a
Nothing
                else case Maybe Value
params of
                    Just Value
p -> case Value -> Result CompleteParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                        Aeson.Success CompleteParams
completeParams -> do
                            CompleteResult
result <- CompleteParams
-> ReaderT
     ServerConfig (StateT ServerState (ExceptT Text IO)) CompleteResult
forall (m :: * -> *).
MCPServer m =>
CompleteParams -> m CompleteResult
handleComplete CompleteParams
completeParams
                            Handle
-> RequestId
-> CompleteResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId CompleteResult
result
                        Aeson.Error String
e ->
                            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
                    Maybe Value
Nothing ->
                        Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                            Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
"logging/setLevel" -> case Maybe Value
params of
            Just Value
p -> case Value -> Result SetLevelParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
p of
                Aeson.Success SetLevelParams
setLevelParams -> do
                    ()
_ <- SetLevelParams
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *). MCPServer m => SetLevelParams -> m ()
handleSetLevel SetLevelParams
setLevelParams
                    -- SetLevel response is just an empty object
                    Handle
-> RequestId
-> Value
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ([Pair] -> Value
object [])
                Aeson.Error String
e ->
                    Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                        Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) (Text
"Invalid params: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e) Maybe Value
forall a. Maybe a
Nothing
            Maybe Value
Nothing ->
                Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                    Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32602) Text
"Missing params" Maybe Value
forall a. Maybe a
Nothing
        Text
_ ->
            Handle
-> RequestId
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> RequestId -> JSONRPCErrorInfo -> m ()
sendError (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId (JSONRPCErrorInfo
 -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ())
-> JSONRPCErrorInfo
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a b. (a -> b) -> a -> b
$
                Int -> Text -> Maybe Value -> JSONRPCErrorInfo
JSONRPCErrorInfo (-Int
32601) Text
"Method not found" Maybe Value
forall a. Maybe a
Nothing

handleInitialize :: RequestId -> InitializeParams -> MCPServerM ()
handleInitialize :: RequestId
-> InitializeParams
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
handleInitialize RequestId
reqId InitializeParams
params = do
    ServerConfig
config <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ServerState
state <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerState
forall s (m :: * -> *). MonadState s m => m s
get

    let InitializeParams{$sel:capabilities:InitializeParams :: InitializeParams -> ClientCapabilities
capabilities = ClientCapabilities
clientCaps} = InitializeParams
params

    ServerState
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
        ServerState
state
            { serverInitialized = True
            , clientCapabilities = Just clientCaps
            , serverInfo = Just (configServerInfo config)
            }

    let result :: InitializeResult
result =
            InitializeResult
                { $sel:protocolVersion:InitializeResult :: Text
protocolVersion = Text
"2024-11-05"
                , $sel:capabilities:InitializeResult :: ServerCapabilities
capabilities = ServerState -> ServerCapabilities
serverCapabilities ServerState
state
                , $sel:serverInfo:InitializeResult :: Implementation
serverInfo = ServerConfig -> Implementation
configServerInfo ServerConfig
config
                , $sel:instructions:InitializeResult :: Maybe Text
instructions = Maybe Text
forall a. Maybe a
Nothing
                , $sel:_meta:InitializeResult :: Maybe Metadata
_meta = Maybe Metadata
forall a. Maybe a
Nothing
                }

    Handle
-> RequestId
-> InitializeResult
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId InitializeResult
result

handlePing :: RequestId -> MCPServerM ()
handlePing :: RequestId
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
handlePing RequestId
reqId = do
    ServerConfig
config <- ReaderT
  ServerConfig (StateT ServerState (ExceptT Text IO)) ServerConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    -- Ping response is just an empty object in MCP
    Handle
-> RequestId
-> Value
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
Handle -> RequestId -> a -> m ()
sendResponse (ServerConfig -> Handle
configOutput ServerConfig
config) RequestId
reqId ([Pair] -> Value
object [])

-- | Handle a JSON-RPC notification
handleNotification :: JSONRPCNotification -> MCPServerM ()
handleNotification :: JSONRPCNotification
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
handleNotification JSONRPCNotification
_ = do
    ()
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Run the MCP server with the given configuration
runServer :: (MCPServer MCPServerM) => ServerConfig -> IO ()
runServer :: MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
ServerConfig -> IO ()
runServer ServerConfig
config = do
    let initialState :: ServerState
initialState = ServerCapabilities -> ServerState
initialServerState (ServerConfig -> ServerCapabilities
configCapabilities ServerConfig
config)

    let loop :: ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
loop = do
            Either () ByteString
eofOrLine <-
                IO (Either () ByteString)
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     (Either () ByteString)
forall a.
IO a
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either () ByteString)
 -> ReaderT
      ServerConfig
      (StateT ServerState (ExceptT Text IO))
      (Either () ByteString))
-> IO (Either () ByteString)
-> ReaderT
     ServerConfig
     (StateT ServerState (ExceptT Text IO))
     (Either () ByteString)
forall a b. (a -> b) -> a -> b
$
                    IO (Either () ByteString)
-> (IOError -> IO (Either () ByteString))
-> IO (Either () ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
                        (ByteString -> Either () ByteString
forall a b. b -> Either a b
Right (ByteString -> Either () ByteString)
-> IO ByteString -> IO (Either () ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
BSC.hGetLine (ServerConfig -> Handle
configInput ServerConfig
config))
                        (\IOError
e -> if IOError -> Bool
isEOFError IOError
e then Either () ByteString -> IO (Either () ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either () ByteString
forall a b. a -> Either a b
Left ()) else IOError -> IO (Either () ByteString)
forall e a. Exception e => e -> IO a
throwIO IOError
e)
            case Either () ByteString
eofOrLine of
                Left () -> ()
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- EOF reached, exit gracefully
                Right ByteString
line -> do
                    Maybe ()
result <- ByteString -> MCPServerM (Maybe ())
MCPServer
  (ReaderT ServerConfig (StateT ServerState (ExceptT Text IO))) =>
ByteString -> MCPServerM (Maybe ())
handleMessage ByteString
line
                    case Maybe ()
result of
                        Just () -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
loop
                        Maybe ()
Nothing -> ()
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
forall a.
a -> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Either Text ((), ServerState)
result <- ServerConfig
-> ServerState
-> ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
-> IO (Either Text ((), ServerState))
forall a.
ServerConfig
-> ServerState -> MCPServerM a -> IO (Either Text (a, ServerState))
runMCPServer ServerConfig
config ServerState
initialState ReaderT ServerConfig (StateT ServerState (ExceptT Text IO)) ()
loop
    case Either Text ((), ServerState)
result of
        Left Text
err -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Server error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
err
        Right ((), ServerState)
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Don't print "Server terminated" for clean EOF