{-|
Module      : Z.Data.MessagePack
Description : Fast MessagePack serialization/deserialization
Copyright   : (c) Dong Han, 2019
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provides <https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md MessagePack-RPC> implementation.

@
-- server
import Z.IO.RPC.MessagePack
import Z.IO.Network
import Z.IO
import qualified Z.Data.Text as T

serveRPC (startTCPServer defaultTCPServerConfig) . simpleRouter $
 [ ("foo", CallHandler $ \\ (req :: Int) -> do
     return (req + 1))
 , ("bar", NotifyHandler $ \\ (req :: T.Text) -> do
     printStd (req <> "world"))
 ]

-- client
import Z.IO.RPC.MessagePack
import Z.IO.Network
import Z.IO
import qualified Z.Data.Text as T

withResource (initTCPClient defaultTCPClientConfig) $ \\ uvs -> do
    c <- rpcClient uvs
    call \@Int \@Int c "foo" 1
    call \@T.Text \@T.Text c "bar" "hello"
@

-}

module Z.IO.RPC.MessagePack where

import           Control.Monad
import           Data.Bits
import           Z.Data.PrimRef.PrimIORef
import qualified Z.Data.MessagePack.Builder as MB
import qualified Z.Data.MessagePack.Value   as MV
import           Z.Data.MessagePack         (MessagePack)
import qualified Z.Data.MessagePack         as MP
import qualified Z.Data.Parser              as P
import qualified Z.Data.Text                as T
import qualified Z.Data.Vector.FlatIntMap   as FIM
import qualified Z.Data.Vector.FlatMap      as FM
import qualified Z.Data.Vector              as V
import           Z.IO
import           Z.IO.Network

data Client = Client
    { Client -> Counter
_clientSeqRef :: Counter
    , Client -> Counter
_clientPipelineReqNum :: Counter
    , Client -> BufferedInput
_clientBufferedInput :: BufferedInput
    , Client -> BufferedOutput
_clientBufferedOutput :: BufferedOutput
    }

-- | Open a RPC client from input/output device.
rpcClient :: (Input dev, Output dev) => dev -> IO Client
rpcClient :: dev -> IO Client
rpcClient dev
uvs = dev -> dev -> Int -> Int -> IO Client
forall i o.
(Input i, Output o) =>
i -> o -> Int -> Int -> IO Client
rpcClient' dev
uvs dev
uvs Int
V.defaultChunkSize Int
V.defaultChunkSize

-- | Open a RPC client with more control.
rpcClient' :: (Input i, Output o)
              => i
              -> o
              -> Int          -- ^ recv buffer size
              -> Int          -- ^ send buffer size
              -> IO Client
rpcClient' :: i -> o -> Int -> Int -> IO Client
rpcClient' i
i o
o Int
recvBufSiz Int
sendBufSiz = do
    Counter
seqRef <- Int -> IO Counter
newCounter Int
0
    Counter
reqNum <- Int -> IO Counter
newCounter Int
0
    BufferedInput
bi <- Int -> i -> IO BufferedInput
forall i. Input i => Int -> i -> IO BufferedInput
newBufferedInput' Int
recvBufSiz i
i
    BufferedOutput
bo <- Int -> o -> IO BufferedOutput
forall o. Output o => Int -> o -> IO BufferedOutput
newBufferedOutput' Int
sendBufSiz o
o
    Client -> IO Client
forall (m :: * -> *) a. Monad m => a -> m a
return (Counter -> Counter -> BufferedInput -> BufferedOutput -> Client
Client Counter
seqRef Counter
reqNum BufferedInput
bi BufferedOutput
bo)

-- | Send a single RPC call and get result.
call:: (MessagePack req, MessagePack res) => Client -> T.Text -> req -> IO res
call :: Client -> Text -> req -> IO res
call Client
cli Text
name req
req = do
    Int
msgid <- Client -> Text -> req -> IO Int
forall req.
(HasCallStack, MessagePack req) =>
Client -> Text -> req -> IO Int
callPipeline Client
cli Text
name req
req
    Int -> PipelineResult -> IO res
forall res.
(HasCallStack, MessagePack res) =>
Int -> PipelineResult -> IO res
fetchPipeline Int
msgid (PipelineResult -> IO res) -> IO PipelineResult -> IO res
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack => Client -> IO PipelineResult
Client -> IO PipelineResult
execPipeline Client
cli

-- | Send a single notification RPC call without getting result.
notify :: MessagePack req => Client -> T.Text -> req -> IO ()
notify :: Client -> Text -> req -> IO ()
notify c :: Client
c@(Client Counter
_ Counter
_ BufferedInput
_ BufferedOutput
bo) Text
name req
req = Client -> Text -> req -> IO ()
forall req.
(HasCallStack, MessagePack req) =>
Client -> Text -> req -> IO ()
notifyPipeline Client
c Text
name req
req IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HasCallStack => BufferedOutput -> IO ()
BufferedOutput -> IO ()
flushBuffer BufferedOutput
bo

type PipelineId = Int
type PipelineResult = FIM.FlatIntMap MV.Value

-- | Make a call inside a pipeline, which will be sent in batch when `execPipeline`.
--
-- @
--  ...
--  fooId <- callPipeline client "foo" $ ...
--  barId <- callPipeline client "bar" $ ...
--  notifyPipeline client "qux" $ ...
--
--  r <- execPipeline client
--
--  fooResult <- fetchPipeline fooId r
--  barResult <- fetchPipeline barId r
-- @
--
callPipeline :: HasCallStack => MessagePack req => Client -> T.Text -> req -> IO PipelineId
callPipeline :: Client -> Text -> req -> IO Int
callPipeline (Client Counter
seqRef Counter
reqNum BufferedInput
_ BufferedOutput
bo) Text
name req
req = do
    Int
msgid <- Counter -> IO Int
forall a. Prim a => PrimIORef a -> IO a
readPrimIORef Counter
seqRef
    Counter -> Int -> IO ()
forall a. Prim a => PrimIORef a -> a -> IO ()
writePrimIORef Counter
seqRef (Int
msgidInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    Counter -> (Int -> Int) -> IO ()
forall a. Prim a => PrimIORef a -> (a -> a) -> IO ()
modifyPrimIORef Counter
reqNum (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    let !msgid' :: Int
msgid' = Int
msgid Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFFFFFFFF  -- shrink to unsiged 32bits
    BufferedOutput -> Builder () -> IO ()
forall a. HasCallStack => BufferedOutput -> Builder a -> IO ()
writeBuilder BufferedOutput
bo (Builder () -> IO ()) -> Builder () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> Builder ()
MB.arrayHeader Int
4
        Int64 -> Builder ()
MB.int Int64
0                        -- type request
        Int64 -> Builder ()
MB.int (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
msgid')    -- msgid
        Text -> Builder ()
MB.str Text
name                     -- method name
        req -> Builder ()
forall a. MessagePack a => a -> Builder ()
MP.encodeMessagePack req
req        -- param
    Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
msgid'

-- | Make a notify inside a pipeline, which will be sent in batch when `execPipeline`.
--
-- Notify calls doesn't affect execution's result.
notifyPipeline :: HasCallStack => MessagePack req => Client -> T.Text -> req -> IO ()
notifyPipeline :: Client -> Text -> req -> IO ()
notifyPipeline (Client Counter
_ Counter
_ BufferedInput
_ BufferedOutput
bo) Text
name req
req = do
    BufferedOutput -> Builder () -> IO ()
forall a. HasCallStack => BufferedOutput -> Builder a -> IO ()
writeBuilder BufferedOutput
bo (Builder () -> IO ()) -> Builder () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> Builder ()
MB.arrayHeader Int
3
        Int64 -> Builder ()
MB.int Int64
2                        -- type notification
        Text -> Builder ()
MB.str Text
name                     -- method name
        req -> Builder ()
forall a. MessagePack a => a -> Builder ()
MP.encodeMessagePack req
req        -- param

-- | Exception thrown when remote endpoint return errors.
data RPCException = RPCException MV.Value CallStack deriving Int -> RPCException -> ShowS
[RPCException] -> ShowS
RPCException -> String
(Int -> RPCException -> ShowS)
-> (RPCException -> String)
-> ([RPCException] -> ShowS)
-> Show RPCException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RPCException] -> ShowS
$cshowList :: [RPCException] -> ShowS
show :: RPCException -> String
$cshow :: RPCException -> String
showsPrec :: Int -> RPCException -> ShowS
$cshowsPrec :: Int -> RPCException -> ShowS
Show
instance Exception RPCException

-- | Sent request in batch and get result in a map identified by 'PipelineId'.
execPipeline :: HasCallStack => Client -> IO PipelineResult
execPipeline :: Client -> IO PipelineResult
execPipeline (Client Counter
_ Counter
reqNum BufferedInput
bi BufferedOutput
bo) = do
    HasCallStack => BufferedOutput -> IO ()
BufferedOutput -> IO ()
flushBuffer BufferedOutput
bo
    Int
n <- Counter -> IO Int
forall a. Prim a => PrimIORef a -> IO a
readPrimIORef Counter
reqNum
    Counter -> Int -> IO ()
forall a. Prim a => PrimIORef a -> a -> IO ()
writePrimIORef Counter
reqNum Int
0
    Int -> [IPair Value] -> PipelineResult
forall v. Int -> [IPair v] -> FlatIntMap v
FIM.packN Int
n ([IPair Value] -> PipelineResult)
-> IO [IPair Value] -> IO PipelineResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (IPair Value) -> IO [IPair Value]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (do
        (Int64
msgid, Value
err, Value
v) <- Parser (Int64, Value, Value)
-> BufferedInput -> IO (Int64, Value, Value)
forall a. HasCallStack => Parser a -> BufferedInput -> IO a
readParser (do
            Word8
tag <- Parser Word8
P.anyWord8
            Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
tag Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x94) (Text -> Parser ()
forall a. Text -> Parser a
P.fail' (Text -> Parser ()) -> Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text
"wrong response tag: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
forall a. Print a => a -> Text
T.toText Word8
tag)
            !Value
typ <- Parser Value
MV.value
            !Value
seq <- Parser Value
MV.value
            !Value
err <- Parser Value
MV.value
            !Value
v <- Parser Value
MV.value
            case Value
typ of
                MV.Int Int64
1 -> case Value
seq of
                    MV.Int Int64
msgid | Int64
msgid Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0 Bool -> Bool -> Bool
&& Int64
msgid Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0xFFFFFFFF ->
                        (Int64, Value, Value) -> Parser (Int64, Value, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64
msgid, Value
err, Value
v)
                    Value
_ -> Text -> Parser (Int64, Value, Value)
forall a. Text -> Parser a
P.fail' (Text -> Parser (Int64, Value, Value))
-> Text -> Parser (Int64, Value, Value)
forall a b. (a -> b) -> a -> b
$ Text
"wrong msgid: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Print a => a -> Text
T.toText Value
seq
                Value
_ -> Text -> Parser (Int64, Value, Value)
forall a. Text -> Parser a
P.fail' (Text -> Parser (Int64, Value, Value))
-> Text -> Parser (Int64, Value, Value)
forall a b. (a -> b) -> a -> b
$ Text
"wrong response type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Print a => a -> Text
T.toText Value
typ
            ) BufferedInput
bi
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value
err Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
MV.Nil) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RPCException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Value -> CallStack -> RPCException
RPCException Value
err CallStack
HasCallStack => CallStack
callStack)
        IPair Value -> IO (IPair Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Value -> IPair Value
forall a. Int -> a -> IPair a
V.IPair (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
msgid) Value
v))

-- | Use the `PipelineId` returned when `callPipeline` to fetch call's result.
fetchPipeline :: HasCallStack => MessagePack res => PipelineId -> PipelineResult -> IO res
fetchPipeline :: Int -> PipelineResult -> IO res
fetchPipeline Int
msgid PipelineResult
r = do
    Text -> Either ConvertError res -> IO res
forall e a. (HasCallStack, Print e) => Text -> Either e a -> IO a
unwrap Text
"EPARSE" (Either ConvertError res -> IO res)
-> (Value -> Either ConvertError res) -> Value -> IO res
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either ConvertError res
forall a. MessagePack a => Value -> Either ConvertError a
MP.convertValue (Value -> IO res) -> IO Value -> IO res
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Text -> Text -> Maybe Value -> IO Value
forall a. HasCallStack => Text -> Text -> Maybe a -> IO a
unwrap' Text
"ENOMSG" (Text
"missing message in response: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Print a => a -> Text
T.toText Int
msgid)
            (Int -> PipelineResult -> Maybe Value
forall v. Int -> FlatIntMap v -> Maybe v
FIM.lookup Int
msgid PipelineResult
r)

--------------------------------------------------------------------------------

type ServerLoop = (UVStream -> IO ()) -> IO ()
type ServerService = T.Text -> Maybe ServerHandler
data ServerHandler where
    CallHandler :: (MessagePack req, MessagePack res) => (req -> IO res) -> ServerHandler
    NotifyHandler :: MessagePack req => (req -> IO ()) -> ServerHandler

-- | Simple router using `FlatMap`, lookup name in /O(log(N))/.
--
-- @
-- import Z.IO.PRC.MessagePack
-- import Z.IO.Network
-- import Z.IO
--
-- serveRPC (startTCPServer defaultTCPServerConfig) . simpleRouter $
--  [ ("foo", CallHandler $ \\ req -> do
--      ... )
--  , ("bar", CallHandler $ \\ req -> do
--      ... )
--  ]
--
-- @
simpleRouter :: [(T.Text, ServerHandler)] -> ServerService
simpleRouter :: [(Text, ServerHandler)] -> ServerService
simpleRouter [(Text, ServerHandler)]
handles Text
name = Text -> FlatMap Text ServerHandler -> Maybe ServerHandler
forall k v. Ord k => k -> FlatMap k v -> Maybe v
FM.lookup Text
name FlatMap Text ServerHandler
handleMap
  where
    handleMap :: FlatMap Text ServerHandler
handleMap = [(Text, ServerHandler)] -> FlatMap Text ServerHandler
forall k v. Ord k => [(k, v)] -> FlatMap k v
FM.packR [(Text, ServerHandler)]
handles

-- | Serve a RPC service.
serveRPC :: ServerLoop -> ServerService -> IO ()
serveRPC :: ServerLoop -> ServerService -> IO ()
serveRPC ServerLoop
serve = ServerLoop -> Int -> Int -> ServerService -> IO ()
serveRPC' ServerLoop
serve Int
V.defaultChunkSize Int
V.defaultChunkSize

-- | Serve a RPC service with more control.
serveRPC' :: ServerLoop
          -> Int          -- ^ recv buffer size
          -> Int          -- ^ send buffer size
          -> ServerService -> IO ()
serveRPC' :: ServerLoop -> Int -> Int -> ServerService -> IO ()
serveRPC' ServerLoop
serve Int
recvBufSiz Int
sendBufSiz ServerService
handle = ServerLoop
serve ServerLoop -> ServerLoop
forall a b. (a -> b) -> a -> b
$ \ UVStream
uvs -> do
    BufferedInput
bi <- Int -> UVStream -> IO BufferedInput
forall i. Input i => Int -> i -> IO BufferedInput
newBufferedInput' Int
recvBufSiz UVStream
uvs
    BufferedOutput
bo <- Int -> UVStream -> IO BufferedOutput
forall o. Output o => Int -> o -> IO BufferedOutput
newBufferedOutput' Int
sendBufSiz UVStream
uvs
    BufferedInput -> BufferedOutput -> IO ()
loop BufferedInput
bi BufferedOutput
bo
  where
    loop :: BufferedInput -> BufferedOutput -> IO ()
loop BufferedInput
bi BufferedOutput
bo = do
        Maybe (Either (Text, Value) (Int64, Text, Value))
req <- BIO Void (Either (Text, Value) (Int64, Text, Value))
-> IO (Maybe (Either (Text, Value) (Int64, Text, Value)))
forall inp out. BIO inp out -> IO (Maybe out)
pull (Parser (Either (Text, Value) (Int64, Text, Value))
-> BufferedInput
-> BIO Void (Either (Text, Value) (Int64, Text, Value))
forall a. HasCallStack => Parser a -> BufferedInput -> Source a
sourceParserFromBuffered (do
            Word8
tag <- Parser Word8
P.anyWord8
            case Word8
tag of
                -- notify
                Word8
0x93 -> do
                    !Value
typ <- Parser Value
MV.value
                    !Value
name <- Parser Value
MV.value
                    !Value
v <- Parser Value
MV.value
                    case Value
typ of
                        MV.Int Int64
2 -> case Value
name of
                            MV.Str Text
name' -> Either (Text, Value) (Int64, Text, Value)
-> Parser (Either (Text, Value) (Int64, Text, Value))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text, Value) -> Either (Text, Value) (Int64, Text, Value)
forall a b. a -> Either a b
Left (Text
name', Value
v))
                            Value
_ -> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a. Text -> Parser a
P.fail' (Text -> Parser (Either (Text, Value) (Int64, Text, Value)))
-> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a b. (a -> b) -> a -> b
$ Text
"wrong RPC name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Print a => a -> Text
T.toText Value
name
                        Value
_ -> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a. Text -> Parser a
P.fail' (Text -> Parser (Either (Text, Value) (Int64, Text, Value)))
-> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a b. (a -> b) -> a -> b
$ Text
"wrong notification type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Print a => a -> Text
T.toText Value
typ
                -- call
                Word8
0x94 -> do
                    !Value
typ <- Parser Value
MV.value
                    !Value
seq <- Parser Value
MV.value
                    !Value
name <- Parser Value
MV.value
                    !Value
v <- Parser Value
MV.value
                    case Value
typ of
                        MV.Int Int64
0 -> case Value
seq of
                            MV.Int Int64
msgid | Int64
msgid Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0 Bool -> Bool -> Bool
&& Int64
msgid Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0xFFFFFFFF -> case Value
name of
                                MV.Str Text
name' -> Either (Text, Value) (Int64, Text, Value)
-> Parser (Either (Text, Value) (Int64, Text, Value))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int64, Text, Value) -> Either (Text, Value) (Int64, Text, Value)
forall a b. b -> Either a b
Right (Int64
msgid, Text
name', Value
v))
                                Value
_ -> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a. Text -> Parser a
P.fail' (Text -> Parser (Either (Text, Value) (Int64, Text, Value)))
-> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a b. (a -> b) -> a -> b
$ Text
"wrong RPC name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Print a => a -> Text
T.toText Value
name
                            Value
_ -> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a. Text -> Parser a
P.fail' (Text -> Parser (Either (Text, Value) (Int64, Text, Value)))
-> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a b. (a -> b) -> a -> b
$ Text
"wrong msgid: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Print a => a -> Text
T.toText Value
seq
                        Value
_ -> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a. Text -> Parser a
P.fail' (Text -> Parser (Either (Text, Value) (Int64, Text, Value)))
-> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a b. (a -> b) -> a -> b
$ Text
"wrong request type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Print a => a -> Text
T.toText Value
typ
                Word8
_ -> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a. Text -> Parser a
P.fail' (Text -> Parser (Either (Text, Value) (Int64, Text, Value)))
-> Text -> Parser (Either (Text, Value) (Int64, Text, Value))
forall a b. (a -> b) -> a -> b
$ Text
"wrong request tag: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
forall a. Print a => a -> Text
T.toText Word8
tag
            ) BufferedInput
bi)
        case Maybe (Either (Text, Value) (Int64, Text, Value))
req of
            Just (Left (Text
name, Value
v)) -> do
                case ServerService
handle Text
name of
                    Just (NotifyHandler req -> IO ()
f) -> do
                        req -> IO ()
f (req -> IO ()) -> IO req -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Either ConvertError req -> IO req
forall e a. (HasCallStack, Print e) => Text -> Either e a -> IO a
unwrap Text
"EPARSE" (Value -> Either ConvertError req
forall a. MessagePack a => Value -> Either ConvertError a
MP.convertValue Value
v)
                    Maybe ServerHandler
_ -> Text -> Text -> IO ()
forall a. HasCallStack => Text -> Text -> IO a
throwOtherError Text
"ENOTFOUND" Text
"notification method not found"
                BufferedInput -> BufferedOutput -> IO ()
loop BufferedInput
bi BufferedOutput
bo
            Just (Right (Int64
msgid, Text
name, Value
v)) -> do
                case ServerService
handle Text
name of
                    Just (CallHandler req -> IO res
f) -> do
                        Either SomeException res
res <- IO res -> IO (Either SomeException res)
forall e a. Exception e => IO a -> IO (Either e a)
try (req -> IO res
f (req -> IO res) -> IO req -> IO res
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Either ConvertError req -> IO req
forall e a. (HasCallStack, Print e) => Text -> Either e a -> IO a
unwrap Text
"EPARSE" (Value -> Either ConvertError req
forall a. MessagePack a => Value -> Either ConvertError a
MP.convertValue Value
v))
                        BufferedOutput -> Builder () -> IO ()
forall a. HasCallStack => BufferedOutput -> Builder a -> IO ()
writeBuilder BufferedOutput
bo (Builder () -> IO ()) -> Builder () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            Int -> Builder ()
MB.arrayHeader Int
4
                            Int64 -> Builder ()
MB.int Int64
1                        -- type response
                            Int64 -> Builder ()
MB.int (Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
msgid)     -- msgid
                            case Either SomeException res
res of
                                Left SomeException
e -> do
                                    Text -> Builder ()
MB.str (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException))
                                    Builder ()
MB.nil
                                Right res
res -> do
                                    Builder ()
MB.nil
                                    res -> Builder ()
forall a. MessagePack a => a -> Builder ()
MP.encodeMessagePack res
res
                        HasCallStack => BufferedOutput -> IO ()
BufferedOutput -> IO ()
flushBuffer BufferedOutput
bo
                    Maybe ServerHandler
_ -> do
                        BufferedOutput -> Builder () -> IO ()
forall a. HasCallStack => BufferedOutput -> Builder a -> IO ()
writeBuilder BufferedOutput
bo (Builder () -> IO ()) -> Builder () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            Int -> Builder ()
MB.arrayHeader Int
4
                            Int64 -> Builder ()
MB.int Int64
1                        -- type response
                            Int64 -> Builder ()
MB.int (Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
msgid)     -- msgid
                            Text -> Builder ()
MB.str (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"request method: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not found"
                            Builder ()
MB.nil
                        HasCallStack => BufferedOutput -> IO ()
BufferedOutput -> IO ()
flushBuffer BufferedOutput
bo
                BufferedInput -> BufferedOutput -> IO ()
loop BufferedInput
bi BufferedOutput
bo
            Maybe (Either (Text, Value) (Int64, Text, Value))
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()