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

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

import           Control.Tracer

import           Ouroboros.Network.Protocol.LocalTxSubmission.Server
import           Ouroboros.Network.Protocol.LocalTxSubmission.Type

import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool.API
import           Ouroboros.Consensus.Util.IOLike


-- | Local transaction submission server, for adding txs to the 'Mempool'
--
localTxSubmissionServer
  :: MonadSTM m
  => Tracer m (TraceLocalTxSubmissionServerEvent blk)
  -> Mempool m blk idx
  -> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
localTxSubmissionServer :: Tracer m (TraceLocalTxSubmissionServerEvent blk)
-> Mempool m blk idx
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
localTxSubmissionServer Tracer m (TraceLocalTxSubmissionServerEvent blk)
tracer Mempool m blk idx
mempool =
    LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
server
  where
    server :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
server = LocalTxSubmissionServer :: forall tx reject (m :: * -> *) a.
(tx
 -> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a))
-> a -> LocalTxSubmissionServer tx reject m a
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
        [MempoolAddTxResult blk]
res <- Mempool m blk idx -> [GenTx blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) blk idx.
MonadSTM m =>
Mempool m blk idx -> [GenTx blk] -> m [MempoolAddTxResult blk]
addLocalTxs Mempool m blk idx
mempool [GenTx blk
tx]
        case [MempoolAddTxResult blk]
res of
          [MempoolAddTxResult blk
addTxRes] -> 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 (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 (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)
          -- The output list of addTxs has the same length as the input list.
          [MempoolAddTxResult blk]
_                 -> [Char]
-> m (SubmitResult (ApplyTxErr blk),
      LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
forall a. HasCallStack => [Char] -> a
error [Char]
"addTxs: unexpected result"

    , 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)