{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | A view of the transaction submission protocol from the point of view of
-- the client.
--
-- This provides a view that uses less complex types and should be easier to
-- use than the underlying typed protocol itself.
--
-- For execution, 'txSubmissionClientPeer' is provided for conversion
-- into the typed protocol.
--
module Ouroboros.Network.Protocol.TxSubmission2.Client
  ( -- * Protocol type for the client
    -- | The protocol states from the point of view of the client.
    TxSubmissionClient (..)
  , ClientStIdle (..)
  , ClientStTxIds (..)
  , ClientStTxs (..)
  , SingBlockingStyle (..)
  , BlockingReplyList (..)
    -- * Execution as a typed protocol
  , txSubmissionClientPeer
  ) where

import Network.TypedProtocol.Core
import Network.TypedProtocol.Peer.Client

import Ouroboros.Network.Protocol.TxSubmission2.Type


-- | The client side of the transaction submission protocol.
--
-- The peer in the client role submits transactions to the peer in the server
-- role.
--
newtype TxSubmissionClient txid tx m a = TxSubmissionClient {
    forall txid tx (m :: * -> *) a.
TxSubmissionClient txid tx m a -> m (ClientStIdle txid tx m a)
runTxSubmissionClient :: m (ClientStIdle txid tx m a)
  }

-- | In the 'StIdle' protocol state, the client does not have agency. Instead
-- it is waiting for:
--
-- * a request for transaction ids (blocking or non-blocking)
-- * a request for a given list of transactions
-- * a termination message
--
-- It must be prepared to handle any of these.
--
data ClientStIdle txid tx m a = ClientStIdle {

    forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking
   -> NumTxIdsToAck
   -> NumTxIdsToReq
   -> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds      :: forall blocking.
                                SingBlockingStyle blocking
                             -> NumTxIdsToAck
                             -> NumTxIdsToReq
                             -> m (ClientStTxIds blocking txid tx m a),

    forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a -> [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs        :: [txid]
                             -> m (ClientStTxs txid tx m a)
  }

data ClientStTxIds blocking txid tx m a where
  SendMsgReplyTxIds :: BlockingReplyList blocking (txid, SizeInBytes)
                    -> ClientStIdle           txid tx m a
                    -> ClientStTxIds blocking txid tx m a

  -- | In the blocking case, the client can terminate the protocol. This could
  -- be used when the client knows there will be no more transactions to submit.
  --
  SendMsgDone       :: a -> ClientStTxIds StBlocking txid tx m a


data ClientStTxs txid tx m a where
  SendMsgReplyTxs   :: [tx]
                    -> ClientStIdle txid tx m a
                    -> ClientStTxs  txid tx m a


-- | A non-pipelined 'Peer' representing the 'TxSubmissionClient'.
--
txSubmissionClientPeer :: forall txid tx m a. Monad m
                       => TxSubmissionClient txid tx m a
                       -> Client (TxSubmission2 txid tx) NonPipelined StInit m a
txSubmissionClientPeer :: forall txid tx (m :: * -> *) a.
Monad m =>
TxSubmissionClient txid tx m a
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StInit m a
txSubmissionClientPeer (TxSubmissionClient m (ClientStIdle txid tx m a)
client) =
    Message (TxSubmission2 txid tx) 'StInit 'StIdle
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StInit m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a
       (st' :: ps).
(StateTokenI st, StateTokenI st', StateAgency st ~ 'ClientAgency,
 Outstanding pl ~ 'Z) =>
Message ps st st' -> Client ps pl st' m a -> Client ps pl st m a
Yield Message (TxSubmission2 txid tx) 'StInit 'StIdle
forall {k} {k1} (txid :: k) (tx :: k1).
Message (TxSubmission2 txid tx) 'StInit 'StIdle
MsgInit (Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
 -> Client (TxSubmission2 txid tx) 'NonPipelined 'StInit m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StInit m a
forall a b. (a -> b) -> a -> b
$
    m (Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Client ps pl st m a) -> Client ps pl st m a
Effect (m (Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a)
 -> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a)
-> m (Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
forall a b. (a -> b) -> a -> b
$ ClientStIdle txid tx m a
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
go (ClientStIdle txid tx m a
 -> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a)
-> m (ClientStIdle txid tx m a)
-> m (Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStIdle txid tx m a)
client
  where
    go :: ClientStIdle txid tx m a
       -> Client (TxSubmission2 txid tx) NonPipelined StIdle m a
    go :: ClientStIdle txid tx m a
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
go ClientStIdle {forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking
   -> NumTxIdsToAck
   -> NumTxIdsToReq
   -> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds, [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: forall txid tx (m :: * -> *) a.
ClientStIdle txid tx m a -> [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs :: [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs} =
      (forall (st' :: TxSubmission2 txid tx).
 Message (TxSubmission2 txid tx) 'StIdle st'
 -> Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'ServerAgency,
 Outstanding pl ~ 'Z) =>
(forall (st' :: ps). Message ps st st' -> Client ps pl st' m a)
-> Client ps pl st m a
Await ((forall (st' :: TxSubmission2 txid tx).
  Message (TxSubmission2 txid tx) 'StIdle st'
  -> Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
 -> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a)
-> (forall (st' :: TxSubmission2 txid tx).
    Message (TxSubmission2 txid tx) 'StIdle st'
    -> Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
forall a b. (a -> b) -> a -> b
$ \Message (TxSubmission2 txid tx) 'StIdle st'
msg -> case Message (TxSubmission2 txid tx) 'StIdle st'
msg of
        MsgRequestTxIds SingBlockingStyle blocking
blocking NumTxIdsToAck
ackNo NumTxIdsToReq
reqNo -> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Client ps pl st m a) -> Client ps pl st m a
Effect (m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
 -> Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
-> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ do
          reply <- SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumTxIdsToAck
-> NumTxIdsToReq
-> m (ClientStTxIds blocking txid tx m a)
recvMsgRequestTxIds SingBlockingStyle blocking
blocking NumTxIdsToAck
ackNo NumTxIdsToReq
reqNo
          case reply of
            SendMsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
txids ClientStIdle txid tx m a
k ->
              -- TODO: investigate why GHC cannot infer `SingI`; it used to in
              -- `coot/typed-protocols-rewrite` branch
              Client (TxSubmission2 txid tx) 'NonPipelined st' m a
-> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Client (TxSubmission2 txid tx) 'NonPipelined st' m a
 -> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a))
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
-> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
forall a b. (a -> b) -> a -> b
$ case SingBlockingStyle blocking
blocking of
                SingBlockingStyle blocking
SingBlocking    -> Message (TxSubmission2 txid tx) st' 'StIdle
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a
       (st' :: ps).
(StateTokenI st, StateTokenI st', StateAgency st ~ 'ClientAgency,
 Outstanding pl ~ 'Z) =>
Message ps st st' -> Client ps pl st' m a -> Client ps pl st m a
Yield (BlockingReplyList blocking (txid, SizeInBytes)
-> Message (TxSubmission2 txid tx) ('StTxIds blocking) 'StIdle
forall {k1} (blocking :: StBlockingStyle) txid1 (tx :: k1).
BlockingReplyList blocking (txid1, SizeInBytes)
-> Message (TxSubmission2 txid1 tx) ('StTxIds blocking) 'StIdle
MsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
txids)
                                         (ClientStIdle txid tx m a
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
go ClientStIdle txid tx m a
k)
                SingBlockingStyle blocking
SingNonBlocking -> Message (TxSubmission2 txid tx) st' 'StIdle
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a
       (st' :: ps).
(StateTokenI st, StateTokenI st', StateAgency st ~ 'ClientAgency,
 Outstanding pl ~ 'Z) =>
Message ps st st' -> Client ps pl st' m a -> Client ps pl st m a
Yield (BlockingReplyList blocking (txid, SizeInBytes)
-> Message (TxSubmission2 txid tx) ('StTxIds blocking) 'StIdle
forall {k1} (blocking :: StBlockingStyle) txid1 (tx :: k1).
BlockingReplyList blocking (txid1, SizeInBytes)
-> Message (TxSubmission2 txid1 tx) ('StTxIds blocking) 'StIdle
MsgReplyTxIds BlockingReplyList blocking (txid, SizeInBytes)
txids)
                                         (ClientStIdle txid tx m a
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StIdle m a
go ClientStIdle txid tx m a
k)

            SendMsgDone a
result ->
              Client (TxSubmission2 txid tx) 'NonPipelined st' m a
-> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Client (TxSubmission2 txid tx) 'NonPipelined st' m a
 -> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a))
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
-> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
forall a b. (a -> b) -> a -> b
$ Message (TxSubmission2 txid tx) st' 'StDone
-> Client (TxSubmission2 txid tx) 'NonPipelined 'StDone m a
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a
       (st' :: ps).
(StateTokenI st, StateTokenI st', StateAgency st ~ 'ClientAgency,
 Outstanding pl ~ 'Z) =>
Message ps st st' -> Client ps pl st' m a -> Client ps pl st m a
Yield Message (TxSubmission2 txid tx) st' 'StDone
Message (TxSubmission2 txid tx) ('StTxIds 'StBlocking) 'StDone
forall {k} {k1} (txid :: k) (tx :: k1).
Message (TxSubmission2 txid tx) ('StTxIds 'StBlocking) 'StDone
MsgDone
                             (a -> Client (TxSubmission2 txid tx) 'NonPipelined 'StDone m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z) =>
a -> Client ps pl st m a
Done a
result)

        MsgRequestTxs [txid1]
txids -> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Client ps pl st m a) -> Client ps pl st m a
Effect (m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
 -> Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
-> m (Client (TxSubmission2 txid tx) 'NonPipelined st' m a)
-> Client (TxSubmission2 txid tx) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ do
          SendMsgReplyTxs txs k <- [txid] -> m (ClientStTxs txid tx m a)
recvMsgRequestTxs [txid]
[txid1]
txids
          return $ Yield (MsgReplyTxs txs)
                         (go k)