{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# 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
    -- * Null local tx submission client
  , localTxSubmissionClientNull
    -- * Utilities
  , mapLocalTxSubmissionClient
  ) where

import           Control.Monad (forever)
import           Control.Monad.Class.MonadTimer

import           Network.TypedProtocol.Core

import           Ouroboros.Network.Protocol.LocalTxSubmission.Type


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

-- | A local tx submission client which never sends any message.
--
localTxSubmissionClientNull :: MonadTimer m => LocalTxSubmissionClient tx reject m a
localTxSubmissionClientNull :: LocalTxSubmissionClient tx reject m a
localTxSubmissionClientNull =
    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 (m (LocalTxClientStIdle tx reject m a)
 -> LocalTxSubmissionClient tx reject m a)
-> m (LocalTxClientStIdle tx reject m a)
-> LocalTxSubmissionClient tx reject m a
forall a b. (a -> b) -> a -> b
$ m () -> m (LocalTxClientStIdle tx reject m a)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m (LocalTxClientStIdle tx reject m a))
-> m () -> m (LocalTxClientStIdle tx reject m a)
forall a b. (a -> b) -> a -> b
$ DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
43200 {- day in seconds -}

{-# DEPRECATED localTxSubmissionClientNull "Use Ouroboros.Network.NodeToClient.localTxSubmissionPeerNull" #-}

-- | 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 :: (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 (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 (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 (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
  -> Peer (LocalTxSubmission tx reject) AsClient StIdle m a
localTxSubmissionClientPeer :: LocalTxSubmissionClient tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
localTxSubmissionClientPeer (LocalTxSubmissionClient m (LocalTxClientStIdle tx reject m a)
client) =
    m (Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> Peer (LocalTxSubmission tx reject) 'AsClient '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) 'AsClient 'StIdle m a)
 -> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> m (Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
forall a b. (a -> b) -> a -> b
$ LocalTxClientStIdle tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
go (LocalTxClientStIdle tx reject m a
 -> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> m (LocalTxClientStIdle tx reject m a)
-> m (Peer (LocalTxSubmission tx reject) 'AsClient '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
       -> Peer (LocalTxSubmission tx reject) AsClient StIdle m a
    go :: LocalTxClientStIdle tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
go (SendMsgSubmitTx tx
tx SubmitResult reject -> m (LocalTxClientStIdle tx reject m a)
k) =
      WeHaveAgency 'AsClient 'StIdle
-> Message (LocalTxSubmission tx reject) 'StIdle 'StBusy
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StBusy m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle 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 (ClientHasAgency 'StIdle -> WeHaveAgency 'AsClient 'StIdle
forall ps (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'StIdle
forall k k (tx :: k) (reject :: k). ClientHasAgency 'StIdle
TokIdle)
            (tx -> Message (LocalTxSubmission tx reject) 'StIdle 'StBusy
forall k tx (reject :: k).
tx -> Message (LocalTxSubmission tx reject) 'StIdle 'StBusy
MsgSubmitTx tx
tx) (Peer (LocalTxSubmission tx reject) 'AsClient 'StBusy m a
 -> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StBusy m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
forall a b. (a -> b) -> a -> b
$
      TheyHaveAgency 'AsClient 'StBusy
-> (forall (st' :: LocalTxSubmission tx reject).
    Message (LocalTxSubmission tx reject) 'StBusy st'
    -> Peer (LocalTxSubmission tx reject) 'AsClient st' m a)
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StBusy 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 (ServerHasAgency 'StBusy -> PeerHasAgency 'AsServer 'StBusy
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'StBusy
forall k k (tx :: k) (reject :: k). ServerHasAgency 'StBusy
TokBusy) ((forall (st' :: LocalTxSubmission tx reject).
  Message (LocalTxSubmission tx reject) 'StBusy st'
  -> Peer (LocalTxSubmission tx reject) 'AsClient st' m a)
 -> Peer (LocalTxSubmission tx reject) 'AsClient 'StBusy m a)
-> (forall (st' :: LocalTxSubmission tx reject).
    Message (LocalTxSubmission tx reject) 'StBusy st'
    -> Peer (LocalTxSubmission tx reject) 'AsClient st' m a)
-> Peer (LocalTxSubmission tx reject) 'AsClient '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'
MsgAcceptTx        -> m (Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> Peer (LocalTxSubmission tx reject) 'AsClient '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 (LocalTxClientStIdle tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
go (LocalTxClientStIdle tx reject m a
 -> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> m (LocalTxClientStIdle tx reject m a)
-> m (Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle 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 reject -> m (Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> Peer (LocalTxSubmission tx reject) 'AsClient '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 (LocalTxClientStIdle tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
go (LocalTxClientStIdle tx reject m a
 -> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a)
-> m (LocalTxClientStIdle tx reject m a)
-> m (Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle 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
reject))

    go (SendMsgDone a
a) =
      WeHaveAgency 'AsClient 'StIdle
-> Message (LocalTxSubmission tx reject) 'StIdle 'StDone
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StDone m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle 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 (ClientHasAgency 'StIdle -> WeHaveAgency 'AsClient 'StIdle
forall ps (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'StIdle
forall k k (tx :: k) (reject :: k). ClientHasAgency 'StIdle
TokIdle)
            Message (LocalTxSubmission tx reject) 'StIdle 'StDone
forall k k (tx :: k) (reject :: k).
Message (LocalTxSubmission tx reject) 'StIdle 'StDone
MsgDone
            (NobodyHasAgency 'StDone
-> a -> Peer (LocalTxSubmission tx reject) 'AsClient '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
a)