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

module Ouroboros.Consensus.Ledger.SupportsMempool
  ( ApplyTxErr
  , ByteSize32 (..)
  , WhatToDoWithTxDiffs (..)
  , InputTxDiffs
  , ConvertRawTxId (..)
  , GenTx
  , GenTxId
  , HasByteSize (..)
  , HasTxId (..)
  , HasTxs (..)
  , IgnoringOverflow (..)
  , Invalidated (..)
  , LedgerSupportsMempool (..)
  , ReapplyTxsResult (..)
  , TxId
  , TxLimits (..)
  , TxMeasureMetrics (..)
  , Validated
  , WhetherToIntervene (..)
  , nothingMkMempoolApplyTxError
  ) 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.Text (Text)
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
import Ouroboros.Network.SizeInBytes as Network

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

-- | When we are revalidating the transactions in the mempool, we either will
-- store the resulting differences (when re-syncing with the LedgerDB) or we
-- simply don't care (when acquiring a mempool snapshot for forging a block).
type data WhatToDoWithTxDiffs = Collect | Discard

-- | This type family serves to make sure that when we are going to discard the
-- differences, we don't even have differences around that we might misuse.
type family InputTxDiffs blk wtd where
  InputTxDiffs blk Discard = ()
  InputTxDiffs blk Collect = LedgerTables (TickedLedgerState blk) DiffMK

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 =>
    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 ValuesMK)

  -- | 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 ::
    LedgerConfig blk ->
    -- | Slot number of the block containing the tx
    SlotNo ->
    [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)] ->
    TickedLedgerState blk ValuesMK ->
    ReapplyTxsResult extra blk wtd
  reapplyTxs LedgerConfig blk
cfg SlotNo
slot [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
txs TickedLedgerState blk ValuesMK
st =
    (\([Invalidated blk]
err, [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
val, TickedLedgerState blk ValuesMK
st') -> [Invalidated blk]
-> [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
-> TickedLedgerState blk EmptyMK
-> ReapplyTxsResult extra blk wtd
forall extra blk (wtd :: WhatToDoWithTxDiffs).
[Invalidated blk]
-> [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
-> TickedLedgerState blk EmptyMK
-> ReapplyTxsResult extra blk wtd
ReapplyTxsResult [Invalidated blk]
err ([(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
-> [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
forall a. [a] -> [a]
reverse [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
val) (TickedLedgerState blk ValuesMK -> TickedLedgerState blk EmptyMK
forall (l :: MapKind -> *) (mk :: MapKind).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables TickedLedgerState blk ValuesMK
st')) (([Invalidated blk],
  [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)],
  TickedLedgerState blk ValuesMK)
 -> ReapplyTxsResult extra blk wtd)
-> ([Invalidated blk],
    [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)],
    TickedLedgerState blk ValuesMK)
-> ReapplyTxsResult extra blk wtd
forall a b. (a -> b) -> a -> b
$
      ((Validated (GenTx blk), InputTxDiffs blk wtd, extra)
 -> Validated (GenTx blk))
-> [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
-> ([Invalidated blk],
    [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)],
    TickedLedgerState blk ValuesMK)
forall a.
(a -> Validated (GenTx blk))
-> [a] -> ([Invalidated blk], [a], TickedLedgerState blk ValuesMK)
foldReapplyTxs (Validated (GenTx blk), InputTxDiffs blk wtd, extra)
-> Validated (GenTx blk)
forall {a} {b} {c}. (a, b, c) -> a
fst3 [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
txs
   where
    fst3 :: (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a

    foldReapplyTxs ::
      (a -> Validated (GenTx blk)) ->
      [a] ->
      ([Invalidated blk], [a], TickedLedgerState blk ValuesMK)
    foldReapplyTxs :: forall a.
(a -> Validated (GenTx blk))
-> [a] -> ([Invalidated blk], [a], TickedLedgerState blk ValuesMK)
foldReapplyTxs a -> Validated (GenTx blk)
projectTx =
      (([Invalidated blk], [a], TickedLedgerState blk ValuesMK)
 -> a -> ([Invalidated blk], [a], TickedLedgerState blk ValuesMK))
-> ([Invalidated blk], [a], TickedLedgerState blk ValuesMK)
-> [a]
-> ([Invalidated blk], [a], TickedLedgerState blk ValuesMK)
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, [a]
accV, TickedLedgerState blk ValuesMK
st') a
a ->
            case Except (ApplyTxErr blk) (TickedLedgerState blk ValuesMK)
-> Either (ApplyTxErr blk) (TickedLedgerState blk ValuesMK)
forall e a. Except e a -> Either e a
runExcept (LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> TickedLedgerState blk ValuesMK
-> Except (ApplyTxErr blk) (TickedLedgerState blk ValuesMK)
forall blk.
(LedgerSupportsMempool blk, HasCallStack) =>
LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> TickedLedgerState blk ValuesMK
-> Except (ApplyTxErr blk) (TickedLedgerState blk ValuesMK)
reapplyTx LedgerConfig blk
cfg SlotNo
slot (a -> Validated (GenTx blk)
projectTx a
a) TickedLedgerState blk ValuesMK
st') of
              Left ApplyTxErr blk
err -> (Validated (GenTx blk) -> ApplyTxErr blk -> Invalidated blk
forall blk.
Validated (GenTx blk) -> ApplyTxErr blk -> Invalidated blk
Invalidated (a -> Validated (GenTx blk)
projectTx a
a) ApplyTxErr blk
err Invalidated blk -> [Invalidated blk] -> [Invalidated blk]
forall a. a -> [a] -> [a]
: [Invalidated blk]
accE, [a]
accV, TickedLedgerState blk ValuesMK
st')
              Right TickedLedgerState blk ValuesMK
st'' -> ([Invalidated blk]
accE, a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
accV, TickedLedgerState blk ValuesMK
st'')
        )
        ([], [], TickedLedgerState blk ValuesMK
st)

  -- | 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
  --
  -- Intended to be non-default in the HardFork instance for optimizing
  -- performance.
  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
  --
  -- Intended to be non-default in the HardFork instance for optimizing
  -- performance.
  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

  -- | The ledger rules' error type for the mempool's current era might allow
  -- the mempool to reject a tx for its own reasons.
  --
  -- This function therefore constructs the type that the @LocalTxSubmission@
  -- node-to-client mini protocol sends when a tx is rejected.
  mkMempoolApplyTxError ::
    -- | for the HFC
    TickedLedgerState blk mk ->
    Text ->
    Maybe (ApplyTxErr blk)

-- | Value of 'mkMempoolApplyTxError' when the block type can never
-- construct the ledger error
nothingMkMempoolApplyTxError :: TickedLedgerState blk mk -> Text -> Maybe (ApplyTxErr blk)
nothingMkMempoolApplyTxError :: forall blk (mk :: MapKind).
TickedLedgerState blk mk -> Text -> Maybe (ApplyTxErr blk)
nothingMkMempoolApplyTxError TickedLedgerState blk mk
_ Text
_ = Maybe (ApplyTxErr blk)
forall a. Maybe a
Nothing

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

-- | 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 size of the transaction from the perspective of diffusion layer
  txWireSize :: GenTx blk -> Network.SizeInBytes

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