{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.MCP.Server
  ( Server,
    ServerHandler,
    ResourceReadHandler,
    ToolCallHandler,
    PromptHandler,
    createServer,
    registerResources,
    registerResourceReadHandler,
    registerTools,
    registerToolCallHandler,
    registerPrompts,
    registerPromptHandler,
    runServerWithTransport,
    withTransportServer,
    handleRequest,
    handleMessage,
  )
where

import Control.Concurrent.Async qualified as Async
import Control.Concurrent.STM
import Control.Exception (SomeException, throwIO, toException, try)
import Data.Aeson
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Network.MCP.Server.Types
import Network.MCP.Transport.Types
import Network.MCP.Types
import UnliftIO.Async qualified as UnliftIO

createServer :: ServerInfo -> ServerCapabilities -> Text -> IO Server
createServer :: ServerInfo -> ServerCapabilities -> Text -> IO Server
createServer ServerInfo
info ServerCapabilities
caps Text
instructions = do
  TVar [Resource]
resourcesVar <- [Resource] -> IO (TVar [Resource])
forall a. a -> IO (TVar a)
newTVarIO []
  TVar [Tool]
toolsVar <- [Tool] -> IO (TVar [Tool])
forall a. a -> IO (TVar a)
newTVarIO []
  TVar [Prompt]
promptsVar <- [Prompt] -> IO (TVar [Prompt])
forall a. a -> IO (TVar a)
newTVarIO []
  TVar (Maybe ResourceReadHandler)
resourceHandlerVar <- Maybe ResourceReadHandler -> IO (TVar (Maybe ResourceReadHandler))
forall a. a -> IO (TVar a)
newTVarIO Maybe ResourceReadHandler
forall a. Maybe a
Nothing
  TVar (Maybe ToolCallHandler)
toolHandlerVar <- Maybe ToolCallHandler -> IO (TVar (Maybe ToolCallHandler))
forall a. a -> IO (TVar a)
newTVarIO Maybe ToolCallHandler
forall a. Maybe a
Nothing
  TVar (Maybe PromptHandler)
promptHandlerVar <- Maybe PromptHandler -> IO (TVar (Maybe PromptHandler))
forall a. a -> IO (TVar a)
newTVarIO Maybe PromptHandler
forall a. Maybe a
Nothing

  -- Initialize message handlers map
  TVar
  (Map Text (Value -> Server -> IO (Either SomeException Value)))
handlersVar <- Map Text (Value -> Server -> IO (Either SomeException Value))
-> IO
     (TVar
        (Map Text (Value -> Server -> IO (Either SomeException Value))))
forall a. a -> IO (TVar a)
newTVarIO Map Text (Value -> Server -> IO (Either SomeException Value))
forall k a. Map k a
Map.empty

  let server :: Server
server =
        Server
          { $sel:serverInfo:Server :: ServerInfo
serverInfo = ServerInfo
info,
            $sel:serverCapabilities:Server :: ServerCapabilities
serverCapabilities = ServerCapabilities
caps,
            $sel:serverResources:Server :: TVar [Resource]
serverResources = TVar [Resource]
resourcesVar,
            $sel:serverTools:Server :: TVar [Tool]
serverTools = TVar [Tool]
toolsVar,
            $sel:serverPrompts:Server :: TVar [Prompt]
serverPrompts = TVar [Prompt]
promptsVar,
            $sel:serverInstructions:Server :: Text
serverInstructions = Text
instructions,
            $sel:serverResourceReadHandler:Server :: TVar (Maybe ResourceReadHandler)
serverResourceReadHandler = TVar (Maybe ResourceReadHandler)
resourceHandlerVar,
            $sel:serverToolCallHandler:Server :: TVar (Maybe ToolCallHandler)
serverToolCallHandler = TVar (Maybe ToolCallHandler)
toolHandlerVar,
            $sel:serverPromptHandler:Server :: TVar (Maybe PromptHandler)
serverPromptHandler = TVar (Maybe PromptHandler)
promptHandlerVar,
            $sel:serverMessageHandlers:Server :: TVar
  (Map Text (Value -> Server -> IO (Either SomeException Value)))
serverMessageHandlers = TVar
  (Map Text (Value -> Server -> IO (Either SomeException Value)))
handlersVar
          }

  -- Register standard request handlers
  Server -> IO ()
registerInitializeHandler Server
server
  Server -> IO ()
registerListResourcesHandler Server
server
  Server -> IO ()
registerReadResourceHandler Server
server
  Server -> IO ()
registerListToolsHandler Server
server
  Server -> IO ()
registerCallToolHandler Server
server
  Server -> IO ()
registerListPromptsHandler Server
server
  Server -> IO ()
registerGetPromptHandler Server
server

  return Server
server

-- | Register available resources
registerResources :: Server -> [Resource] -> IO ()
registerResources :: Server -> [Resource] -> IO ()
registerResources Server
server [Resource]
resources = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [Resource] -> [Resource] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Server -> TVar [Resource]
serverResources Server
server) [Resource]
resources

-- | Register resource read handler
registerResourceReadHandler :: Server -> ResourceReadHandler -> IO ()
registerResourceReadHandler :: Server -> ResourceReadHandler -> IO ()
registerResourceReadHandler Server
server ResourceReadHandler
handler = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe ResourceReadHandler)
-> Maybe ResourceReadHandler -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Server -> TVar (Maybe ResourceReadHandler)
serverResourceReadHandler Server
server) (ResourceReadHandler -> Maybe ResourceReadHandler
forall a. a -> Maybe a
Just ResourceReadHandler
handler)

-- | Register available tools
registerTools :: Server -> [Tool] -> IO ()
registerTools :: Server -> [Tool] -> IO ()
registerTools Server
server [Tool]
tools = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [Tool] -> [Tool] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Server -> TVar [Tool]
serverTools Server
server) [Tool]
tools

-- | Register tool call handler
registerToolCallHandler :: Server -> ToolCallHandler -> IO ()
registerToolCallHandler :: Server -> ToolCallHandler -> IO ()
registerToolCallHandler Server
server ToolCallHandler
handler = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe ToolCallHandler) -> Maybe ToolCallHandler -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Server -> TVar (Maybe ToolCallHandler)
serverToolCallHandler Server
server) (ToolCallHandler -> Maybe ToolCallHandler
forall a. a -> Maybe a
Just ToolCallHandler
handler)

-- | Register available prompts
registerPrompts :: Server -> [Prompt] -> IO ()
registerPrompts :: Server -> [Prompt] -> IO ()
registerPrompts Server
server [Prompt]
prompts = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [Prompt] -> [Prompt] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Server -> TVar [Prompt]
serverPrompts Server
server) [Prompt]
prompts

-- | Register prompt handler
registerPromptHandler :: Server -> PromptHandler -> IO ()
registerPromptHandler :: Server -> PromptHandler -> IO ()
registerPromptHandler Server
server PromptHandler
handler = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe PromptHandler) -> Maybe PromptHandler -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Server -> TVar (Maybe PromptHandler)
serverPromptHandler Server
server) (PromptHandler -> Maybe PromptHandler
forall a. a -> Maybe a
Just PromptHandler
handler)

-- | Run the server, handling messages until the transport mechanism shuts down.
runServerWithTransport :: (Transport t) => Server -> t -> IO ()
runServerWithTransport :: forall t. Transport t => Server -> t -> IO ()
runServerWithTransport Server
server t
t =
  t -> (Message -> IO (Maybe Message)) -> IO ()
forall t.
Transport t =>
t -> (Message -> IO (Maybe Message)) -> IO ()
handleMessages t
t (Server -> Message -> IO (Maybe Message)
handleMessage Server
server)

-- | Run a transport server while the action is executed.
-- If the action throws an exception or terminates the server will be stopped.
withTransportServer :: (Transport t) => Server -> t -> (UnliftIO.Async () -> IO a) -> IO a
withTransportServer :: forall t a.
Transport t =>
Server -> t -> (Async () -> IO a) -> IO a
withTransportServer Server
server t
t Async () -> IO a
action = do
  let runServer :: IO ()
runServer = do
        -- Run the server with the provided transport
        Server -> t -> IO ()
forall t. Transport t => Server -> t -> IO ()
runServerWithTransport Server
server t
t
  IO () -> (Async () -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync IO ()
runServer ((Async () -> IO a) -> IO a) -> (Async () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async ()
handle -> do
    -- Execute the action with the server running
    -- The server will be terminated when the action completes
    Async () -> IO a
action Async ()
handle

-- Helper to process a message
handleMessage :: Server -> Message -> IO (Maybe Message)
handleMessage :: Server -> Message -> IO (Maybe Message)
handleMessage Server
server Message
msg = case Message
msg of
  RequestMessage Request
request ->
    Server -> Request -> IO (Either SomeException Response)
handleRequest Server
server Request
request IO (Either SomeException Response)
-> (Either SomeException Response -> IO (Maybe Message))
-> IO (Maybe Message)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right Response
response -> Maybe Message -> IO (Maybe Message)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Message -> IO (Maybe Message))
-> (Message -> Maybe Message) -> Message -> IO (Maybe Message)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> IO (Maybe Message)) -> Message -> IO (Maybe Message)
forall a b. (a -> b) -> a -> b
$ (Response -> Message
ResponseMessage Response
response)
      Left SomeException
err -> Maybe Message -> IO (Maybe Message)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Message -> IO (Maybe Message))
-> (Message -> Maybe Message) -> Message -> IO (Maybe Message)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> IO (Maybe Message)) -> Message -> IO (Maybe Message)
forall a b. (a -> b) -> a -> b
$ Request -> SomeException -> Message
mkErrorResponse Request
request SomeException
err
  NotificationMessage Notification
notification -> do
    Server -> Notification -> IO ()
handleNotification Server
server Notification
notification
    pure Maybe Message
forall a. Maybe a
Nothing
  Message
_ -> do
    TransportError -> IO (Maybe Message)
forall e a. Exception e => e -> IO a
throwIO (TransportError -> IO (Maybe Message))
-> TransportError -> IO (Maybe Message)
forall a b. (a -> b) -> a -> b
$ [Char] -> TransportError
TransportError ([Char] -> TransportError) -> [Char] -> TransportError
forall a b. (a -> b) -> a -> b
$ [Char]
"Received unexpected message type in handleMessage: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Message -> [Char]
forall a. Show a => a -> [Char]
show Message
msg

-- Helper to send error responses
mkErrorResponse :: Request -> SomeException -> Message
mkErrorResponse :: Request -> SomeException -> Message
mkErrorResponse Request
request SomeException
err =
  let errorResponse :: Response
errorResponse =
        Response
          { $sel:responseJsonrpc:Response :: JSONRPC
responseJsonrpc = Text -> JSONRPC
JSONRPC Text
"2.0",
            $sel:responseId:Response :: Value
responseId = Request -> Value
requestId Request
request,
            $sel:responseResult:Response :: Maybe Value
responseResult = Maybe Value
forall a. Maybe a
Nothing,
            $sel:responseError:Response :: Maybe ErrorResponse
responseError =
              ErrorResponse -> Maybe ErrorResponse
forall a. a -> Maybe a
Just (ErrorResponse -> Maybe ErrorResponse)
-> ErrorResponse -> Maybe ErrorResponse
forall a b. (a -> b) -> a -> b
$
                ErrorResponse
                  { $sel:errorCode:ErrorResponse :: Int
errorCode = -Int
32603,
                    $sel:errorMessage:ErrorResponse :: Text
errorMessage = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
err,
                    $sel:errorData:ErrorResponse :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
                  }
          }
   in (Response -> Message
ResponseMessage Response
errorResponse)

-- | Handle a request
handleRequest :: Server -> Request -> IO (Either SomeException Response)
handleRequest :: Server -> Request -> IO (Either SomeException Response)
handleRequest Server
server Request
request = do
  let method :: Text
method = Request -> Text
requestMethod Request
request
      params :: Value
params = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Request -> Maybe Value
requestParams Request
request)

  Map Text (Value -> Server -> IO (Either SomeException Value))
handlers <- TVar
  (Map Text (Value -> Server -> IO (Either SomeException Value)))
-> IO
     (Map Text (Value -> Server -> IO (Either SomeException Value)))
forall a. TVar a -> IO a
readTVarIO (Server
-> TVar
     (Map Text (Value -> Server -> IO (Either SomeException Value)))
serverMessageHandlers Server
server)
  case Text
-> Map Text (Value -> Server -> IO (Either SomeException Value))
-> Maybe (Value -> Server -> IO (Either SomeException Value))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
method Map Text (Value -> Server -> IO (Either SomeException Value))
handlers of
    Just Value -> Server -> IO (Either SomeException Value)
handler -> do
      Either SomeException (Either SomeException Value)
e'result <- IO (Either SomeException Value)
-> IO (Either SomeException (Either SomeException Value))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Either SomeException Value)
 -> IO (Either SomeException (Either SomeException Value)))
-> IO (Either SomeException Value)
-> IO (Either SomeException (Either SomeException Value))
forall a b. (a -> b) -> a -> b
$ Value -> Server -> IO (Either SomeException Value)
handler Value
params Server
server
      case Either SomeException (Either SomeException Value)
e'result of
        Right Either SomeException Value
value ->
          Either SomeException Response -> IO (Either SomeException Response)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Response
 -> IO (Either SomeException Response))
-> Either SomeException Response
-> IO (Either SomeException Response)
forall a b. (a -> b) -> a -> b
$
            Response -> Either SomeException Response
forall a b. b -> Either a b
Right (Response -> Either SomeException Response)
-> Response -> Either SomeException Response
forall a b. (a -> b) -> a -> b
$
              Response
                { $sel:responseJsonrpc:Response :: JSONRPC
responseJsonrpc = Text -> JSONRPC
JSONRPC Text
"2.0",
                  $sel:responseId:Response :: Value
responseId = Request -> Value
requestId Request
request,
                  $sel:responseResult:Response :: Maybe Value
responseResult = case Either SomeException Value
value of
                    Left SomeException
_err -> [Char] -> Maybe Value
forall a. HasCallStack => [Char] -> a
error (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
_err) -- WAT?
                    Right Value
v -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v,
                  $sel:responseError:Response :: Maybe ErrorResponse
responseError = Maybe ErrorResponse
forall a. Maybe a
Nothing
                }
        Left SomeException
err -> Either SomeException Response -> IO (Either SomeException Response)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Response
 -> IO (Either SomeException Response))
-> Either SomeException Response
-> IO (Either SomeException Response)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException Response
forall a b. a -> Either a b
Left SomeException
err
    Maybe (Value -> Server -> IO (Either SomeException Value))
Nothing ->
      Either SomeException Response -> IO (Either SomeException Response)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Response
 -> IO (Either SomeException Response))
-> Either SomeException Response
-> IO (Either SomeException Response)
forall a b. (a -> b) -> a -> b
$
        Response -> Either SomeException Response
forall a b. b -> Either a b
Right (Response -> Either SomeException Response)
-> Response -> Either SomeException Response
forall a b. (a -> b) -> a -> b
$
          Response
            { $sel:responseJsonrpc:Response :: JSONRPC
responseJsonrpc = Text -> JSONRPC
JSONRPC Text
"2.0",
              $sel:responseId:Response :: Value
responseId = Request -> Value
requestId Request
request,
              $sel:responseResult:Response :: Maybe Value
responseResult = Maybe Value
forall a. Maybe a
Nothing,
              $sel:responseError:Response :: Maybe ErrorResponse
responseError =
                ErrorResponse -> Maybe ErrorResponse
forall a. a -> Maybe a
Just (ErrorResponse -> Maybe ErrorResponse)
-> ErrorResponse -> Maybe ErrorResponse
forall a b. (a -> b) -> a -> b
$
                  ErrorResponse
                    { $sel:errorCode:ErrorResponse :: Int
errorCode = -Int
32601,
                      $sel:errorMessage:ErrorResponse :: Text
errorMessage = Text
"Method not found",
                      $sel:errorData:ErrorResponse :: Maybe Value
errorData = Maybe Value
forall a. Maybe a
Nothing
                    }
            }

-- | Handle a notification
handleNotification :: Server -> Notification -> IO ()
handleNotification :: Server -> Notification -> IO ()
handleNotification Server
_server Notification
notification = do
  let _method :: Text
_method = Notification -> Text
notificationMethod Notification
notification
      _params :: Value
_params = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Notification -> Maybe Value
notificationParams Notification
notification)

  -- TODO: Implement notification handling logic

  () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Register a request handler
registerRequestHandler :: Server -> Text -> (Value -> Server -> IO (Either SomeException Value)) -> IO ()
registerRequestHandler :: Server
-> Text
-> (Value -> Server -> IO (Either SomeException Value))
-> IO ()
registerRequestHandler Server
server Text
method Value -> Server -> IO (Either SomeException Value)
handler = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Map Text (Value -> Server -> IO (Either SomeException Value))
handlers <- TVar
  (Map Text (Value -> Server -> IO (Either SomeException Value)))
-> STM
     (Map Text (Value -> Server -> IO (Either SomeException Value)))
forall a. TVar a -> STM a
readTVar (Server
-> TVar
     (Map Text (Value -> Server -> IO (Either SomeException Value)))
serverMessageHandlers Server
server)
  TVar
  (Map Text (Value -> Server -> IO (Either SomeException Value)))
-> Map Text (Value -> Server -> IO (Either SomeException Value))
-> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Server
-> TVar
     (Map Text (Value -> Server -> IO (Either SomeException Value)))
serverMessageHandlers Server
server) (Text
-> (Value -> Server -> IO (Either SomeException Value))
-> Map Text (Value -> Server -> IO (Either SomeException Value))
-> Map Text (Value -> Server -> IO (Either SomeException Value))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
method Value -> Server -> IO (Either SomeException Value)
handler Map Text (Value -> Server -> IO (Either SomeException Value))
handlers)

-- | Register initialize handler
registerInitializeHandler :: Server -> IO ()
registerInitializeHandler :: Server -> IO ()
registerInitializeHandler Server
server = Server
-> Text
-> (Value -> Server -> IO (Either SomeException Value))
-> IO ()
registerRequestHandler Server
server Text
"initialize" ((Value -> Server -> IO (Either SomeException Value)) -> IO ())
-> (Value -> Server -> IO (Either SomeException Value)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
params Server
_ -> do
  case Value -> Result ClientInitializeOptions
forall a. FromJSON a => Value -> Result a
fromJSON Value
params of
    Success (ClientInitializeOptions
_clientOptions :: ClientInitializeOptions) -> do
      -- TODO: Verify protocol version compatibility

      let serverOptions :: ServerInitializeOptions
serverOptions =
            ServerInitializeOptions
              { $sel:serverInitProtocolVersion:ServerInitializeOptions :: Text
serverInitProtocolVersion = [Text] -> Text
forall a. HasCallStack => [a] -> a
head [Text]
supportedVersions,
                $sel:serverInitInfo:ServerInitializeOptions :: ServerInfo
serverInitInfo = Server -> ServerInfo
serverInfo Server
server,
                $sel:serverInitCapabilities:ServerInitializeOptions :: ServerCapabilities
serverInitCapabilities = Server -> ServerCapabilities
serverCapabilities Server
server,
                $sel:serverInitInstructions:ServerInitializeOptions :: Text
serverInitInstructions = Server -> Text
serverInstructions Server
server
              }

      Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either SomeException Value
forall a b. b -> Either a b
Right (Value -> Either SomeException Value)
-> Value -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ ServerInitializeOptions -> Value
forall a. ToJSON a => a -> Value
toJSON ServerInitializeOptions
serverOptions
    Error [Char]
err -> Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException Value
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Value)
-> SomeException -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException ([Char] -> IOError
userError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid initialize parameters: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)

-- | Register list resources handler
registerListResourcesHandler :: Server -> IO ()
registerListResourcesHandler :: Server -> IO ()
registerListResourcesHandler Server
server = Server
-> Text
-> (Value -> Server -> IO (Either SomeException Value))
-> IO ()
registerRequestHandler Server
server Text
"resources/list" ((Value -> Server -> IO (Either SomeException Value)) -> IO ())
-> (Value -> Server -> IO (Either SomeException Value)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
_ Server
svr -> do
  [Resource]
resources <- TVar [Resource] -> IO [Resource]
forall a. TVar a -> IO a
readTVarIO (Server -> TVar [Resource]
serverResources Server
svr)
  let result :: ListResourcesResult
result = [Resource] -> ListResourcesResult
ListResourcesResult [Resource]
resources
  Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either SomeException Value
forall a b. b -> Either a b
Right (Value -> Either SomeException Value)
-> Value -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ ListResourcesResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListResourcesResult
result

-- | Register read resource handler
registerReadResourceHandler :: Server -> IO ()
registerReadResourceHandler :: Server -> IO ()
registerReadResourceHandler Server
server = Server
-> Text
-> (Value -> Server -> IO (Either SomeException Value))
-> IO ()
registerRequestHandler Server
server Text
"resources/read" ((Value -> Server -> IO (Either SomeException Value)) -> IO ())
-> (Value -> Server -> IO (Either SomeException Value)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
params Server
svr -> do
  Maybe ResourceReadHandler
handlerM <- TVar (Maybe ResourceReadHandler) -> IO (Maybe ResourceReadHandler)
forall a. TVar a -> IO a
readTVarIO (Server -> TVar (Maybe ResourceReadHandler)
serverResourceReadHandler Server
svr)
  case Maybe ResourceReadHandler
handlerM of
    Just ResourceReadHandler
handler -> case Value -> Result ReadResourceRequest
forall a. FromJSON a => Value -> Result a
fromJSON Value
params of
      Success ReadResourceRequest
req -> do
        ReadResourceResult
result <- ResourceReadHandler
handler ReadResourceRequest
req
        return $ Value -> Either SomeException Value
forall a b. b -> Either a b
Right (Value -> Either SomeException Value)
-> Value -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ ReadResourceResult -> Value
forall a. ToJSON a => a -> Value
toJSON ReadResourceResult
result
      Error [Char]
err -> Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException Value
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Value)
-> SomeException -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException ([Char] -> IOError
userError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid resource read parameters: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
    Maybe ResourceReadHandler
Nothing -> Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException Value
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Value)
-> SomeException -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException ([Char] -> IOError
userError [Char]
"No resource read handler registered")

-- | Register list tools handler
registerListToolsHandler :: Server -> IO ()
registerListToolsHandler :: Server -> IO ()
registerListToolsHandler Server
server = Server
-> Text
-> (Value -> Server -> IO (Either SomeException Value))
-> IO ()
registerRequestHandler Server
server Text
"tools/list" ((Value -> Server -> IO (Either SomeException Value)) -> IO ())
-> (Value -> Server -> IO (Either SomeException Value)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
_ Server
svr -> do
  [Tool]
tools <- TVar [Tool] -> IO [Tool]
forall a. TVar a -> IO a
readTVarIO (Server -> TVar [Tool]
serverTools Server
svr)
  let result :: ListToolsResult
result = [Tool] -> ListToolsResult
ListToolsResult [Tool]
tools
  Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either SomeException Value
forall a b. b -> Either a b
Right (Value -> Either SomeException Value)
-> Value -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ ListToolsResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListToolsResult
result

-- | Register call tool handler
registerCallToolHandler :: Server -> IO ()
registerCallToolHandler :: Server -> IO ()
registerCallToolHandler Server
server = Server
-> Text
-> (Value -> Server -> IO (Either SomeException Value))
-> IO ()
registerRequestHandler Server
server Text
"tools/call" ((Value -> Server -> IO (Either SomeException Value)) -> IO ())
-> (Value -> Server -> IO (Either SomeException Value)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
params Server
svr -> do
  Maybe ToolCallHandler
handlerM <- TVar (Maybe ToolCallHandler) -> IO (Maybe ToolCallHandler)
forall a. TVar a -> IO a
readTVarIO (Server -> TVar (Maybe ToolCallHandler)
serverToolCallHandler Server
svr)
  case Maybe ToolCallHandler
handlerM of
    Just ToolCallHandler
handler -> case Value -> Result CallToolRequest
forall a. FromJSON a => Value -> Result a
fromJSON Value
params of
      Success CallToolRequest
req -> do
        CallToolResult
result <- ToolCallHandler
handler CallToolRequest
req
        return $ Value -> Either SomeException Value
forall a b. b -> Either a b
Right (Value -> Either SomeException Value)
-> Value -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ CallToolResult -> Value
forall a. ToJSON a => a -> Value
toJSON CallToolResult
result
      Error [Char]
err -> Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException Value
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Value)
-> SomeException -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException ([Char] -> IOError
userError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid tool call parameters: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
    Maybe ToolCallHandler
Nothing -> Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException Value
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Value)
-> SomeException -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException ([Char] -> IOError
userError [Char]
"No tool call handler registered")

-- | Register list prompts handler
registerListPromptsHandler :: Server -> IO ()
registerListPromptsHandler :: Server -> IO ()
registerListPromptsHandler Server
server = Server
-> Text
-> (Value -> Server -> IO (Either SomeException Value))
-> IO ()
registerRequestHandler Server
server Text
"prompts/list" ((Value -> Server -> IO (Either SomeException Value)) -> IO ())
-> (Value -> Server -> IO (Either SomeException Value)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
_ Server
svr -> do
  [Prompt]
prompts <- TVar [Prompt] -> IO [Prompt]
forall a. TVar a -> IO a
readTVarIO (Server -> TVar [Prompt]
serverPrompts Server
svr)
  let result :: ListPromptsResult
result = [Prompt] -> ListPromptsResult
ListPromptsResult [Prompt]
prompts
  Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either SomeException Value
forall a b. b -> Either a b
Right (Value -> Either SomeException Value)
-> Value -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ ListPromptsResult -> Value
forall a. ToJSON a => a -> Value
toJSON ListPromptsResult
result

-- | Register get prompt handler
registerGetPromptHandler :: Server -> IO ()
registerGetPromptHandler :: Server -> IO ()
registerGetPromptHandler Server
server = Server
-> Text
-> (Value -> Server -> IO (Either SomeException Value))
-> IO ()
registerRequestHandler Server
server Text
"prompts/get" ((Value -> Server -> IO (Either SomeException Value)) -> IO ())
-> (Value -> Server -> IO (Either SomeException Value)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
params Server
svr -> do
  Maybe PromptHandler
handlerM <- TVar (Maybe PromptHandler) -> IO (Maybe PromptHandler)
forall a. TVar a -> IO a
readTVarIO (Server -> TVar (Maybe PromptHandler)
serverPromptHandler Server
svr)
  case Maybe PromptHandler
handlerM of
    Just PromptHandler
handler -> case Value -> Result GetPromptRequest
forall a. FromJSON a => Value -> Result a
fromJSON Value
params of
      Success GetPromptRequest
req -> do
        GetPromptResult
result <- PromptHandler
handler GetPromptRequest
req
        return $ Value -> Either SomeException Value
forall a b. b -> Either a b
Right (Value -> Either SomeException Value)
-> Value -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ GetPromptResult -> Value
forall a. ToJSON a => a -> Value
toJSON GetPromptResult
result
      Error [Char]
err -> Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException Value
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Value)
-> SomeException -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException ([Char] -> IOError
userError ([Char] -> IOError) -> [Char] -> IOError
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid get prompt parameters: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
    Maybe PromptHandler
Nothing -> Either SomeException Value -> IO (Either SomeException Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException Value -> IO (Either SomeException Value))
-> Either SomeException Value -> IO (Either SomeException Value)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException Value
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Value)
-> SomeException -> Either SomeException Value
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException ([Char] -> IOError
userError [Char]
"No prompt handler registered")