{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Interface to the Shelley ledger for the purposes of managing a Shelley
-- mempool.
module Shelley.Spec.Ledger.API.Mempool
  ( ApplyTx (..),
    ApplyTxError (..),
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Ledger.Core (AnnotatedData, ChainData, SerialisableData)
import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra)
import Control.Arrow (left)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
  ( PredicateFailure,
    STS,
    TRC (..),
    applySTS,
  )
import Data.Sequence (Seq)
import Data.Typeable (Typeable)
import Shelley.Spec.Ledger.API.Protocol (PraosCrypto)
import Shelley.Spec.Ledger.BaseTypes (Globals)
import Shelley.Spec.Ledger.LedgerState (NewEpochState)
import qualified Shelley.Spec.Ledger.LedgerState as LedgerState
import Shelley.Spec.Ledger.STS.Ledgers (LEDGERS)
import qualified Shelley.Spec.Ledger.STS.Ledgers as Ledgers
import Shelley.Spec.Ledger.Slot (SlotNo)
import Shelley.Spec.Ledger.Tx (Tx)

-- TODO #1304: add reapplyTxs
class
  ( ChainData (Tx era),
    AnnotatedData (Tx era),
    Eq (ApplyTxError era),
    Show (ApplyTxError era),
    Typeable (ApplyTxError era),
    SerialisableData (ApplyTxError era)
  ) =>
  ApplyTx era
  where
  applyTxs ::
    MonadError (ApplyTxError era) m =>
    Globals ->
    SlotNo ->
    Seq (Tx era) ->
    NewEpochState era ->
    m (NewEpochState era)
  default applyTxs ::
    (MonadError (ApplyTxError era) m, STS (LEDGERS era)) =>
    Globals ->
    SlotNo ->
    Seq (Tx era) ->
    NewEpochState era ->
    m (NewEpochState era)
  applyTxs Globals
globals SlotNo
slot Seq (Tx era)
txs NewEpochState era
state =
    (MempoolState era -> m (MempoolState era))
-> NewEpochState era -> m (NewEpochState era)
forall (f :: * -> *) era.
Applicative f =>
(MempoolState era -> f (MempoolState era))
-> NewEpochState era -> f (NewEpochState era)
overNewEpochState (Globals
-> MempoolEnv era
-> Seq (Tx era)
-> MempoolState era
-> m (MempoolState era)
forall era (m :: * -> *).
(STS (LEDGERS era), MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> Seq (Tx era)
-> MempoolState era
-> m (MempoolState era)
applyTxsTransition Globals
globals MempoolEnv era
mempoolEnv Seq (Tx era)
txs) NewEpochState era
state
    where
      mempoolEnv :: MempoolEnv era
mempoolEnv = NewEpochState era -> SlotNo -> MempoolEnv era
forall era. NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv NewEpochState era
state SlotNo
slot

instance PraosCrypto c => ApplyTx (ShelleyEra c)

type MempoolEnv era = Ledgers.LedgersEnv era

type MempoolState = LedgerState.LedgerState

-- | Construct the environment used to validate transactions from the full
-- ledger state.
--
-- Note that this function also takes a slot. During slot validation, the slot
-- given here is the slot of the block containing the transactions. This slot is
-- used for quite a number of things, but in general these do not determine the
-- validity of the transaction. There are two exceptions:
--
-- - Each transaction has a ttl (time-to-live) value. If the slot is beyond this
--   value, then the transaction is invalid.
-- - If the transaction contains a protocol update proposal, then it may only be
--   included until a certain number of slots before the end of the epoch. A
--   protocol update proposal submitted after this is considered invalid.
mkMempoolEnv ::
  NewEpochState era ->
  SlotNo ->
  MempoolEnv era
mkMempoolEnv :: NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv
  LedgerState.NewEpochState
    { EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
nesEs :: EpochState era
LedgerState.nesEs
    }
  SlotNo
slot =
    LedgersEnv :: forall era. SlotNo -> PParams era -> AccountState -> LedgersEnv era
Ledgers.LedgersEnv
      { ledgersSlotNo :: SlotNo
Ledgers.ledgersSlotNo = SlotNo
slot,
        ledgersPp :: PParams era
Ledgers.ledgersPp = EpochState era -> PParams era
forall era. EpochState era -> PParams era
LedgerState.esPp EpochState era
nesEs,
        ledgersAccount :: AccountState
Ledgers.ledgersAccount = EpochState era -> AccountState
forall era. EpochState era -> AccountState
LedgerState.esAccountState EpochState era
nesEs
      }

-- | Construct a mempool state from the wider ledger state.
--
--   The given mempool state may then be evolved using 'applyTxs', but should be
--   regenerated when the ledger state gets updated (e.g. through application of
--   a new block).
mkMempoolState :: NewEpochState era -> MempoolState era
mkMempoolState :: NewEpochState era -> MempoolState era
mkMempoolState LedgerState.NewEpochState {EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
LedgerState.nesEs} =
  EpochState era -> MempoolState era
forall era. EpochState era -> LedgerState era
LedgerState.esLState EpochState era
nesEs

data ApplyTxError era = ApplyTxError [PredicateFailure (LEDGERS era)]

deriving stock instance
  (Eq (PredicateFailure (LEDGERS era))) =>
  Eq (ApplyTxError era)

deriving stock instance
  (Show (PredicateFailure (LEDGERS era))) =>
  Show (ApplyTxError era)

instance
  ( ShelleyBased era,
    ToCBOR (PredicateFailure (LEDGERS era))
  ) =>
  ToCBOR (ApplyTxError era)
  where
  toCBOR :: ApplyTxError era -> Encoding
toCBOR (ApplyTxError [PredicateFailure (LEDGERS era)]
es) = [LedgersPredicateFailure era] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR [PredicateFailure (LEDGERS era)]
[LedgersPredicateFailure era]
es

instance
  ( ShelleyBased era,
    FromCBOR (PredicateFailure (LEDGERS era))
  ) =>
  FromCBOR (ApplyTxError era)
  where
  fromCBOR :: Decoder s (ApplyTxError era)
fromCBOR = [LedgersPredicateFailure era] -> ApplyTxError era
forall era. [PredicateFailure (LEDGERS era)] -> ApplyTxError era
ApplyTxError ([LedgersPredicateFailure era] -> ApplyTxError era)
-> Decoder s [LedgersPredicateFailure era]
-> Decoder s (ApplyTxError era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [LedgersPredicateFailure era]
forall a s. FromCBOR a => Decoder s a
fromCBOR

applyTxsTransition ::
  forall era m.
  ( STS (LEDGERS era),
    MonadError (ApplyTxError era) m
  ) =>
  Globals ->
  MempoolEnv era ->
  Seq (Tx era) ->
  MempoolState era ->
  m (MempoolState era)
applyTxsTransition :: Globals
-> MempoolEnv era
-> Seq (Tx era)
-> MempoolState era
-> m (MempoolState era)
applyTxsTransition Globals
globals MempoolEnv era
env Seq (Tx era)
txs MempoolState era
state =
  let res :: Either [[LedgersPredicateFailure era]] (MempoolState era)
res =
        (Reader
   Globals (Either [[LedgersPredicateFailure era]] (MempoolState era))
 -> Globals
 -> Either [[LedgersPredicateFailure era]] (MempoolState era))
-> Globals
-> Reader
     Globals (Either [[LedgersPredicateFailure era]] (MempoolState era))
-> Either [[LedgersPredicateFailure era]] (MempoolState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals (Either [[LedgersPredicateFailure era]] (MempoolState era))
-> Globals
-> Either [[LedgersPredicateFailure era]] (MempoolState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals (Either [[LedgersPredicateFailure era]] (MempoolState era))
 -> Either [[LedgersPredicateFailure era]] (MempoolState era))
-> (TRC (LEDGERS era)
    -> Reader
         Globals
         (Either [[LedgersPredicateFailure era]] (MempoolState era)))
-> TRC (LEDGERS era)
-> Either [[LedgersPredicateFailure era]] (MempoolState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s -> m (Either [[PredicateFailure s]] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS (LEDGERS era), RuleTypeRep rtype, m ~ BaseM (LEDGERS era)) =>
RuleContext rtype (LEDGERS era)
-> m (Either
        [[PredicateFailure (LEDGERS era)]] (State (LEDGERS era)))
applySTS @(LEDGERS era)
          (TRC (LEDGERS era)
 -> Either [[LedgersPredicateFailure era]] (MempoolState era))
-> TRC (LEDGERS era)
-> Either [[LedgersPredicateFailure era]] (MempoolState era)
forall a b. (a -> b) -> a -> b
$ (Environment (LEDGERS era), State (LEDGERS era),
 Signal (LEDGERS era))
-> TRC (LEDGERS era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (LEDGERS era)
MempoolEnv era
env, State (LEDGERS era)
MempoolState era
state, Seq (Tx era)
Signal (LEDGERS era)
txs)
   in Either (ApplyTxError era) (MempoolState era)
-> m (MempoolState era)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
        (Either (ApplyTxError era) (MempoolState era)
 -> m (MempoolState era))
-> (Either [[LedgersPredicateFailure era]] (MempoolState era)
    -> Either (ApplyTxError era) (MempoolState era))
-> Either [[LedgersPredicateFailure era]] (MempoolState era)
-> m (MempoolState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[LedgersPredicateFailure era]] -> ApplyTxError era)
-> Either [[LedgersPredicateFailure era]] (MempoolState era)
-> Either (ApplyTxError era) (MempoolState era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ([LedgersPredicateFailure era] -> ApplyTxError era
forall era. [PredicateFailure (LEDGERS era)] -> ApplyTxError era
ApplyTxError ([LedgersPredicateFailure era] -> ApplyTxError era)
-> ([[LedgersPredicateFailure era]]
    -> [LedgersPredicateFailure era])
-> [[LedgersPredicateFailure era]]
-> ApplyTxError era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[LedgersPredicateFailure era]] -> [LedgersPredicateFailure era]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join)
        (Either [[LedgersPredicateFailure era]] (MempoolState era)
 -> m (MempoolState era))
-> Either [[LedgersPredicateFailure era]] (MempoolState era)
-> m (MempoolState era)
forall a b. (a -> b) -> a -> b
$ Either [[LedgersPredicateFailure era]] (MempoolState era)
res

-- | Transform a function over mempool states to one over the full
-- 'NewEpochState'.
overNewEpochState ::
  Applicative f =>
  (MempoolState era -> f (MempoolState era)) ->
  NewEpochState era ->
  f (NewEpochState era)
overNewEpochState :: (MempoolState era -> f (MempoolState era))
-> NewEpochState era -> f (NewEpochState era)
overNewEpochState MempoolState era -> f (MempoolState era)
f NewEpochState era
st = do
  MempoolState era
res <- MempoolState era -> f (MempoolState era)
f (MempoolState era -> f (MempoolState era))
-> MempoolState era -> f (MempoolState era)
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> MempoolState era
forall era. NewEpochState era -> MempoolState era
mkMempoolState NewEpochState era
st
  pure $
    NewEpochState era
st
      { nesEs :: EpochState era
LedgerState.nesEs =
          (NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
st) {esLState :: MempoolState era
LedgerState.esLState = MempoolState era
res}
      }