{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Ouroboros.Consensus.Ledger.SupportsMempool
  ( ApplyTxErr
  , ByteSize32 (..)
  , ComputeDiffs (..)
  , ConvertRawTxId (..)
  , GenTx
  , GenTxId
  , HasByteSize (..)
  , HasTxId (..)
  , HasTxs (..)
  , IgnoringOverflow (..)
  , Invalidated (..)
  , LedgerSupportsMempool (..)
  , ReapplyTxsResult (..)
  , TxId
  , TxLimits (..)
  , TxMeasureMetrics (..)
  , Validated
  , WhetherToIntervene (..)
  ) where

import Codec.Serialise (Serialise)
import Control.DeepSeq (NFData)
import Control.Monad.Except
import Data.ByteString.Short (ShortByteString)
import Data.Coerce (coerce)
import Data.DerivingVia (InstantiatedAt (..))
import qualified Data.Foldable as Foldable
import Data.Kind (Type)
import Data.Measure (Measure)
import qualified Data.Measure
import Data.Word (Word32)
import GHC.Stack (HasCallStack)
import NoThunks.Class
import Numeric.Natural
import Ouroboros.Consensus.Block.Abstract
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Tables.Utils

-- | Generalized transaction
--
-- The mempool (and, accordingly, blocks) consist of "generalized
-- transactions"; this could be "proper" transactions (transferring funds) but
-- also other kinds of things such as update proposals, delegations, etc.
type GenTx :: Type -> Type
data family GenTx blk

-- | Updating the ledger with a single transaction may result in a different
-- error type as when updating it with a block
type ApplyTxErr :: Type -> Type
type family ApplyTxErr blk

-- | A flag indicating whether the mempool should reject a valid-but-problematic
-- transaction, in order to to protect its author from penalties etc
--
-- The primary example is that, as of the Alonzo ledger, a valid transaction can
-- carry an invalid script. If a remote peer sends us such a transaction (over a
-- Node-to-Node protocol), we include it in a block so that the ledger will
-- penalize them them for the invalid script: they wasted our resources by
-- forcing us to run the script to determine it's invalid. But if our local
-- wallet -- which we trust by assumption -- sends us such a transaction (over a
-- Node-to-Client protocol), we would be a good neighbor by rejecting that
-- transaction: they must have made some sort of mistake, and we don't want the
-- ledger to penalize them.
data WhetherToIntervene
  = -- | We do not trust remote peers, so if a problematic-yet-valid transaction
    -- arrives over NTN, we accept it; it will end up in a block and the ledger
    -- will penalize them for it.
    DoNotIntervene
  | -- | We trust local clients, so if a problematic-yet-valid transaction
    -- arrives over NTC, we reject it in order to avoid the ledger penalizing
    -- them for it.
    Intervene
  deriving Int -> WhetherToIntervene -> ShowS
[WhetherToIntervene] -> ShowS
WhetherToIntervene -> String
(Int -> WhetherToIntervene -> ShowS)
-> (WhetherToIntervene -> String)
-> ([WhetherToIntervene] -> ShowS)
-> Show WhetherToIntervene
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WhetherToIntervene -> ShowS
showsPrec :: Int -> WhetherToIntervene -> ShowS
$cshow :: WhetherToIntervene -> String
show :: WhetherToIntervene -> String
$cshowList :: [WhetherToIntervene] -> ShowS
showList :: [WhetherToIntervene] -> ShowS
Show

-- | Whether to keep track of the diffs produced by applying the transactions.
--
-- When getting a mempool snapshot, we will revalidate all the
-- transactions but we won't do anything useful with the resulting
-- state. We can safely omit computing the differences in this case.
--
-- This optimization is worthwile as snapshotting is in the critical
-- path of block minting, and we don't make use of the resulting
-- state, only of the transactions that remain valid.
--
-- Eventually, the Ledger rules will construct the differences for us,
-- so this optimization will no longer be needed. That's why we chose
-- to go with a boolean isomorph instead of something fancier.
data ComputeDiffs
  = -- | This option should be used when syncing the mempool with the
    -- LedgerDB, to store a useful state in the mempool.
    ComputeDiffs
  | -- | This option should be used only when snapshotting the mempool,
    -- as we discard the resulting state anyways.
    IgnoreDiffs
  deriving Int -> ComputeDiffs -> ShowS
[ComputeDiffs] -> ShowS
ComputeDiffs -> String
(Int -> ComputeDiffs -> ShowS)
-> (ComputeDiffs -> String)
-> ([ComputeDiffs] -> ShowS)
-> Show ComputeDiffs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ComputeDiffs -> ShowS
showsPrec :: Int -> ComputeDiffs -> ShowS
$cshow :: ComputeDiffs -> String
show :: ComputeDiffs -> String
$cshowList :: [ComputeDiffs] -> ShowS
showList :: [ComputeDiffs] -> ShowS
Show

class
  ( UpdateLedger blk
  , TxLimits blk
  , NoThunks (GenTx blk)
  , NoThunks (Validated (GenTx blk))
  , Show (GenTx blk)
  , Show (Validated (GenTx blk))
  , Show (ApplyTxErr blk)
  ) =>
  LedgerSupportsMempool blk
  where
  -- | Check whether the internal invariants of the transaction hold.
  txInvariant :: GenTx blk -> Bool
  txInvariant = Bool -> GenTx blk -> Bool
forall a b. a -> b -> a
const Bool
True

  -- | Apply an unvalidated transaction
  --
  -- The mempool expects that the ledger checks the sanity of the transaction'
  -- size. The mempool implementation will add any valid transaction as long as
  -- there is at least one byte free in the mempool.
  --
  -- The resulting ledger state contains the diffs produced by applying this
  -- transaction alone.
  applyTx ::
    LedgerConfig blk ->
    WhetherToIntervene ->
    -- | Slot number of the block containing the tx
    SlotNo ->
    GenTx blk ->
    -- | Contain only the values for the tx to apply
    TickedLedgerState blk ValuesMK ->
    Except (ApplyTxErr blk) (TickedLedgerState blk DiffMK, Validated (GenTx blk))

  -- | Apply a previously validated transaction to a potentially different
  -- ledger state
  --
  -- When we re-apply a transaction to a potentially different ledger state
  -- expensive checks such as cryptographic hashes can be skipped, but other
  -- checks (such as checking for double spending) must still be done.
  --
  -- The returned ledger state contains the resulting values too so that this
  -- function can be used to reapply a list of transactions, providing as a
  -- first state one that contains the values for all the transactions.
  reapplyTx ::
    HasCallStack =>
    ComputeDiffs ->
    LedgerConfig blk ->
    -- | Slot number of the block containing the tx
    SlotNo ->
    Validated (GenTx blk) ->
    -- | Contains at least the values for the tx to reapply
    TickedLedgerState blk ValuesMK ->
    Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)

  -- | Apply a list of previously validated transactions to a new ledger state.
  --
  -- It is never the case that we reapply one single transaction, we always
  -- reapply a list of transactions (and even one transaction can just be lifted
  -- into the unary list).
  --
  -- When reapplying a list of transactions, in the hard-fork instance we want
  -- to first project everything into the particular block instance and then we
  -- can inject/project the ledger tables only once. For single era blocks, this
  -- is by default implemented as a fold using 'reapplyTx'.
  --
  -- Notice: It is crucial that the list of validated transactions returned is
  -- in the same order as they were given, as we will use those later on to
  -- filter a list of 'TxTicket's.
  reapplyTxs ::
    ComputeDiffs ->
    LedgerConfig blk ->
    -- | Slot number of the block containing the tx
    SlotNo ->
    [(Validated (GenTx blk), extra)] ->
    TickedLedgerState blk ValuesMK ->
    ReapplyTxsResult extra blk
  reapplyTxs ComputeDiffs
doDiffs LedgerConfig blk
cfg SlotNo
slot [(Validated (GenTx blk), extra)]
txs TickedLedgerState blk ValuesMK
st =
    ( \([Invalidated blk]
err, [(Validated (GenTx blk), extra)]
val, TickedLedgerState blk TrackingMK
st') ->
        [Invalidated blk]
-> [(Validated (GenTx blk), extra)]
-> TickedLedgerState blk TrackingMK
-> ReapplyTxsResult extra blk
forall extra blk.
[Invalidated blk]
-> [(Validated (GenTx blk), extra)]
-> TickedLedgerState blk TrackingMK
-> ReapplyTxsResult extra blk
ReapplyTxsResult
          [Invalidated blk]
err
          ([(Validated (GenTx blk), extra)]
-> [(Validated (GenTx blk), extra)]
forall a. [a] -> [a]
reverse [(Validated (GenTx blk), extra)]
val)
          TickedLedgerState blk TrackingMK
st'
    )
      (([Invalidated blk], [(Validated (GenTx blk), extra)],
  TickedLedgerState blk TrackingMK)
 -> ReapplyTxsResult extra blk)
-> ([Invalidated blk], [(Validated (GenTx blk), extra)],
    TickedLedgerState blk TrackingMK)
-> ReapplyTxsResult extra blk
forall a b. (a -> b) -> a -> b
$ (([Invalidated blk], [(Validated (GenTx blk), extra)],
  TickedLedgerState blk TrackingMK)
 -> (Validated (GenTx blk), extra)
 -> ([Invalidated blk], [(Validated (GenTx blk), extra)],
     TickedLedgerState blk TrackingMK))
-> ([Invalidated blk], [(Validated (GenTx blk), extra)],
    TickedLedgerState blk TrackingMK)
-> [(Validated (GenTx blk), extra)]
-> ([Invalidated blk], [(Validated (GenTx blk), extra)],
    TickedLedgerState blk TrackingMK)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
        ( \([Invalidated blk]
accE, [(Validated (GenTx blk), extra)]
accV, TickedLedgerState blk TrackingMK
st') (Validated (GenTx blk)
tx, extra
extra) ->
            case Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)
-> Either (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)
forall e a. Except e a -> Either e a
runExcept (ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> TickedLedgerState blk ValuesMK
-> Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)
forall blk.
(LedgerSupportsMempool blk, HasCallStack) =>
ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> TickedLedgerState blk ValuesMK
-> Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)
reapplyTx ComputeDiffs
doDiffs LedgerConfig blk
cfg SlotNo
slot Validated (GenTx blk)
tx (TickedLedgerState blk ValuesMK
 -> Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK))
-> TickedLedgerState blk ValuesMK
-> Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)
forall a b. (a -> b) -> a -> b
$ TickedLedgerState blk TrackingMK -> TickedLedgerState blk ValuesMK
forall (l :: MapKind -> *).
(LedgerTableConstraints l, HasLedgerTables l) =>
l TrackingMK -> l ValuesMK
trackingToValues TickedLedgerState blk TrackingMK
st') of
              Left ApplyTxErr blk
err -> (Validated (GenTx blk) -> ApplyTxErr blk -> Invalidated blk
forall blk.
Validated (GenTx blk) -> ApplyTxErr blk -> Invalidated blk
Invalidated Validated (GenTx blk)
tx ApplyTxErr blk
err Invalidated blk -> [Invalidated blk] -> [Invalidated blk]
forall a. a -> [a] -> [a]
: [Invalidated blk]
accE, [(Validated (GenTx blk), extra)]
accV, TickedLedgerState blk TrackingMK
st')
              Right TickedLedgerState blk TrackingMK
st'' ->
                ( [Invalidated blk]
accE
                , (Validated (GenTx blk)
tx, extra
extra) (Validated (GenTx blk), extra)
-> [(Validated (GenTx blk), extra)]
-> [(Validated (GenTx blk), extra)]
forall a. a -> [a] -> [a]
: [(Validated (GenTx blk), extra)]
accV
                , case ComputeDiffs
doDiffs of
                    ComputeDiffs
ComputeDiffs -> TickedLedgerState blk TrackingMK
-> TickedLedgerState blk TrackingMK
-> TickedLedgerState blk TrackingMK
forall (l :: MapKind -> *) (l' :: MapKind -> *).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l TrackingMK -> l' TrackingMK -> l' TrackingMK
prependTrackingDiffs TickedLedgerState blk TrackingMK
st' TickedLedgerState blk TrackingMK
st''
                    ComputeDiffs
IgnoreDiffs -> TickedLedgerState blk TrackingMK
st''
                )
        )
        ([], [], TickedLedgerState blk ValuesMK -> TickedLedgerState blk TrackingMK
forall (l :: MapKind -> *).
HasLedgerTables l =>
l ValuesMK -> l TrackingMK
attachEmptyDiffs TickedLedgerState blk ValuesMK
st)
        [(Validated (GenTx blk), extra)]
txs

  -- | Discard the evidence that transaction has been previously validated
  txForgetValidated :: Validated (GenTx blk) -> GenTx blk

  -- | Given a transaction, get the key-sets that we need to apply it to a
  -- ledger state. This is implemented in the Ledger. An example of non-obvious
  -- needed keys in Cardano are those of reference scripts for computing the
  -- transaction size.
  getTransactionKeySets :: GenTx blk -> LedgerTables (LedgerState blk) KeysMK

  -- Mempools live in a single slot so in the hard fork block case
  -- it is cheaper to perform these operations on LedgerStates, saving
  -- the time of projecting and injecting ledger tables.
  --
  -- The cost of this when adding transactions is very small compared
  -- to eg the networking costs of mempool synchronization, but still
  -- it is worthwile locking the mempool for as short as possible.
  --
  -- Eventually the Ledger will provide these diffs, so we might even
  -- be able to remove this optimization altogether.

  -- | Prepend diffs on ledger states
  prependMempoolDiffs ::
    TickedLedgerState blk DiffMK ->
    TickedLedgerState blk DiffMK ->
    TickedLedgerState blk DiffMK
  prependMempoolDiffs = TickedLedgerState blk DiffMK
-> TickedLedgerState blk DiffMK -> TickedLedgerState blk DiffMK
forall (l :: MapKind -> *) (l' :: MapKind -> *).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l DiffMK -> l' DiffMK -> l' DiffMK
prependDiffs

  -- | Apply diffs on ledger states
  applyMempoolDiffs ::
    LedgerTables (LedgerState blk) ValuesMK ->
    LedgerTables (LedgerState blk) KeysMK ->
    TickedLedgerState blk DiffMK ->
    TickedLedgerState blk ValuesMK
  applyMempoolDiffs = LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) KeysMK
-> TickedLedgerState blk DiffMK
-> TickedLedgerState blk ValuesMK
forall (l :: MapKind -> *) (l' :: MapKind -> *).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
LedgerTables l ValuesMK
-> LedgerTables l KeysMK -> l' DiffMK -> l' ValuesMK
applyDiffForKeysOnTables

data ReapplyTxsResult extra blk
  = ReapplyTxsResult
  { forall extra blk. ReapplyTxsResult extra blk -> [Invalidated blk]
invalidatedTxs :: ![Invalidated blk]
  -- ^ txs that are now invalid. Order doesn't matter
  , forall extra blk.
ReapplyTxsResult extra blk -> [(Validated (GenTx blk), extra)]
validatedTxs :: ![(Validated (GenTx blk), extra)]
  -- ^ txs that are valid again, order must be the same as the order in
  -- which txs were received
  , forall extra blk.
ReapplyTxsResult extra blk -> TickedLedgerState blk TrackingMK
resultingState :: !(TickedLedgerState blk TrackingMK)
  -- ^ Resulting ledger state
  }

-- | A generalized transaction, 'GenTx', identifier.
type TxId :: Type -> Type
data family TxId blk

-- | Transactions with an identifier
--
-- The mempool will use these to locate transactions, so two different
-- transactions should have different identifiers.
class
  ( Show (TxId tx)
  , Ord (TxId tx)
  , NoThunks (TxId tx)
  ) =>
  HasTxId tx
  where
  -- | Return the 'TxId' of a 'GenTx'.
  --
  -- NOTE: a 'TxId' must be unique up to ledger rules, i.e., two 'GenTx's with
  -- the same 'TxId' must be the same transaction /according to the ledger/.
  -- However, we do not assume that a 'TxId' uniquely determines a 'GenTx':
  -- two 'GenTx's with the same 'TxId' can differ in, e.g., witnesses.
  --
  -- Should be cheap as this will be called often.
  txId :: tx -> TxId tx

-- | Extract the raw hash bytes from a 'TxId'.
class HasTxId tx => ConvertRawTxId tx where
  -- | NOTE: The composition @'toRawTxIdHash' . 'txId'@ must satisfy the same
  -- properties as defined in the docs of 'txId'.
  toRawTxIdHash :: TxId tx -> ShortByteString

-- | Shorthand: ID of a generalized transaction
type GenTxId blk = TxId (GenTx blk)

-- | Collect all transactions from a block
--
-- This is used for tooling only. We don't require it as part of RunNode
-- (and cannot, because we cannot give an instance for the dual ledger).
class HasTxs blk where
  -- | Return the transactions part of the given block in no particular order.
  extractTxs :: blk -> [GenTx blk]

{-------------------------------------------------------------------------------
  Tx sizes
-------------------------------------------------------------------------------}

-- | Each block has its limits of how many transactions it can hold. That limit
-- is compared against the sum of measurements taken of each of the
-- transactions in that block.
--
-- How we measure the transaction depends of the era that this transaction
-- belongs to (more specifically it depends on the block type to which this
-- transaction will be added). For initial eras (like Byron and initial
-- generations of Shelley based eras) this measure was simply a byte size
-- (block could not be bigger then given size - in bytes - specified by the
-- ledger state). In subsequent eras (starting with Alonzo) this measure was a
-- bit more complex as it had to take other factors into account (like
-- execution units). For details please see the individual instances for the
-- TxLimits.
class
  ( Measure (TxMeasure blk)
  , HasByteSize (TxMeasure blk)
  , NoThunks (TxMeasure blk)
  , TxMeasureMetrics (TxMeasure blk)
  , Show (TxMeasure blk)
  ) =>
  TxLimits blk
  where
  -- | The (possibly multi-dimensional) size of a transaction in a block.
  type TxMeasure blk

  -- | The various sizes (bytes, Plutus script ExUnits, etc) of a tx /when it's
  -- in a block/
  --
  -- This size is used to compute how many transaction we can put in a block
  -- when forging one.
  --
  -- The byte size component in particular might differ from the size of the
  -- serialisation used to send and receive the transaction across the network.
  -- For example, CBOR-in-CBOR could be used when sending the transaction
  -- across the network, requiring a few extra bytes compared to the actual
  -- in-block serialisation. Another example is the transaction of the
  -- hard-fork combinator which will include an envelope indicating its era
  -- when sent across the network. However, when embedded in the respective
  -- era's block, there is no need for such envelope. An example from upstream
  -- is that the Cardano ledger's "Segregated Witness" encoding scheme
  -- contributes to the encoding overhead.
  --
  -- INVARIANT Assuming no hash collisions, the size should be the same in any
  -- state in which the transaction is valid. For example, it's acceptable to
  -- simply omit the size of ref scripts that could not be found, since their
  -- absence implies the tx is invalid. In fact, that invalidity could be
  -- reported by this function, but it need not be.
  --
  -- INVARIANT @Right x = txMeasure cfg st tx@ implies @x 'Measure.<='
  -- 'blockCapacityTxMeasure cfg st'. Otherwise, the mempool could block
  -- forever.
  --
  -- Returns an exception if and only if the transaction violates the per-tx
  -- limits.
  txMeasure ::
    -- | used at least by HFC's composition logic
    LedgerConfig blk ->
    -- | This state needs values as a transaction measure might depend on
    -- those. For example in Cardano they look at the reference scripts.
    TickedLedgerState blk ValuesMK ->
    GenTx blk ->
    Except (ApplyTxErr blk) (TxMeasure blk)

  -- | What is the allowed capacity for the txs in an individual block?
  blockCapacityTxMeasure ::
    -- | at least for symmetry with 'txMeasure'
    LedgerConfig blk ->
    TickedLedgerState blk mk ->
    TxMeasure blk

-- | We intentionally do not declare a 'Num' instance! We prefer @ByteSize32@
-- to occur explicitly in the code where possible, for
-- legibility/perspicuousness. We also do not need nor want subtraction.
--
-- This data type measures the size of a transaction, the sum of the sizes of
-- txs in a block, the sum of the sizes of the txs in the mempool, etc. None of
-- those will ever need to represent gigabytes, so 32 bits suffice. But 16 bits
-- would not.
--
-- This is modular arithmetic, so uses need to be concerned with overflow. For
-- example, see the related guard in
-- 'Ouroboros.Consensus.Mempool.Update.pureTryAddTx'. One important element is
-- anticipating the possibility of very large summands injected by the
-- adversary.
--
-- There is a temptation to use 'Natural' here, since it can never overflow.
-- However, some points in the interface do not easily handle 'Natural's, such
-- as encoders. Thus 'Natural' would merely defer the overflow concern, and
-- even risks instilling a false sense that overflow need not be considered at
-- all.
newtype ByteSize32 = ByteSize32 {ByteSize32 -> Word32
unByteSize32 :: Word32}
  deriving stock Int -> ByteSize32 -> ShowS
[ByteSize32] -> ShowS
ByteSize32 -> String
(Int -> ByteSize32 -> ShowS)
-> (ByteSize32 -> String)
-> ([ByteSize32] -> ShowS)
-> Show ByteSize32
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ByteSize32 -> ShowS
showsPrec :: Int -> ByteSize32 -> ShowS
$cshow :: ByteSize32 -> String
show :: ByteSize32 -> String
$cshowList :: [ByteSize32] -> ShowS
showList :: [ByteSize32] -> ShowS
Show
  deriving newtype (ByteSize32 -> ByteSize32 -> Bool
(ByteSize32 -> ByteSize32 -> Bool)
-> (ByteSize32 -> ByteSize32 -> Bool) -> Eq ByteSize32
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ByteSize32 -> ByteSize32 -> Bool
== :: ByteSize32 -> ByteSize32 -> Bool
$c/= :: ByteSize32 -> ByteSize32 -> Bool
/= :: ByteSize32 -> ByteSize32 -> Bool
Eq, Eq ByteSize32
Eq ByteSize32 =>
(ByteSize32 -> ByteSize32 -> Ordering)
-> (ByteSize32 -> ByteSize32 -> Bool)
-> (ByteSize32 -> ByteSize32 -> Bool)
-> (ByteSize32 -> ByteSize32 -> Bool)
-> (ByteSize32 -> ByteSize32 -> Bool)
-> (ByteSize32 -> ByteSize32 -> ByteSize32)
-> (ByteSize32 -> ByteSize32 -> ByteSize32)
-> Ord ByteSize32
ByteSize32 -> ByteSize32 -> Bool
ByteSize32 -> ByteSize32 -> Ordering
ByteSize32 -> ByteSize32 -> ByteSize32
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ByteSize32 -> ByteSize32 -> Ordering
compare :: ByteSize32 -> ByteSize32 -> Ordering
$c< :: ByteSize32 -> ByteSize32 -> Bool
< :: ByteSize32 -> ByteSize32 -> Bool
$c<= :: ByteSize32 -> ByteSize32 -> Bool
<= :: ByteSize32 -> ByteSize32 -> Bool
$c> :: ByteSize32 -> ByteSize32 -> Bool
> :: ByteSize32 -> ByteSize32 -> Bool
$c>= :: ByteSize32 -> ByteSize32 -> Bool
>= :: ByteSize32 -> ByteSize32 -> Bool
$cmax :: ByteSize32 -> ByteSize32 -> ByteSize32
max :: ByteSize32 -> ByteSize32 -> ByteSize32
$cmin :: ByteSize32 -> ByteSize32 -> ByteSize32
min :: ByteSize32 -> ByteSize32 -> ByteSize32
Ord)
  deriving newtype ByteSize32 -> ()
(ByteSize32 -> ()) -> NFData ByteSize32
forall a. (a -> ()) -> NFData a
$crnf :: ByteSize32 -> ()
rnf :: ByteSize32 -> ()
NFData
  deriving newtype [ByteSize32] -> Encoding
ByteSize32 -> Encoding
(ByteSize32 -> Encoding)
-> (forall s. Decoder s ByteSize32)
-> ([ByteSize32] -> Encoding)
-> (forall s. Decoder s [ByteSize32])
-> Serialise ByteSize32
forall s. Decoder s [ByteSize32]
forall s. Decoder s ByteSize32
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: ByteSize32 -> Encoding
encode :: ByteSize32 -> Encoding
$cdecode :: forall s. Decoder s ByteSize32
decode :: forall s. Decoder s ByteSize32
$cencodeList :: [ByteSize32] -> Encoding
encodeList :: [ByteSize32] -> Encoding
$cdecodeList :: forall s. Decoder s [ByteSize32]
decodeList :: forall s. Decoder s [ByteSize32]
Serialise
  deriving
    (Semigroup ByteSize32
ByteSize32
Semigroup ByteSize32 =>
ByteSize32
-> (ByteSize32 -> ByteSize32 -> ByteSize32)
-> ([ByteSize32] -> ByteSize32)
-> Monoid ByteSize32
[ByteSize32] -> ByteSize32
ByteSize32 -> ByteSize32 -> ByteSize32
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: ByteSize32
mempty :: ByteSize32
$cmappend :: ByteSize32 -> ByteSize32 -> ByteSize32
mappend :: ByteSize32 -> ByteSize32 -> ByteSize32
$cmconcat :: [ByteSize32] -> ByteSize32
mconcat :: [ByteSize32] -> ByteSize32
Monoid, NonEmpty ByteSize32 -> ByteSize32
ByteSize32 -> ByteSize32 -> ByteSize32
(ByteSize32 -> ByteSize32 -> ByteSize32)
-> (NonEmpty ByteSize32 -> ByteSize32)
-> (forall b. Integral b => b -> ByteSize32 -> ByteSize32)
-> Semigroup ByteSize32
forall b. Integral b => b -> ByteSize32 -> ByteSize32
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: ByteSize32 -> ByteSize32 -> ByteSize32
<> :: ByteSize32 -> ByteSize32 -> ByteSize32
$csconcat :: NonEmpty ByteSize32 -> ByteSize32
sconcat :: NonEmpty ByteSize32 -> ByteSize32
$cstimes :: forall b. Integral b => b -> ByteSize32 -> ByteSize32
stimes :: forall b. Integral b => b -> ByteSize32 -> ByteSize32
Semigroup)
    via (InstantiatedAt Measure (IgnoringOverflow ByteSize32))
  deriving
    Context -> ByteSize32 -> IO (Maybe ThunkInfo)
Proxy ByteSize32 -> String
(Context -> ByteSize32 -> IO (Maybe ThunkInfo))
-> (Context -> ByteSize32 -> IO (Maybe ThunkInfo))
-> (Proxy ByteSize32 -> String)
-> NoThunks ByteSize32
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ByteSize32 -> IO (Maybe ThunkInfo)
noThunks :: Context -> ByteSize32 -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ByteSize32 -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ByteSize32 -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ByteSize32 -> String
showTypeOf :: Proxy ByteSize32 -> String
NoThunks
    via OnlyCheckWhnfNamed "ByteSize" ByteSize32

-- | @'IgnoringOverflow' a@ has the same semantics as @a@, except it ignores
-- the fact that @a@ can overflow.
--
-- For example, @'Measure' 'Word32'@ is not lawful, because overflow violates
-- the /lattice-ordered monoid/ law. But @'Measure' (IgnoringOverflow
-- 'Word32')@ is lawful, since it explicitly ignores that case.
--
-- WARNING: anywhere this type occurs is a very strong indicator that overflow
-- will break assumptions, so overflow must therefore be guarded against.
--
-- TODO upstream this to the @measure@ package
newtype IgnoringOverflow a = IgnoringOverflow {forall a. IgnoringOverflow a -> a
unIgnoringOverflow :: a}
  deriving stock Int -> IgnoringOverflow a -> ShowS
[IgnoringOverflow a] -> ShowS
IgnoringOverflow a -> String
(Int -> IgnoringOverflow a -> ShowS)
-> (IgnoringOverflow a -> String)
-> ([IgnoringOverflow a] -> ShowS)
-> Show (IgnoringOverflow a)
forall a. Show a => Int -> IgnoringOverflow a -> ShowS
forall a. Show a => [IgnoringOverflow a] -> ShowS
forall a. Show a => IgnoringOverflow a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> IgnoringOverflow a -> ShowS
showsPrec :: Int -> IgnoringOverflow a -> ShowS
$cshow :: forall a. Show a => IgnoringOverflow a -> String
show :: IgnoringOverflow a -> String
$cshowList :: forall a. Show a => [IgnoringOverflow a] -> ShowS
showList :: [IgnoringOverflow a] -> ShowS
Show
  deriving newtype (IgnoringOverflow a -> IgnoringOverflow a -> Bool
(IgnoringOverflow a -> IgnoringOverflow a -> Bool)
-> (IgnoringOverflow a -> IgnoringOverflow a -> Bool)
-> Eq (IgnoringOverflow a)
forall a. Eq a => IgnoringOverflow a -> IgnoringOverflow a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => IgnoringOverflow a -> IgnoringOverflow a -> Bool
== :: IgnoringOverflow a -> IgnoringOverflow a -> Bool
$c/= :: forall a. Eq a => IgnoringOverflow a -> IgnoringOverflow a -> Bool
/= :: IgnoringOverflow a -> IgnoringOverflow a -> Bool
Eq, Eq (IgnoringOverflow a)
Eq (IgnoringOverflow a) =>
(IgnoringOverflow a -> IgnoringOverflow a -> Ordering)
-> (IgnoringOverflow a -> IgnoringOverflow a -> Bool)
-> (IgnoringOverflow a -> IgnoringOverflow a -> Bool)
-> (IgnoringOverflow a -> IgnoringOverflow a -> Bool)
-> (IgnoringOverflow a -> IgnoringOverflow a -> Bool)
-> (IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a)
-> (IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a)
-> Ord (IgnoringOverflow a)
IgnoringOverflow a -> IgnoringOverflow a -> Bool
IgnoringOverflow a -> IgnoringOverflow a -> Ordering
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (IgnoringOverflow a)
forall a. Ord a => IgnoringOverflow a -> IgnoringOverflow a -> Bool
forall a.
Ord a =>
IgnoringOverflow a -> IgnoringOverflow a -> Ordering
forall a.
Ord a =>
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
$ccompare :: forall a.
Ord a =>
IgnoringOverflow a -> IgnoringOverflow a -> Ordering
compare :: IgnoringOverflow a -> IgnoringOverflow a -> Ordering
$c< :: forall a. Ord a => IgnoringOverflow a -> IgnoringOverflow a -> Bool
< :: IgnoringOverflow a -> IgnoringOverflow a -> Bool
$c<= :: forall a. Ord a => IgnoringOverflow a -> IgnoringOverflow a -> Bool
<= :: IgnoringOverflow a -> IgnoringOverflow a -> Bool
$c> :: forall a. Ord a => IgnoringOverflow a -> IgnoringOverflow a -> Bool
> :: IgnoringOverflow a -> IgnoringOverflow a -> Bool
$c>= :: forall a. Ord a => IgnoringOverflow a -> IgnoringOverflow a -> Bool
>= :: IgnoringOverflow a -> IgnoringOverflow a -> Bool
$cmax :: forall a.
Ord a =>
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
max :: IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
$cmin :: forall a.
Ord a =>
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
min :: IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
Ord)
  deriving newtype IgnoringOverflow a -> ()
(IgnoringOverflow a -> ()) -> NFData (IgnoringOverflow a)
forall a. NFData a => IgnoringOverflow a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => IgnoringOverflow a -> ()
rnf :: IgnoringOverflow a -> ()
NFData
  deriving newtype (Semigroup (IgnoringOverflow a)
IgnoringOverflow a
Semigroup (IgnoringOverflow a) =>
IgnoringOverflow a
-> (IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a)
-> ([IgnoringOverflow a] -> IgnoringOverflow a)
-> Monoid (IgnoringOverflow a)
[IgnoringOverflow a] -> IgnoringOverflow a
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (IgnoringOverflow a)
forall a. Monoid a => IgnoringOverflow a
forall a. Monoid a => [IgnoringOverflow a] -> IgnoringOverflow a
forall a.
Monoid a =>
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
$cmempty :: forall a. Monoid a => IgnoringOverflow a
mempty :: IgnoringOverflow a
$cmappend :: forall a.
Monoid a =>
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
mappend :: IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
$cmconcat :: forall a. Monoid a => [IgnoringOverflow a] -> IgnoringOverflow a
mconcat :: [IgnoringOverflow a] -> IgnoringOverflow a
Monoid, NonEmpty (IgnoringOverflow a) -> IgnoringOverflow a
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
(IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a)
-> (NonEmpty (IgnoringOverflow a) -> IgnoringOverflow a)
-> (forall b.
    Integral b =>
    b -> IgnoringOverflow a -> IgnoringOverflow a)
-> Semigroup (IgnoringOverflow a)
forall b.
Integral b =>
b -> IgnoringOverflow a -> IgnoringOverflow a
forall a.
Semigroup a =>
NonEmpty (IgnoringOverflow a) -> IgnoringOverflow a
forall a.
Semigroup a =>
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
forall a b.
(Semigroup a, Integral b) =>
b -> IgnoringOverflow a -> IgnoringOverflow a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a.
Semigroup a =>
IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
<> :: IgnoringOverflow a -> IgnoringOverflow a -> IgnoringOverflow a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (IgnoringOverflow a) -> IgnoringOverflow a
sconcat :: NonEmpty (IgnoringOverflow a) -> IgnoringOverflow a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> IgnoringOverflow a -> IgnoringOverflow a
stimes :: forall b.
Integral b =>
b -> IgnoringOverflow a -> IgnoringOverflow a
Semigroup)
  deriving newtype Context -> IgnoringOverflow a -> IO (Maybe ThunkInfo)
Proxy (IgnoringOverflow a) -> String
(Context -> IgnoringOverflow a -> IO (Maybe ThunkInfo))
-> (Context -> IgnoringOverflow a -> IO (Maybe ThunkInfo))
-> (Proxy (IgnoringOverflow a) -> String)
-> NoThunks (IgnoringOverflow a)
forall a.
NoThunks a =>
Context -> IgnoringOverflow a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Proxy (IgnoringOverflow a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall a.
NoThunks a =>
Context -> IgnoringOverflow a -> IO (Maybe ThunkInfo)
noThunks :: Context -> IgnoringOverflow a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a.
NoThunks a =>
Context -> IgnoringOverflow a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> IgnoringOverflow a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall a. NoThunks a => Proxy (IgnoringOverflow a) -> String
showTypeOf :: Proxy (IgnoringOverflow a) -> String
NoThunks
  deriving newtype IgnoringOverflow a -> ByteSize32
(IgnoringOverflow a -> ByteSize32)
-> HasByteSize (IgnoringOverflow a)
forall a. HasByteSize a => IgnoringOverflow a -> ByteSize32
forall a. (a -> ByteSize32) -> HasByteSize a
$ctxMeasureByteSize :: forall a. HasByteSize a => IgnoringOverflow a -> ByteSize32
txMeasureByteSize :: IgnoringOverflow a -> ByteSize32
HasByteSize
  deriving newtype IgnoringOverflow a -> Natural
IgnoringOverflow a -> ByteSize32
(IgnoringOverflow a -> ByteSize32)
-> (IgnoringOverflow a -> Natural)
-> (IgnoringOverflow a -> Natural)
-> (IgnoringOverflow a -> ByteSize32)
-> TxMeasureMetrics (IgnoringOverflow a)
forall a. TxMeasureMetrics a => IgnoringOverflow a -> Natural
forall a. TxMeasureMetrics a => IgnoringOverflow a -> ByteSize32
forall msr.
(msr -> ByteSize32)
-> (msr -> Natural)
-> (msr -> Natural)
-> (msr -> ByteSize32)
-> TxMeasureMetrics msr
$ctxMeasureMetricTxSizeBytes :: forall a. TxMeasureMetrics a => IgnoringOverflow a -> ByteSize32
txMeasureMetricTxSizeBytes :: IgnoringOverflow a -> ByteSize32
$ctxMeasureMetricExUnitsMemory :: forall a. TxMeasureMetrics a => IgnoringOverflow a -> Natural
txMeasureMetricExUnitsMemory :: IgnoringOverflow a -> Natural
$ctxMeasureMetricExUnitsSteps :: forall a. TxMeasureMetrics a => IgnoringOverflow a -> Natural
txMeasureMetricExUnitsSteps :: IgnoringOverflow a -> Natural
$ctxMeasureMetricRefScriptsSizeBytes :: forall a. TxMeasureMetrics a => IgnoringOverflow a -> ByteSize32
txMeasureMetricRefScriptsSizeBytes :: IgnoringOverflow a -> ByteSize32
TxMeasureMetrics

instance Measure (IgnoringOverflow ByteSize32) where
  zero :: IgnoringOverflow ByteSize32
zero = Word32 -> IgnoringOverflow ByteSize32
forall a b. Coercible a b => a -> b
coerce (Word32
0 :: Word32)
  plus :: IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32 -> IgnoringOverflow ByteSize32
plus = (Word32 -> Word32 -> Word32)
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
forall a b. Coercible a b => a -> b
coerce ((Word32 -> Word32 -> Word32)
 -> IgnoringOverflow ByteSize32
 -> IgnoringOverflow ByteSize32
 -> IgnoringOverflow ByteSize32)
-> (Word32 -> Word32 -> Word32)
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
(+) @Word32
  min :: IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32 -> IgnoringOverflow ByteSize32
min = (Word32 -> Word32 -> Word32)
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
forall a b. Coercible a b => a -> b
coerce ((Word32 -> Word32 -> Word32)
 -> IgnoringOverflow ByteSize32
 -> IgnoringOverflow ByteSize32
 -> IgnoringOverflow ByteSize32)
-> (Word32 -> Word32 -> Word32)
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min @Word32
  max :: IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32 -> IgnoringOverflow ByteSize32
max = (Word32 -> Word32 -> Word32)
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
forall a b. Coercible a b => a -> b
coerce ((Word32 -> Word32 -> Word32)
 -> IgnoringOverflow ByteSize32
 -> IgnoringOverflow ByteSize32
 -> IgnoringOverflow ByteSize32)
-> (Word32 -> Word32 -> Word32)
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max @Word32

class HasByteSize a where
  -- | The byte size component (of 'TxMeasure')
  txMeasureByteSize :: a -> ByteSize32

instance HasByteSize ByteSize32 where
  txMeasureByteSize :: ByteSize32 -> ByteSize32
txMeasureByteSize = ByteSize32 -> ByteSize32
forall a. a -> a
id

class TxMeasureMetrics msr where
  txMeasureMetricTxSizeBytes :: msr -> ByteSize32
  txMeasureMetricExUnitsMemory :: msr -> Natural
  txMeasureMetricExUnitsSteps :: msr -> Natural
  txMeasureMetricRefScriptsSizeBytes :: msr -> ByteSize32

instance TxMeasureMetrics ByteSize32 where
  txMeasureMetricTxSizeBytes :: ByteSize32 -> ByteSize32
txMeasureMetricTxSizeBytes = ByteSize32 -> ByteSize32
forall a. a -> a
id
  txMeasureMetricExUnitsMemory :: ByteSize32 -> Natural
txMeasureMetricExUnitsMemory ByteSize32
_ = Natural
0
  txMeasureMetricExUnitsSteps :: ByteSize32 -> Natural
txMeasureMetricExUnitsSteps ByteSize32
_ = Natural
0
  txMeasureMetricRefScriptsSizeBytes :: ByteSize32 -> ByteSize32
txMeasureMetricRefScriptsSizeBytes ByteSize32
_ = ByteSize32
forall a. Monoid a => a
mempty

-- | A transaction that was previously valid. Used to clarify the types on the
-- 'reapplyTxs' function.
data Invalidated blk = Invalidated
  { forall blk. Invalidated blk -> Validated (GenTx blk)
getInvalidated :: !(Validated (GenTx blk))
  , forall blk. Invalidated blk -> ApplyTxErr blk
getReason :: !(ApplyTxErr blk)
  }