{-# LANGUAGE FlexibleContexts #-}

-- | Queries to the mempool
module Ouroboros.Consensus.Mempool.Query (implGetSnapshotFor) where

import           Ouroboros.Consensus.Block.Abstract
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool.API
import           Ouroboros.Consensus.Mempool.Impl.Common
import qualified Ouroboros.Consensus.Mempool.TxSeq as TxSeq
import           Ouroboros.Consensus.Util.IOLike

implGetSnapshotFor ::
     ( IOLike m
     , LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     )
  => MempoolEnv m blk
  -> SlotNo -- ^ Get snapshot for this slot number (usually the current slot)
  -> TickedLedgerState blk DiffMK -- ^ The ledger state at which we want the
                                  -- snapshot, ticked to @slot@.
  -> (LedgerTables (LedgerState blk) KeysMK -> m (LedgerTables (LedgerState blk) ValuesMK))
      -- ^ A function that returns values corresponding to the given keys for
      -- the unticked ledger state.
  -> m (MempoolSnapshot blk)
implGetSnapshotFor :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
MempoolEnv m blk
-> SlotNo
-> TickedLedgerState blk DiffMK
-> (LedgerTables (LedgerState blk) KeysMK
    -> m (LedgerTables (LedgerState blk) ValuesMK))
-> m (MempoolSnapshot blk)
implGetSnapshotFor MempoolEnv m blk
mpEnv SlotNo
slot TickedLedgerState blk DiffMK
ticked LedgerTables (LedgerState blk) KeysMK
-> m (LedgerTables (LedgerState blk) ValuesMK)
readUntickedTables = do
  is <- STM m (InternalState blk) -> m (InternalState blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (InternalState blk) -> m (InternalState blk))
-> STM m (InternalState blk) -> m (InternalState blk)
forall a b. (a -> b) -> a -> b
$ StrictTMVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
readTMVar StrictTMVar m (InternalState blk)
istate
  if pointHash (isTip is) == castHash (getTipHash ticked) &&
     isSlotNo is == slot
    then
      -- We are looking for a snapshot exactly for the ledger state we already
      -- have cached, then just return it.
      pure . snapshotFromIS $ is
    else do
      values <-
        if pointHash (isTip is) == castHash (getTipHash ticked)
           -- We are looking for a snapshot at the same state ticked
           -- to a different slot, so we can reuse the cached values
        then pure (isTxValues is)
           -- We are looking for a snapshot at a different state, so we
           -- need to read the values from the ledgerdb.
        else readUntickedTables (isTxKeys is)
      pure
        $ computeSnapshot
            capacityOverride
            cfg
            slot
            ticked
            values
            (isLastTicketNo is)
            (TxSeq.toList $ isTxs is)
 where
    MempoolEnv { mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTMVar m (InternalState blk)
mpEnvStateVar         = StrictTMVar m (InternalState blk)
istate
               , mpEnvLedgerCfg :: forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerConfig blk
mpEnvLedgerCfg        = LedgerConfig blk
cfg
               , mpEnvCapacityOverride :: forall (m :: * -> *) blk.
MempoolEnv m blk -> MempoolCapacityBytesOverride
mpEnvCapacityOverride = MempoolCapacityBytesOverride
capacityOverride
               } = MempoolEnv m blk
mpEnv