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

-- | A view of the local transaction submission protocol from the point of view
-- of the server.
--
-- This provides a view that uses less complex types and should be easier to
-- use than the underlying typed protocol itself.
--
-- For execution, a conversion into the typed protocol is provided.
--
module Ouroboros.Network.Protocol.LocalTxSubmission.Server
  ( -- * Protocol type for the server
    -- | The protocol states from the point of view of the server.
    LocalTxSubmissionServer (..)
    -- * Execution as a typed protocol
  , localTxSubmissionServerPeer
  ) where

import           Network.TypedProtocol.Core

import           Ouroboros.Network.Protocol.LocalTxSubmission.Type


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

       -- | The client has submited a single transaction and it expects a reply.
       --
       -- The server must reply 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.
       --
       LocalTxSubmissionServer tx reject m a
-> tx
-> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a)
recvMsgSubmitTx :: tx -> m ( SubmitResult reject
                                  , LocalTxSubmissionServer tx reject m a ),

       -- | The client can terminate the protocol.
       --
       LocalTxSubmissionServer tx reject m a -> a
recvMsgDone     :: a
     }


-- | A non-pipelined 'Peer' representing the 'LocalTxSubmissionServer'.
--
localTxSubmissionServerPeer
  :: forall tx reject m a. Monad m
  => m (LocalTxSubmissionServer tx reject m a)
  -> Peer (LocalTxSubmission tx reject) AsServer StIdle m a
localTxSubmissionServerPeer :: m (LocalTxSubmissionServer tx reject m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
localTxSubmissionServerPeer m (LocalTxSubmissionServer tx reject m a)
server =
    m (Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) a.
m (Peer ps pr st m a) -> Peer ps pr st m a
Effect (m (Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a)
 -> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a)
-> m (Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
forall a b. (a -> b) -> a -> b
$ LocalTxSubmissionServer tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
go (LocalTxSubmissionServer tx reject m a
 -> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a)
-> m (LocalTxSubmissionServer tx reject m a)
-> m (Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LocalTxSubmissionServer tx reject m a)
server
  where
    go :: LocalTxSubmissionServer tx reject m a
       -> Peer (LocalTxSubmission tx reject) AsServer StIdle m a
    go :: LocalTxSubmissionServer tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
go LocalTxSubmissionServer{tx
-> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a)
recvMsgSubmitTx :: tx
-> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a)
recvMsgSubmitTx :: forall tx reject (m :: * -> *) a.
LocalTxSubmissionServer tx reject m a
-> tx
-> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a)
recvMsgSubmitTx, a
recvMsgDone :: a
recvMsgDone :: forall tx reject (m :: * -> *) a.
LocalTxSubmissionServer tx reject m a -> a
recvMsgDone} =
      TheyHaveAgency 'AsServer 'StIdle
-> (forall (st' :: LocalTxSubmission tx reject).
    Message (LocalTxSubmission tx reject) 'StIdle st'
    -> Peer (LocalTxSubmission tx reject) 'AsServer st' m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
forall (pr :: PeerRole) ps (st :: ps) (m :: * -> *) a.
TheyHaveAgency pr st
-> (forall (st' :: ps). Message ps st st' -> Peer ps pr st' m a)
-> Peer ps pr st m a
Await (ClientHasAgency 'StIdle -> PeerHasAgency 'AsClient 'StIdle
forall ps (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'StIdle
forall k k (tx :: k) (reject :: k). ClientHasAgency 'StIdle
TokIdle) ((forall (st' :: LocalTxSubmission tx reject).
  Message (LocalTxSubmission tx reject) 'StIdle st'
  -> Peer (LocalTxSubmission tx reject) 'AsServer st' m a)
 -> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a)
-> (forall (st' :: LocalTxSubmission tx reject).
    Message (LocalTxSubmission tx reject) 'StIdle st'
    -> Peer (LocalTxSubmission tx reject) 'AsServer st' m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
forall a b. (a -> b) -> a -> b
$ \Message (LocalTxSubmission tx reject) 'StIdle st'
msg -> case Message (LocalTxSubmission tx reject) 'StIdle st'
msg of
        MsgSubmitTx tx -> m (Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) a.
m (Peer ps pr st m a) -> Peer ps pr st m a
Effect (m (Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a)
 -> Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a)
-> m (Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a
forall a b. (a -> b) -> a -> b
$ do
          (SubmitResult reject
result, LocalTxSubmissionServer tx reject m a
k) <- tx
-> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a)
recvMsgSubmitTx tx
tx
tx
          Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a
-> m (Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a
 -> m (Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a))
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a
-> m (Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a)
forall a b. (a -> b) -> a -> b
$
            case SubmitResult reject
result of
              SubmitResult reject
SubmitSuccess ->
                WeHaveAgency 'AsServer 'StBusy
-> Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) (m :: * -> *) a.
WeHaveAgency pr st
-> Message ps st st' -> Peer ps pr st' m a -> Peer ps pr st m a
Yield
                  (ServerHasAgency 'StBusy -> WeHaveAgency 'AsServer 'StBusy
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'StBusy
forall k k (tx :: k) (reject :: k). ServerHasAgency 'StBusy
TokBusy)
                  Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
forall k k (tx :: k) (reject :: k).
Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
MsgAcceptTx
                  (LocalTxSubmissionServer tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
go LocalTxSubmissionServer tx reject m a
k)
              SubmitFail reject
reject ->
                WeHaveAgency 'AsServer 'StBusy
-> Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StBusy m a
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) (m :: * -> *) a.
WeHaveAgency pr st
-> Message ps st st' -> Peer ps pr st' m a -> Peer ps pr st m a
Yield
                  (ServerHasAgency 'StBusy -> WeHaveAgency 'AsServer 'StBusy
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'StBusy
forall k k (tx :: k) (reject :: k). ServerHasAgency 'StBusy
TokBusy)
                  (reject -> Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
forall k reject (tx :: k).
reject -> Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
MsgRejectTx reject
reject)
                  (LocalTxSubmissionServer tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
go LocalTxSubmissionServer tx reject m a
k)

        Message (LocalTxSubmission tx reject) 'StIdle st'
MsgDone -> NobodyHasAgency 'StDone
-> a -> Peer (LocalTxSubmission tx reject) 'AsServer 'StDone m a
forall ps (st :: ps) a (pr :: PeerRole) (m :: * -> *).
NobodyHasAgency st -> a -> Peer ps pr st m a
Done NobodyHasAgency 'StDone
forall k k (tx :: k) (reject :: k). NobodyHasAgency 'StDone
TokDone a
recvMsgDone