{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.MCP.Transport.Types
  ( Transport (..),
    Message (..),
    Request (..),
    Response (..),
    Notification (..),
    ErrorResponse (..),
    TransportError (..),
    JSONRPC (..),
  )
where

import Control.Exception (Exception)
import Data.Aeson
import Data.Aeson.Types
import Data.Text (Text)
import GHC.Generics

-- JSON-RPC protocol constant
newtype JSONRPC = JSONRPC {JSONRPC -> Text
unJSONRPC :: Text}
  deriving (Int -> JSONRPC -> ShowS
[JSONRPC] -> ShowS
JSONRPC -> String
(Int -> JSONRPC -> ShowS)
-> (JSONRPC -> String) -> ([JSONRPC] -> ShowS) -> Show JSONRPC
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JSONRPC -> ShowS
showsPrec :: Int -> JSONRPC -> ShowS
$cshow :: JSONRPC -> String
show :: JSONRPC -> String
$cshowList :: [JSONRPC] -> ShowS
showList :: [JSONRPC] -> ShowS
Show, JSONRPC -> JSONRPC -> Bool
(JSONRPC -> JSONRPC -> Bool)
-> (JSONRPC -> JSONRPC -> Bool) -> Eq JSONRPC
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JSONRPC -> JSONRPC -> Bool
== :: JSONRPC -> JSONRPC -> Bool
$c/= :: JSONRPC -> JSONRPC -> Bool
/= :: JSONRPC -> JSONRPC -> Bool
Eq, (forall x. JSONRPC -> Rep JSONRPC x)
-> (forall x. Rep JSONRPC x -> JSONRPC) -> Generic JSONRPC
forall x. Rep JSONRPC x -> JSONRPC
forall x. JSONRPC -> Rep JSONRPC x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JSONRPC -> Rep JSONRPC x
from :: forall x. JSONRPC -> Rep JSONRPC x
$cto :: forall x. Rep JSONRPC x -> JSONRPC
to :: forall x. Rep JSONRPC x -> JSONRPC
Generic)

instance ToJSON JSONRPC where
  toJSON :: JSONRPC -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (JSONRPC -> Text) -> JSONRPC -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONRPC -> Text
unJSONRPC

instance FromJSON JSONRPC where
  parseJSON :: Value -> Parser JSONRPC
parseJSON = String -> (Text -> Parser JSONRPC) -> Value -> Parser JSONRPC
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"JSONRPC" ((Text -> Parser JSONRPC) -> Value -> Parser JSONRPC)
-> (Text -> Parser JSONRPC) -> Value -> Parser JSONRPC
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"2.0"
      then JSONRPC -> Parser JSONRPC
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (JSONRPC -> Parser JSONRPC) -> JSONRPC -> Parser JSONRPC
forall a b. (a -> b) -> a -> b
$ Text -> JSONRPC
JSONRPC Text
t
      else String -> Parser JSONRPC
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser JSONRPC) -> String -> Parser JSONRPC
forall a b. (a -> b) -> a -> b
$ String
"Expected JSONRPC version 2.0, got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t

-- | JSON-RPC Request
data Request = Request
  { Request -> JSONRPC
requestJsonrpc :: JSONRPC,
    Request -> Value
requestId :: Value,
    Request -> Text
requestMethod :: Text,
    Request -> Maybe Value
requestParams :: Maybe Value
  }
  deriving (Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Request -> ShowS
showsPrec :: Int -> Request -> ShowS
$cshow :: Request -> String
show :: Request -> String
$cshowList :: [Request] -> ShowS
showList :: [Request] -> ShowS
Show, Request -> Request -> Bool
(Request -> Request -> Bool)
-> (Request -> Request -> Bool) -> Eq Request
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
/= :: Request -> Request -> Bool
Eq, (forall x. Request -> Rep Request x)
-> (forall x. Rep Request x -> Request) -> Generic Request
forall x. Rep Request x -> Request
forall x. Request -> Rep Request x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Request -> Rep Request x
from :: forall x. Request -> Rep Request x
$cto :: forall x. Rep Request x -> Request
to :: forall x. Rep Request x -> Request
Generic)

instance ToJSON Request where
  toJSON :: Request -> Value
toJSON Request {Maybe Value
Value
Text
JSONRPC
$sel:requestJsonrpc:Request :: Request -> JSONRPC
$sel:requestId:Request :: Request -> Value
$sel:requestMethod:Request :: Request -> Text
$sel:requestParams:Request :: Request -> Maybe Value
requestJsonrpc :: JSONRPC
requestId :: Value
requestMethod :: Text
requestParams :: Maybe Value
..} =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"jsonrpc" Key -> JSONRPC -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= JSONRPC
requestJsonrpc,
        Key
"id" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Value
requestId,
        Key
"method" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
requestMethod
      ]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"params" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Value
p | Value
p <- Maybe Value -> [Value]
forall a. Maybe a -> [a]
maybeToList Maybe Value
requestParams]

instance FromJSON Request where
  parseJSON :: Value -> Parser Request
parseJSON = String -> (Object -> Parser Request) -> Value -> Parser Request
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Request" ((Object -> Parser Request) -> Value -> Parser Request)
-> (Object -> Parser Request) -> Value -> Parser Request
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    JSONRPC
jsonrpc <- Object
o Object -> Key -> Parser JSONRPC
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"jsonrpc"
    Value
id' <- Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
    Text
method <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method"
    Maybe Value
params <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"params"
    return $ JSONRPC -> Value -> Text -> Maybe Value -> Request
Request JSONRPC
jsonrpc Value
id' Text
method Maybe Value
params

-- | JSON-RPC Notification (no ID)
data Notification = Notification
  { Notification -> JSONRPC
notificationJsonrpc :: JSONRPC,
    Notification -> Text
notificationMethod :: Text,
    Notification -> Maybe Value
notificationParams :: Maybe Value
  }
  deriving (Int -> Notification -> ShowS
[Notification] -> ShowS
Notification -> String
(Int -> Notification -> ShowS)
-> (Notification -> String)
-> ([Notification] -> ShowS)
-> Show Notification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Notification -> ShowS
showsPrec :: Int -> Notification -> ShowS
$cshow :: Notification -> String
show :: Notification -> String
$cshowList :: [Notification] -> ShowS
showList :: [Notification] -> ShowS
Show, Notification -> Notification -> Bool
(Notification -> Notification -> Bool)
-> (Notification -> Notification -> Bool) -> Eq Notification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Notification -> Notification -> Bool
== :: Notification -> Notification -> Bool
$c/= :: Notification -> Notification -> Bool
/= :: Notification -> Notification -> Bool
Eq, (forall x. Notification -> Rep Notification x)
-> (forall x. Rep Notification x -> Notification)
-> Generic Notification
forall x. Rep Notification x -> Notification
forall x. Notification -> Rep Notification x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Notification -> Rep Notification x
from :: forall x. Notification -> Rep Notification x
$cto :: forall x. Rep Notification x -> Notification
to :: forall x. Rep Notification x -> Notification
Generic)

instance ToJSON Notification where
  toJSON :: Notification -> Value
toJSON Notification {Maybe Value
Text
JSONRPC
$sel:notificationJsonrpc:Notification :: Notification -> JSONRPC
$sel:notificationMethod:Notification :: Notification -> Text
$sel:notificationParams:Notification :: Notification -> Maybe Value
notificationJsonrpc :: JSONRPC
notificationMethod :: Text
notificationParams :: Maybe Value
..} =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"jsonrpc" Key -> JSONRPC -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= JSONRPC
notificationJsonrpc,
        Key
"method" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
notificationMethod
      ]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"params" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Value
p | Value
p <- Maybe Value -> [Value]
forall a. Maybe a -> [a]
maybeToList Maybe Value
notificationParams]

instance FromJSON Notification where
  parseJSON :: Value -> Parser Notification
parseJSON = String
-> (Object -> Parser Notification) -> Value -> Parser Notification
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Notification" ((Object -> Parser Notification) -> Value -> Parser Notification)
-> (Object -> Parser Notification) -> Value -> Parser Notification
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    JSONRPC
jsonrpc <- Object
o Object -> Key -> Parser JSONRPC
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"jsonrpc"
    Text
method <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method"
    Maybe Value
params <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"params"
    return $ JSONRPC -> Text -> Maybe Value -> Notification
Notification JSONRPC
jsonrpc Text
method Maybe Value
params

-- | JSON-RPC Error Response
data ErrorResponse = ErrorResponse
  { ErrorResponse -> Int
errorCode :: Int,
    ErrorResponse -> Text
errorMessage :: Text,
    ErrorResponse -> Maybe Value
errorData :: Maybe Value
  }
  deriving (Int -> ErrorResponse -> ShowS
[ErrorResponse] -> ShowS
ErrorResponse -> String
(Int -> ErrorResponse -> ShowS)
-> (ErrorResponse -> String)
-> ([ErrorResponse] -> ShowS)
-> Show ErrorResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorResponse -> ShowS
showsPrec :: Int -> ErrorResponse -> ShowS
$cshow :: ErrorResponse -> String
show :: ErrorResponse -> String
$cshowList :: [ErrorResponse] -> ShowS
showList :: [ErrorResponse] -> ShowS
Show, ErrorResponse -> ErrorResponse -> Bool
(ErrorResponse -> ErrorResponse -> Bool)
-> (ErrorResponse -> ErrorResponse -> Bool) -> Eq ErrorResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorResponse -> ErrorResponse -> Bool
== :: ErrorResponse -> ErrorResponse -> Bool
$c/= :: ErrorResponse -> ErrorResponse -> Bool
/= :: ErrorResponse -> ErrorResponse -> Bool
Eq, (forall x. ErrorResponse -> Rep ErrorResponse x)
-> (forall x. Rep ErrorResponse x -> ErrorResponse)
-> Generic ErrorResponse
forall x. Rep ErrorResponse x -> ErrorResponse
forall x. ErrorResponse -> Rep ErrorResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ErrorResponse -> Rep ErrorResponse x
from :: forall x. ErrorResponse -> Rep ErrorResponse x
$cto :: forall x. Rep ErrorResponse x -> ErrorResponse
to :: forall x. Rep ErrorResponse x -> ErrorResponse
Generic)

instance ToJSON ErrorResponse where
  toJSON :: ErrorResponse -> Value
toJSON ErrorResponse {Int
Maybe Value
Text
$sel:errorCode:ErrorResponse :: ErrorResponse -> Int
$sel:errorMessage:ErrorResponse :: ErrorResponse -> Text
$sel:errorData:ErrorResponse :: ErrorResponse -> Maybe Value
errorCode :: Int
errorMessage :: Text
errorData :: Maybe Value
..} =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"code" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Int
errorCode,
        Key
"message" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
errorMessage
      ]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"data" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Value
d | Value
d <- Maybe Value -> [Value]
forall a. Maybe a -> [a]
maybeToList Maybe Value
errorData]

instance FromJSON ErrorResponse where
  parseJSON :: Value -> Parser ErrorResponse
parseJSON = String
-> (Object -> Parser ErrorResponse)
-> Value
-> Parser ErrorResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ErrorResponse" ((Object -> Parser ErrorResponse) -> Value -> Parser ErrorResponse)
-> (Object -> Parser ErrorResponse)
-> Value
-> Parser ErrorResponse
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Int
code <- Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code"
    Text
message <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
    Maybe Value
errorData <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"data"
    return $ Int -> Text -> Maybe Value -> ErrorResponse
ErrorResponse Int
code Text
message Maybe Value
errorData

-- | JSON-RPC Response
data Response = Response
  { Response -> JSONRPC
responseJsonrpc :: JSONRPC,
    Response -> Value
responseId :: Value,
    Response -> Maybe Value
responseResult :: Maybe Value,
    Response -> Maybe ErrorResponse
responseError :: Maybe ErrorResponse
  }
  deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Response -> ShowS
showsPrec :: Int -> Response -> ShowS
$cshow :: Response -> String
show :: Response -> String
$cshowList :: [Response] -> ShowS
showList :: [Response] -> ShowS
Show, Response -> Response -> Bool
(Response -> Response -> Bool)
-> (Response -> Response -> Bool) -> Eq Response
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
/= :: Response -> Response -> Bool
Eq, (forall x. Response -> Rep Response x)
-> (forall x. Rep Response x -> Response) -> Generic Response
forall x. Rep Response x -> Response
forall x. Response -> Rep Response x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Response -> Rep Response x
from :: forall x. Response -> Rep Response x
$cto :: forall x. Rep Response x -> Response
to :: forall x. Rep Response x -> Response
Generic)

instance ToJSON Response where
  toJSON :: Response -> Value
toJSON Response {Maybe Value
Maybe ErrorResponse
Value
JSONRPC
$sel:responseJsonrpc:Response :: Response -> JSONRPC
$sel:responseId:Response :: Response -> Value
$sel:responseResult:Response :: Response -> Maybe Value
$sel:responseError:Response :: Response -> Maybe ErrorResponse
responseJsonrpc :: JSONRPC
responseId :: Value
responseResult :: Maybe Value
responseError :: Maybe ErrorResponse
..} =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"jsonrpc" Key -> JSONRPC -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= JSONRPC
responseJsonrpc,
        Key
"id" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Value
responseId
      ]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"result" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Value
r | Value
r <- Maybe Value -> [Value]
forall a. Maybe a -> [a]
maybeToList Maybe Value
responseResult]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"error" Key -> ErrorResponse -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ErrorResponse
e | ErrorResponse
e <- Maybe ErrorResponse -> [ErrorResponse]
forall a. Maybe a -> [a]
maybeToList Maybe ErrorResponse
responseError]

instance FromJSON Response where
  parseJSON :: Value -> Parser Response
parseJSON = String -> (Object -> Parser Response) -> Value -> Parser Response
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Response" ((Object -> Parser Response) -> Value -> Parser Response)
-> (Object -> Parser Response) -> Value -> Parser Response
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    JSONRPC
jsonrpc <- Object
o Object -> Key -> Parser JSONRPC
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"jsonrpc"
    Value
id' <- Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
    Maybe Value
result <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"result"
    Maybe ErrorResponse
error' <- Object
o Object -> Key -> Parser (Maybe ErrorResponse)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error"
    return $ JSONRPC -> Value -> Maybe Value -> Maybe ErrorResponse -> Response
Response JSONRPC
jsonrpc Value
id' Maybe Value
result Maybe ErrorResponse
error'

-- | Combined message type for the transport layer
data Message
  = RequestMessage Request
  | ResponseMessage Response
  | NotificationMessage Notification
  deriving (Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Message -> ShowS
showsPrec :: Int -> Message -> ShowS
$cshow :: Message -> String
show :: Message -> String
$cshowList :: [Message] -> ShowS
showList :: [Message] -> ShowS
Show, Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
/= :: Message -> Message -> Bool
Eq)

instance ToJSON Message where
  toJSON :: Message -> Value
toJSON (RequestMessage Request
req) = Request -> Value
forall a. ToJSON a => a -> Value
toJSON Request
req
  toJSON (ResponseMessage Response
res) = Response -> Value
forall a. ToJSON a => a -> Value
toJSON Response
res
  toJSON (NotificationMessage Notification
notif) = Notification -> Value
forall a. ToJSON a => a -> Value
toJSON Notification
notif

instance FromJSON Message where
  parseJSON :: Value -> Parser Message
parseJSON Value
val = do
    Object
obj <- Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
    Maybe Value
id' <- Object
obj Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"id" :: Parser (Maybe Value)
    Maybe Text
method <- Object
obj Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"method" :: Parser (Maybe Text)
    case (Maybe Value
id', Maybe Text
method) of
      (Just Value
_, Just Text
_) -> Request -> Message
RequestMessage (Request -> Message) -> Parser Request -> Parser Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Request
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      (Just Value
_, Maybe Text
Nothing) -> Response -> Message
ResponseMessage (Response -> Message) -> Parser Response -> Parser Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Response
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      (Maybe Value
Nothing, Just Text
_) -> Notification -> Message
NotificationMessage (Notification -> Message) -> Parser Notification -> Parser Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Notification
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
      (Maybe Value, Maybe Text)
_ -> String -> Parser Message
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid JSON-RPC message"

-- | Transport error
data TransportError = TransportError String
  deriving stock (Int -> TransportError -> ShowS
[TransportError] -> ShowS
TransportError -> String
(Int -> TransportError -> ShowS)
-> (TransportError -> String)
-> ([TransportError] -> ShowS)
-> Show TransportError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportError -> ShowS
showsPrec :: Int -> TransportError -> ShowS
$cshow :: TransportError -> String
show :: TransportError -> String
$cshowList :: [TransportError] -> ShowS
showList :: [TransportError] -> ShowS
Show, TransportError -> TransportError -> Bool
(TransportError -> TransportError -> Bool)
-> (TransportError -> TransportError -> Bool) -> Eq TransportError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportError -> TransportError -> Bool
== :: TransportError -> TransportError -> Bool
$c/= :: TransportError -> TransportError -> Bool
/= :: TransportError -> TransportError -> Bool
Eq)
  deriving anyclass (Show TransportError
Typeable TransportError
(Typeable TransportError, Show TransportError) =>
(TransportError -> SomeException)
-> (SomeException -> Maybe TransportError)
-> (TransportError -> String)
-> Exception TransportError
SomeException -> Maybe TransportError
TransportError -> String
TransportError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: TransportError -> SomeException
toException :: TransportError -> SomeException
$cfromException :: SomeException -> Maybe TransportError
fromException :: SomeException -> Maybe TransportError
$cdisplayException :: TransportError -> String
displayException :: TransportError -> String
Exception)

-- | Transport interface for all transport implementations
class Transport t where
  -- | Keep processing messages using the provided handler.
  -- Will only return if the transport mechanism signals termination;
  -- e.g. EOF on a socket or similar.
  handleMessages :: t -> (Message -> IO (Maybe Message)) -> IO ()

-- Helper function
maybeToList :: Maybe a -> [a]
maybeToList :: forall a. Maybe a -> [a]
maybeToList Maybe a
Nothing = []
maybeToList (Just a
x) = [a
x]