{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Bench.Consensus.Mempool (
    -- * Commands
    MempoolCmd (..)
    -- ** Queries on commands
  , getCmdTx
  , getCmdTxId
  , getCmdsTxIds
  , getCmdsTxs
    -- * Commands execution
  , run
  ) where

import           Bench.Consensus.Mempool.TestBlock ()
import           Control.DeepSeq (NFData)
import           Control.Monad (void)
import           Data.Foldable (traverse_)
import           Data.Maybe (mapMaybe)
import           GHC.Generics (Generic)
import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Ledger
import           Ouroboros.Consensus.Mempool.API (AddTxOnBehalfOf (..))
import qualified Test.Consensus.Mempool.Mocked as Mocked
import           Test.Consensus.Mempool.Mocked (MockedMempool)

{-------------------------------------------------------------------------------
  Commands
-------------------------------------------------------------------------------}

data MempoolCmd blk =
    -- | Add a transaction.
    --
    -- NB: if the mempool is full, the execution of this command will block
    -- until the mempool has at least one byte free. As a consenquence, if these
    -- commands are run sequentially the benchmarks or tests will deadlock if
    -- the maxium mempool capacity is reached.
    AddTx (Ledger.GenTx blk)
  deriving ((forall x. MempoolCmd blk -> Rep (MempoolCmd blk) x)
-> (forall x. Rep (MempoolCmd blk) x -> MempoolCmd blk)
-> Generic (MempoolCmd blk)
forall x. Rep (MempoolCmd blk) x -> MempoolCmd blk
forall x. MempoolCmd blk -> Rep (MempoolCmd blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (MempoolCmd blk) x -> MempoolCmd blk
forall blk x. MempoolCmd blk -> Rep (MempoolCmd blk) x
$cfrom :: forall blk x. MempoolCmd blk -> Rep (MempoolCmd blk) x
from :: forall x. MempoolCmd blk -> Rep (MempoolCmd blk) x
$cto :: forall blk x. Rep (MempoolCmd blk) x -> MempoolCmd blk
to :: forall x. Rep (MempoolCmd blk) x -> MempoolCmd blk
Generic)

deriving anyclass instance (NFData (Ledger.GenTx blk)) => NFData (MempoolCmd blk)

getCmdTx :: MempoolCmd blk -> Maybe (Ledger.GenTx blk)
getCmdTx :: forall blk. MempoolCmd blk -> Maybe (GenTx blk)
getCmdTx (AddTx GenTx blk
tx) = GenTx blk -> Maybe (GenTx blk)
forall a. a -> Maybe a
Just GenTx blk
tx

getCmdsTxs :: [MempoolCmd blk] -> [Ledger.GenTx blk]
getCmdsTxs :: forall blk. [MempoolCmd blk] -> [GenTx blk]
getCmdsTxs = (MempoolCmd blk -> Maybe (GenTx blk))
-> [MempoolCmd blk] -> [GenTx blk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MempoolCmd blk -> Maybe (GenTx blk)
forall blk. MempoolCmd blk -> Maybe (GenTx blk)
getCmdTx

getCmdTxId ::
     Ledger.HasTxId (Ledger.GenTx blk)
  => MempoolCmd blk -> Maybe (Ledger.TxId (Ledger.GenTx blk))
getCmdTxId :: forall blk.
HasTxId (GenTx blk) =>
MempoolCmd blk -> Maybe (TxId (GenTx blk))
getCmdTxId = (GenTx blk -> TxId (GenTx blk))
-> Maybe (GenTx blk) -> Maybe (TxId (GenTx blk))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenTx blk -> TxId (GenTx blk)
forall tx. HasTxId tx => tx -> TxId tx
Ledger.txId (Maybe (GenTx blk) -> Maybe (TxId (GenTx blk)))
-> (MempoolCmd blk -> Maybe (GenTx blk))
-> MempoolCmd blk
-> Maybe (TxId (GenTx blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolCmd blk -> Maybe (GenTx blk)
forall blk. MempoolCmd blk -> Maybe (GenTx blk)
getCmdTx

getCmdsTxIds ::
     Ledger.HasTxId (Ledger.GenTx blk)
  => [MempoolCmd blk] -> [Ledger.TxId (Ledger.GenTx blk)]
getCmdsTxIds :: forall blk.
HasTxId (GenTx blk) =>
[MempoolCmd blk] -> [TxId (GenTx blk)]
getCmdsTxIds = (MempoolCmd blk -> Maybe (TxId (GenTx blk)))
-> [MempoolCmd blk] -> [TxId (GenTx blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MempoolCmd blk -> Maybe (TxId (GenTx blk))
forall blk.
HasTxId (GenTx blk) =>
MempoolCmd blk -> Maybe (TxId (GenTx blk))
getCmdTxId

{-------------------------------------------------------------------------------
  Commands execution
-------------------------------------------------------------------------------}

-- TODO: the interpretation of running the command should be defined elsewhere,
-- and tested by state-mathine tests.
run ::
     Monad m
  => MockedMempool m blk -> [MempoolCmd blk] -> m ()
run :: forall (m :: * -> *) blk.
Monad m =>
MockedMempool m blk -> [MempoolCmd blk] -> m ()
run MockedMempool m blk
mempool = (MempoolCmd blk -> m ()) -> [MempoolCmd blk] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (MockedMempool m blk -> MempoolCmd blk -> m ()
forall (m :: * -> *) blk.
Monad m =>
MockedMempool m blk -> MempoolCmd blk -> m ()
runCmd MockedMempool m blk
mempool)

runCmd ::
     Monad m
  => MockedMempool m blk -> MempoolCmd blk -> m ()
runCmd :: forall (m :: * -> *) blk.
Monad m =>
MockedMempool m blk -> MempoolCmd blk -> m ()
runCmd MockedMempool m blk
mempool = \case
    AddTx GenTx blk
tx -> m (MempoolAddTxResult blk) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (MempoolAddTxResult blk) -> m ())
-> m (MempoolAddTxResult blk) -> m ()
forall a b. (a -> b) -> a -> b
$ MockedMempool m blk
-> AddTxOnBehalfOf -> GenTx blk -> m (MempoolAddTxResult blk)
forall (m :: * -> *) blk.
MockedMempool m blk
-> AddTxOnBehalfOf -> GenTx blk -> m (MempoolAddTxResult blk)
Mocked.addTx MockedMempool m blk
mempool AddTxOnBehalfOf
AddTxForRemotePeer GenTx blk
tx -- TODO: we might want to benchmark the 'Intervene' case