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

module Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
  ( localTxSubmissionServer

    -- * Trace events
  , TraceLocalTxSubmissionServerEvent (..)
  ) where

import Control.Tracer
import Data.Tuple (Solo (..))
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
          MkSolo addTxRes <- Mempool m blk
-> Solo (GenTx blk) -> m (Solo (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 -> Solo (GenTx blk)
forall a. a -> Solo a
MkSolo GenTx blk
tx)
          case 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
  = -- | A transaction was received.
    TraceReceivedTx (GenTx blk)

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