{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module: Capnp.Rpc.Transport
-- Description: Support for exchanging messages with remote vats.
--
-- This module provides a 'Transport' type, which provides operations
-- used to transmit messages between vats in the RPC protocol.
module Capnp.Rpc.Transport
  ( Transport (..),
    handleTransport,
    socketTransport,
    tracingTransport,
    TraceConfig (..),
  )
where

import Capnp.Bits (WordCount)
import Capnp.Classes (Parsed)
import Capnp.Convert (msgToParsed)
import qualified Capnp.Gen.Capnp.Rpc as R
import Capnp.IO (hGetMsg, hPutMsg, sGetMsg, sPutMsg)
import Capnp.Message (Message, Mutability (Const))
import Capnp.TraversalLimit (evalLimitT)
import Data.Default (def)
import Network.Socket (Socket)
import System.IO (Handle)
import Text.Show.Pretty (ppShow)
import Prelude hiding (log)

-- | A @'Transport'@ handles transmitting RPC messages.
data Transport = Transport
  { -- | Send a message
    Transport -> Message 'Const -> IO ()
sendMsg :: Message 'Const -> IO (),
    -- | Receive a message
    Transport -> IO (Message 'Const)
recvMsg :: IO (Message 'Const)
  }

-- | @'handleTransport' handle limit@ is a transport which reads and writes
-- messages from/to @handle@. It uses @limit@ as the traversal limit when
-- reading messages and decoding.
handleTransport :: Handle -> WordCount -> Transport
handleTransport :: Handle -> WordCount -> Transport
handleTransport Handle
handle WordCount
limit =
  Transport
    { $sel:sendMsg:Transport :: Message 'Const -> IO ()
sendMsg = Handle -> Message 'Const -> IO ()
hPutMsg Handle
handle,
      $sel:recvMsg:Transport :: IO (Message 'Const)
recvMsg = Handle -> WordCount -> IO (Message 'Const)
hGetMsg Handle
handle WordCount
limit
    }

-- | @'socketTransport' socket limit@ is a transport which reads and writes
-- messages to/from a socket. It uses @limit@ as the traversal limit when
-- reading messages and decoing.
socketTransport :: Socket -> WordCount -> Transport
socketTransport :: Socket -> WordCount -> Transport
socketTransport Socket
socket WordCount
limit =
  Transport
    { $sel:sendMsg:Transport :: Message 'Const -> IO ()
sendMsg = Socket -> Message 'Const -> IO ()
sPutMsg Socket
socket,
      $sel:recvMsg:Transport :: IO (Message 'Const)
recvMsg = Socket -> WordCount -> IO (Message 'Const)
sGetMsg Socket
socket WordCount
limit
    }

data TraceConfig = TraceConfig
  { TraceConfig -> String -> IO ()
log :: String -> IO (),
    TraceConfig -> Bool
showPayloads :: !Bool
  }

-- | @'tracingTransport' log trans@ wraps another transport @trans@, loging
-- messages when they are sent or received (using the @log@ function). This
-- can be useful for debugging.
tracingTransport :: TraceConfig -> Transport -> Transport
tracingTransport :: TraceConfig -> Transport -> Transport
tracingTransport TraceConfig
tcfg Transport
trans =
  Transport
    { $sel:sendMsg:Transport :: Message 'Const -> IO ()
sendMsg = \Message 'Const
msg -> do
        Parsed Message
rpcMsg <- forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT forall a. Bounded a => a
maxBound forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *) pa.
(ReadCtx m 'Const, IsStruct a, Parse a pa) =>
Message 'Const -> m pa
msgToParsed @R.Message Message 'Const
msg
        TraceConfig -> String -> IO ()
log TraceConfig
tcfg forall a b. (a -> b) -> a -> b
$ String
"sending message: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
ppShow (TraceConfig -> Parsed Message -> Parsed Message
editForTrace TraceConfig
tcfg Parsed Message
rpcMsg)
        Transport -> Message 'Const -> IO ()
sendMsg Transport
trans Message 'Const
msg,
      $sel:recvMsg:Transport :: IO (Message 'Const)
recvMsg = do
        Message 'Const
msg <- Transport -> IO (Message 'Const)
recvMsg Transport
trans
        Parsed Message
rpcMsg <- forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT forall a. Bounded a => a
maxBound forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *) pa.
(ReadCtx m 'Const, IsStruct a, Parse a pa) =>
Message 'Const -> m pa
msgToParsed @R.Message Message 'Const
msg
        TraceConfig -> String -> IO ()
log TraceConfig
tcfg forall a b. (a -> b) -> a -> b
$ String
"received message: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
ppShow (TraceConfig -> Parsed Message -> Parsed Message
editForTrace TraceConfig
tcfg Parsed Message
rpcMsg)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Message 'Const
msg
    }

editForTrace :: TraceConfig -> Parsed R.Message -> Parsed R.Message
editForTrace :: TraceConfig -> Parsed Message -> Parsed Message
editForTrace TraceConfig
tcfg Parsed Message
rpcMsg =
  if TraceConfig -> Bool
showPayloads TraceConfig
tcfg
    then Parsed Message
rpcMsg
    else
      ( case Parsed Message
rpcMsg of
          R.Message (R.Message'call Parsed Call
call) ->
            Parsed (Which Message) -> Parsed Message
R.Message forall a b. (a -> b) -> a -> b
$
              Parsed Call -> Parsed (Which Message)
R.Message'call forall a b. (a -> b) -> a -> b
$
                Parsed Call
call {$sel:params:Call :: Parsed Payload
R.params = forall a. Default a => a
def}
          R.Message (R.Message'return R.Return {$sel:union':Return :: Parsed Return -> Parsed (Which Return)
union' = R.Return'results Parsed Payload
_, Parsed Bool
Parsed Word32
$sel:releaseParamCaps:Return :: Parsed Return -> Parsed Bool
$sel:answerId:Return :: Parsed Return -> Parsed Word32
releaseParamCaps :: Parsed Bool
answerId :: Parsed Word32
..}) ->
            Parsed (Which Message) -> Parsed Message
R.Message forall a b. (a -> b) -> a -> b
$
              Parsed Return -> Parsed (Which Message)
R.Message'return forall a b. (a -> b) -> a -> b
$
                R.Return {$sel:union':Return :: Parsed (Which Return)
R.union' = Parsed Payload -> Parsed (Which Return)
R.Return'results forall a. Default a => a
def, Parsed Bool
Parsed Word32
$sel:releaseParamCaps:Return :: Parsed Bool
$sel:answerId:Return :: Parsed Word32
releaseParamCaps :: Parsed Bool
answerId :: Parsed Word32
..}
          Parsed Message
_ ->
            Parsed Message
rpcMsg
      )