{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server (
    localTxSubmissionServer
    -- * Trace events
  , TraceLocalTxSubmissionServerEvent (..)
  ) where

import           Control.Tracer
import           Data.SOP.BasicFunctors
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool.API
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Network.Protocol.LocalTxSubmission.Server
import           Ouroboros.Network.Protocol.LocalTxSubmission.Type


-- | Local transaction submission server, for adding txs to the 'Mempool'
--
localTxSubmissionServer ::
     MonadSTM m
  => Tracer m (TraceLocalTxSubmissionServerEvent blk)
  -> Mempool m blk
  -> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
localTxSubmissionServer :: forall (m :: * -> *) blk.
MonadSTM m =>
Tracer m (TraceLocalTxSubmissionServerEvent blk)
-> Mempool m blk
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
localTxSubmissionServer Tracer m (TraceLocalTxSubmissionServerEvent blk)
tracer Mempool m blk
mempool =
    LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
server
  where
    server :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
server = LocalTxSubmissionServer {
      recvMsgSubmitTx :: GenTx blk
-> m (SubmitResult (ApplyTxErr blk),
      LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
recvMsgSubmitTx = \GenTx blk
tx -> do
        Tracer m (TraceLocalTxSubmissionServerEvent blk)
-> TraceLocalTxSubmissionServerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalTxSubmissionServerEvent blk)
tracer (TraceLocalTxSubmissionServerEvent blk -> m ())
-> TraceLocalTxSubmissionServerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ GenTx blk -> TraceLocalTxSubmissionServerEvent blk
forall blk. GenTx blk -> TraceLocalTxSubmissionServerEvent blk
TraceReceivedTx GenTx blk
tx
        -- Once we drop GHC 8.10, we could use @Solo@ from base.
        I MempoolAddTxResult blk
addTxRes <- Mempool m blk -> I (GenTx blk) -> m (I (MempoolAddTxResult blk))
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addLocalTxs Mempool m blk
mempool (GenTx blk -> I (GenTx blk)
forall a. a -> I a
I GenTx blk
tx)
        case MempoolAddTxResult blk
addTxRes of
          MempoolTxAdded Validated (GenTx blk)
_tx             -> (SubmitResult (ApplyTxErr blk),
 LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
-> m (SubmitResult (ApplyTxErr blk),
      LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SubmitResult (ApplyTxErr blk)
forall reason. SubmitResult reason
SubmitSuccess, LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
server)
          MempoolTxRejected GenTx blk
_tx ApplyTxErr blk
addTxErr -> (SubmitResult (ApplyTxErr blk),
 LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
-> m (SubmitResult (ApplyTxErr blk),
      LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplyTxErr blk -> SubmitResult (ApplyTxErr blk)
forall reason. reason -> SubmitResult reason
SubmitFail ApplyTxErr blk
addTxErr, LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
server)

    , recvMsgDone :: ()
recvMsgDone = ()
    }


{-------------------------------------------------------------------------------
  Trace events
-------------------------------------------------------------------------------}

data TraceLocalTxSubmissionServerEvent blk
  = TraceReceivedTx (GenTx blk)
    -- ^ A transaction was received.

deriving instance Eq   (GenTx blk)
               => Eq   (TraceLocalTxSubmissionServerEvent blk)
deriving instance Show (GenTx blk)
               => Show (TraceLocalTxSubmissionServerEvent blk)