{-# 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 Network.TypedProtocol.Peer.Server

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.
       --
       forall tx reject (m :: * -> *) a.
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.
       --
       forall tx reject (m :: * -> *) a.
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)
  -> Server (LocalTxSubmission tx reject) NonPipelined StIdle m a
localTxSubmissionServerPeer :: forall tx reject (m :: * -> *) a.
Monad m =>
m (LocalTxSubmissionServer tx reject m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
localTxSubmissionServerPeer m (LocalTxSubmissionServer tx reject m a)
server =
    m (Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect (m (Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
 -> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> m (Server
        (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
forall a b. (a -> b) -> a -> b
$ LocalTxSubmissionServer tx reject m a
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
go (LocalTxSubmissionServer tx reject m a
 -> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> m (LocalTxSubmissionServer tx reject m a)
-> m (Server
        (LocalTxSubmission tx reject) 'NonPipelined '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
       -> Server (LocalTxSubmission tx reject) NonPipelined StIdle m a
    go :: LocalTxSubmissionServer tx reject m a
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
go LocalTxSubmissionServer{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 :: tx
-> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a)
recvMsgSubmitTx, a
recvMsgDone :: forall tx reject (m :: * -> *) a.
LocalTxSubmissionServer tx reject m a -> a
recvMsgDone :: a
recvMsgDone} =
      (forall (st' :: LocalTxSubmission tx reject).
 Message (LocalTxSubmission tx reject) 'StIdle st'
 -> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'ClientAgency,
 Outstanding pl ~ 'Z) =>
(forall (st' :: ps). Message ps st st' -> Server ps pl st' m a)
-> Server ps pl st m a
Await ((forall (st' :: LocalTxSubmission tx reject).
  Message (LocalTxSubmission tx reject) 'StIdle st'
  -> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a)
 -> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a)
-> (forall (st' :: LocalTxSubmission tx reject).
    Message (LocalTxSubmission tx reject) 'StIdle st'
    -> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined '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 tx1
tx -> m (Server (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect (m (Server (LocalTxSubmission tx reject) 'NonPipelined st' m a)
 -> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> m (Server (LocalTxSubmission tx reject) 'NonPipelined st' m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ do
          (result, k) <- tx
-> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a)
recvMsgSubmitTx tx
tx1
tx
          return $
            case result of
              SubmitResult reject
SubmitSuccess ->
                Message (LocalTxSubmission tx reject) st' 'StIdle
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
-> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a
       (st' :: ps).
(StateTokenI st, StateTokenI st', StateAgency st ~ 'ServerAgency,
 Outstanding pl ~ 'Z) =>
Message ps st st' -> Server ps pl st' m a -> Server ps pl st m a
Yield
                  Message (LocalTxSubmission tx reject) st' 'StIdle
Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
forall {k} {k1} (tx :: k) (reject :: k1).
Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
MsgAcceptTx
                  (LocalTxSubmissionServer tx reject m a
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
go LocalTxSubmissionServer tx reject m a
k)
              SubmitFail reject
reject ->
                Message (LocalTxSubmission tx reject) st' 'StIdle
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
-> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a
       (st' :: ps).
(StateTokenI st, StateTokenI st', StateAgency st ~ 'ServerAgency,
 Outstanding pl ~ 'Z) =>
Message ps st st' -> Server ps pl st' m a -> Server ps pl st m a
Yield
                  (reject -> Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
forall {k} reject1 (tx :: k).
reject1 -> Message (LocalTxSubmission tx reject1) 'StBusy 'StIdle
MsgRejectTx reject
reject)
                  (LocalTxSubmissionServer tx reject m a
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
go LocalTxSubmissionServer tx reject m a
k)

        Message (LocalTxSubmission tx reject) 'StIdle st'
R:MessageLocalTxSubmissionfromto (*) (*) tx reject 'StIdle st'
MsgDone -> a -> Server (LocalTxSubmission tx reject) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z) =>
a -> Server ps pl st m a
Done a
recvMsgDone