module Ribosome.Host.Data.RpcMessage where

import Data.MessagePack (Object (ObjectArray, ObjectNil))
import qualified Data.Serialize as Serialize
import Data.Serialize (Serialize)
import Exon (exon)

import Ribosome.Host.Class.Msgpack.Array (MsgpackArray (msgpackArray))
import Ribosome.Host.Class.Msgpack.Decode (pattern Msgpack, MsgpackDecode (fromMsgpack))
import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))
import qualified Ribosome.Host.Data.Request as Request
import Ribosome.Host.Data.Request (Request, TrackedRequest (TrackedRequest), formatReq, formatTrackedReq)
import qualified Ribosome.Host.Data.Response as Response
import Ribosome.Host.Data.Response (TrackedResponse (TrackedResponse), formatTrackedResponse)

rpcError :: Object -> Text
rpcError :: Object -> Text
rpcError = \case
  Msgpack Text
e ->
    Text
e
  ObjectArray [Item [Object]
_, Msgpack Text
e] ->
    Text
e
  Object
o ->
    Object -> Text
forall b a. (Show a, IsString b) => a -> b
show Object
o

pattern ErrorPayload :: Text -> Object
pattern $mErrorPayload :: forall {r}. Object -> (Text -> r) -> (Void# -> r) -> r
ErrorPayload e <- (rpcError -> e)

data RpcMessage =
  Request TrackedRequest
  |
  Response TrackedResponse
  |
  Notification Request
  deriving stock (RpcMessage -> RpcMessage -> Bool
(RpcMessage -> RpcMessage -> Bool)
-> (RpcMessage -> RpcMessage -> Bool) -> Eq RpcMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RpcMessage -> RpcMessage -> Bool
$c/= :: RpcMessage -> RpcMessage -> Bool
== :: RpcMessage -> RpcMessage -> Bool
$c== :: RpcMessage -> RpcMessage -> Bool
Eq, Int -> RpcMessage -> ShowS
[RpcMessage] -> ShowS
RpcMessage -> String
(Int -> RpcMessage -> ShowS)
-> (RpcMessage -> String)
-> ([RpcMessage] -> ShowS)
-> Show RpcMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RpcMessage] -> ShowS
$cshowList :: [RpcMessage] -> ShowS
show :: RpcMessage -> String
$cshow :: RpcMessage -> String
showsPrec :: Int -> RpcMessage -> ShowS
$cshowsPrec :: Int -> RpcMessage -> ShowS
Show)

instance MsgpackEncode RpcMessage where
  toMsgpack :: RpcMessage -> Object
toMsgpack = \case
    Request (TrackedRequest RequestId
i (Request.Request RpcMethod
method [Object]
payload)) ->
      Int -> RequestId -> RpcMethod -> [Object] -> Object
forall a. MsgpackArray a => a
msgpackArray (Int
0 :: Int) RequestId
i RpcMethod
method [Object]
payload
    Response (TrackedResponse RequestId
i (Response.Success Object
payload)) ->
      Int -> RequestId -> () -> Object -> Object
forall a. MsgpackArray a => a
msgpackArray (Int
1 :: Int) RequestId
i () Object
payload
    Response (TrackedResponse RequestId
i (Response.Error Text
payload)) ->
      Int -> RequestId -> Text -> () -> Object
forall a. MsgpackArray a => a
msgpackArray (Int
1 :: Int) RequestId
i Text
payload ()
    Notification (Request.Request RpcMethod
method [Object]
payload) ->
      Int -> RpcMethod -> [Object] -> Object
forall a. MsgpackArray a => a
msgpackArray (Int
2 :: Int) RpcMethod
method [Object]
payload

instance MsgpackDecode RpcMessage where
  fromMsgpack :: Object -> Either Text RpcMessage
fromMsgpack = \case
    ObjectArray [Msgpack (Int
0 :: Int), Msgpack RequestId
i, Msgpack RpcMethod
method, Msgpack [Object]
payload] ->
      RpcMessage -> Either Text RpcMessage
forall a b. b -> Either a b
Right (TrackedRequest -> RpcMessage
Request (RequestId -> Request -> TrackedRequest
TrackedRequest RequestId
i (RpcMethod -> [Object] -> Request
Request.Request RpcMethod
method [Object]
payload)))
    ObjectArray [Msgpack (Int
1 :: Int), Msgpack RequestId
i, Item [Object]
Object
ObjectNil, Item [Object]
payload] ->
      RpcMessage -> Either Text RpcMessage
forall a b. b -> Either a b
Right (TrackedResponse -> RpcMessage
Response (RequestId -> Response -> TrackedResponse
TrackedResponse RequestId
i (Object -> Response
Response.Success Item [Object]
Object
payload)))
    ObjectArray [Msgpack (Int
1 :: Int), Msgpack RequestId
i, ErrorPayload Text
e, Item [Object]
Object
ObjectNil] ->
      RpcMessage -> Either Text RpcMessage
forall a b. b -> Either a b
Right (TrackedResponse -> RpcMessage
Response (RequestId -> Response -> TrackedResponse
TrackedResponse RequestId
i (Text -> Response
Response.Error Text
e)))
    ObjectArray [Msgpack (Int
2 :: Int), Msgpack RpcMethod
method, Msgpack [Object]
payload] ->
      RpcMessage -> Either Text RpcMessage
forall a b. b -> Either a b
Right (Request -> RpcMessage
Notification (RpcMethod -> [Object] -> Request
Request.Request RpcMethod
method [Object]
payload))
    Object
o ->
      Text -> Either Text RpcMessage
forall a b. a -> Either a b
Left [exon|Invalid format for RpcMessage: #{show o}|]

instance Serialize RpcMessage where
  put :: Putter RpcMessage
put =
    Putter Object
forall t. Serialize t => Putter t
Serialize.put Putter Object -> (RpcMessage -> Object) -> Putter RpcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcMessage -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack
  get :: Get RpcMessage
get =
    (Text -> Get RpcMessage)
-> (RpcMessage -> Get RpcMessage)
-> Either Text RpcMessage
-> Get RpcMessage
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Get RpcMessage
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get RpcMessage)
-> (Text -> String) -> Text -> Get RpcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString) RpcMessage -> Get RpcMessage
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text RpcMessage -> Get RpcMessage)
-> (Object -> Either Text RpcMessage) -> Object -> Get RpcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either Text RpcMessage
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack (Object -> Get RpcMessage) -> Get Object -> Get RpcMessage
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Object
forall t. Serialize t => Get t
Serialize.get

formatRpcMsg :: RpcMessage -> Text
formatRpcMsg :: RpcMessage -> Text
formatRpcMsg = \case
  Request TrackedRequest
req ->
    [exon|request #{formatTrackedReq req}|]
  Response TrackedResponse
res ->
    [exon|response #{formatTrackedResponse res}|]
  Notification Request
req ->
    [exon|notification #{formatReq req}|]