{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# 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, 'localTxSubmissionClientPeer' is provided for conversion
-- into the typed protocol.
--
module Ouroboros.Network.Protocol.LocalTxSubmission.Client
  ( -- * Protocol type for the client
    -- | The protocol states from the point of view of the client.
    LocalTxSubmissionClient (..)
  , LocalTxClientStIdle (..)
    -- * The result from a transaction submission.
  , SubmitResult (..)
    -- * Execution as a typed protocol
  , localTxSubmissionClientPeer
    -- * Utilities
  , mapLocalTxSubmissionClient
  ) where

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

import Ouroboros.Network.Protocol.LocalTxSubmission.Type


newtype LocalTxSubmissionClient tx reject m a = LocalTxSubmissionClient {
      forall tx reject (m :: * -> *) a.
LocalTxSubmissionClient tx reject m a
-> m (LocalTxClientStIdle tx reject m a)
runLocalTxSubmissionClient :: m (LocalTxClientStIdle tx reject m a)
    }


-- | The client side of the local transaction submission protocol.
--
-- The peer in the client role submits transactions to the peer in the server
-- role.
--
data LocalTxClientStIdle tx reject m a where

     -- | The client submits a single transaction and waits a reply.
     --
     -- The server replies to inform the client that it has either accepted the
     -- transaction or rejected it. In the rejection case a reason for the
     -- rejection is included.
     --
     SendMsgSubmitTx
       :: tx
       -> (SubmitResult reject -> m (LocalTxClientStIdle tx reject m a))
       -> LocalTxClientStIdle tx reject m a

     -- | The client can terminate the protocol.
     --
     SendMsgDone
       :: a -> LocalTxClientStIdle tx reject m a


-- | Transform a 'LocalTxSubmissionClient' by mapping over the tx and the
-- rejection errors.
--
-- Note the direction of the individual mapping functions corresponds to
-- whether the types are used as protocol inputs or outputs.
--
mapLocalTxSubmissionClient :: forall tx tx' reject reject' m a.
                              Functor m
                           => (tx -> tx')
                           -> (reject' -> reject)
                           -> LocalTxSubmissionClient tx  reject  m a
                           -> LocalTxSubmissionClient tx' reject' m a
mapLocalTxSubmissionClient :: forall tx tx' reject reject' (m :: * -> *) a.
Functor m =>
(tx -> tx')
-> (reject' -> reject)
-> LocalTxSubmissionClient tx reject m a
-> LocalTxSubmissionClient tx' reject' m a
mapLocalTxSubmissionClient tx -> tx'
ftx reject' -> reject
frej =
    \(LocalTxSubmissionClient m (LocalTxClientStIdle tx reject m a)
c) -> m (LocalTxClientStIdle tx' reject' m a)
-> LocalTxSubmissionClient tx' reject' m a
forall tx reject (m :: * -> *) a.
m (LocalTxClientStIdle tx reject m a)
-> LocalTxSubmissionClient tx reject m a
LocalTxSubmissionClient ((LocalTxClientStIdle tx reject m a
 -> LocalTxClientStIdle tx' reject' m a)
-> m (LocalTxClientStIdle tx reject m a)
-> m (LocalTxClientStIdle tx' reject' m a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalTxClientStIdle tx reject m a
-> LocalTxClientStIdle tx' reject' m a
go m (LocalTxClientStIdle tx reject m a)
c)
  where
    go :: LocalTxClientStIdle tx  reject  m a
       -> LocalTxClientStIdle tx' reject' m a
    go :: LocalTxClientStIdle tx reject m a
-> LocalTxClientStIdle tx' reject' m a
go (SendMsgSubmitTx tx
tx SubmitResult reject -> m (LocalTxClientStIdle tx reject m a)
k) =
      tx'
-> (SubmitResult reject'
    -> m (LocalTxClientStIdle tx' reject' m a))
-> LocalTxClientStIdle tx' reject' m a
forall tx reject (m :: * -> *) a.
tx
-> (SubmitResult reject -> m (LocalTxClientStIdle tx reject m a))
-> LocalTxClientStIdle tx reject m a
SendMsgSubmitTx (tx -> tx'
ftx tx
tx) (\SubmitResult reject'
res -> (LocalTxClientStIdle tx reject m a
 -> LocalTxClientStIdle tx' reject' m a)
-> m (LocalTxClientStIdle tx reject m a)
-> m (LocalTxClientStIdle tx' reject' m a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalTxClientStIdle tx reject m a
-> LocalTxClientStIdle tx' reject' m a
go (SubmitResult reject -> m (LocalTxClientStIdle tx reject m a)
k ((reject' -> reject) -> SubmitResult reject' -> SubmitResult reject
forall a b. (a -> b) -> SubmitResult a -> SubmitResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap reject' -> reject
frej SubmitResult reject'
res)))

    go (SendMsgDone a
a) = a -> LocalTxClientStIdle tx' reject' m a
forall a tx reject (m :: * -> *).
a -> LocalTxClientStIdle tx reject m a
SendMsgDone a
a


-- | A non-pipelined 'Peer' representing the 'LocalTxSubmissionClient'.
--
localTxSubmissionClientPeer
  :: forall tx reject m a. Monad m
  => LocalTxSubmissionClient tx reject m a
  -> Client (LocalTxSubmission tx reject) NonPipelined StIdle m a
localTxSubmissionClientPeer :: forall tx reject (m :: * -> *) a.
Monad m =>
LocalTxSubmissionClient tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
localTxSubmissionClientPeer (LocalTxSubmissionClient m (LocalTxClientStIdle tx reject m a)
client) =
    m (Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> Client (LocalTxSubmission tx reject) '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 (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
 -> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> m (Client
        (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
forall a b. (a -> b) -> a -> b
$ LocalTxClientStIdle tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
go (LocalTxClientStIdle tx reject m a
 -> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> m (LocalTxClientStIdle tx reject m a)
-> m (Client
        (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LocalTxClientStIdle tx reject m a)
client
  where
    go :: LocalTxClientStIdle tx reject m a
       -> Client (LocalTxSubmission tx reject) NonPipelined StIdle m a
    go :: LocalTxClientStIdle tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
go (SendMsgSubmitTx tx
tx SubmitResult reject -> m (LocalTxClientStIdle tx reject m a)
k) =
      Message (LocalTxSubmission tx reject) 'StIdle 'StBusy
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StBusy m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle 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 (tx -> Message (LocalTxSubmission tx reject) 'StIdle 'StBusy
forall {k1} tx1 (reject :: k1).
tx1 -> Message (LocalTxSubmission tx1 reject) 'StIdle 'StBusy
MsgSubmitTx tx
tx) (Client (LocalTxSubmission tx reject) 'NonPipelined 'StBusy m a
 -> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StBusy m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
forall a b. (a -> b) -> a -> b
$
      (forall (st' :: LocalTxSubmission tx reject).
 Message (LocalTxSubmission tx reject) 'StBusy st'
 -> Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StBusy 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' :: LocalTxSubmission tx reject).
  Message (LocalTxSubmission tx reject) 'StBusy st'
  -> Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
 -> Client (LocalTxSubmission tx reject) 'NonPipelined 'StBusy m a)
-> (forall (st' :: LocalTxSubmission tx reject).
    Message (LocalTxSubmission tx reject) 'StBusy st'
    -> Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StBusy m a
forall a b. (a -> b) -> a -> b
$ \Message (LocalTxSubmission tx reject) 'StBusy st'
msg -> case Message (LocalTxSubmission tx reject) 'StBusy st'
msg of
        Message (LocalTxSubmission tx reject) 'StBusy st'
R:MessageLocalTxSubmissionfromto (*) (*) tx reject 'StBusy st'
MsgAcceptTx        -> m (Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> Client (LocalTxSubmission tx reject) '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 (LocalTxClientStIdle tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined st' m a
LocalTxClientStIdle tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
go (LocalTxClientStIdle tx reject m a
 -> Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> m (LocalTxClientStIdle tx reject m a)
-> m (Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubmitResult reject -> m (LocalTxClientStIdle tx reject m a)
k SubmitResult reject
forall reason. SubmitResult reason
SubmitSuccess)
        MsgRejectTx reject1
reject -> m (Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> Client (LocalTxSubmission tx reject) '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 (LocalTxClientStIdle tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined st' m a
LocalTxClientStIdle tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
go (LocalTxClientStIdle tx reject m a
 -> Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> m (LocalTxClientStIdle tx reject m a)
-> m (Client (LocalTxSubmission tx reject) 'NonPipelined st' m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubmitResult reject -> m (LocalTxClientStIdle tx reject m a)
k (reject -> SubmitResult reject
forall reason. reason -> SubmitResult reason
SubmitFail reject
reject1
reject))

    go (SendMsgDone a
a) =
      Message (LocalTxSubmission tx reject) 'StIdle 'StDone
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StDone m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle 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 (LocalTxSubmission tx reject) 'StIdle 'StDone
forall {k} {k1} (tx :: k) (reject :: k1).
Message (LocalTxSubmission tx reject) 'StIdle 'StDone
MsgDone (a -> Client (LocalTxSubmission tx reject) '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
a)