{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Shelley mempool integration
--
-- TODO nearly all of the logic in this module belongs in cardano-ledger, not
-- ouroboros-consensus; ouroboros-consensus-cardano should just be "glue code".
module Ouroboros.Consensus.Shelley.Ledger.Mempool (
    GenTx (..)
  , SL.ApplyTxError (..)
  , TxId (..)
  , Validated (..)
  , fixedBlockBodyOverhead
  , mkShelleyTx
  , mkShelleyValidatedTx
  , perTxOverhead
    -- * Exported for tests
  , AlonzoMeasure (..)
  , ConwayMeasure (..)
  , fromExUnits
  ) where

import qualified Cardano.Crypto.Hash as Hash
import qualified Cardano.Ledger.Allegra.Rules as AllegraEra
import           Cardano.Ledger.Alonzo.Core (Tx, TxSeq, bodyTxL, eraDecoder,
                     fromTxSeq, ppMaxBBSizeL, ppMaxBlockExUnitsL, sizeTxF)
import qualified Cardano.Ledger.Alonzo.Rules as AlonzoEra
import           Cardano.Ledger.Alonzo.Scripts (ExUnits, ExUnits' (..),
                     pointWiseExUnits, unWrapExUnits)
import           Cardano.Ledger.Alonzo.Tx (totExUnits)
import qualified Cardano.Ledger.Api as L
import qualified Cardano.Ledger.Babbage.Rules as BabbageEra
import qualified Cardano.Ledger.BaseTypes as L
import           Cardano.Ledger.Binary (Annotator (..), DecCBOR (..),
                     EncCBOR (..), FromCBOR (..), FullByteString (..),
                     ToCBOR (..))
import qualified Cardano.Ledger.Conway.Rules as ConwayEra
import qualified Cardano.Ledger.Conway.Rules as SL
import qualified Cardano.Ledger.Conway.UTxO as SL
import qualified Cardano.Ledger.Core as SL (txIdTxBody)
import qualified Cardano.Ledger.Hashes as SL
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Rules as ShelleyEra
import           Cardano.Protocol.Crypto (Crypto)
import           Control.Arrow ((+++))
import           Control.Monad (guard)
import           Control.Monad.Except (Except, liftEither)
import           Control.Monad.Identity (Identity (..))
import           Data.DerivingVia (InstantiatedAt (..))
import           Data.Foldable (toList)
import           Data.Measure (Measure)
import           Data.Typeable (Typeable)
import qualified Data.Validation as V
import           GHC.Generics (Generic)
import           GHC.Natural (Natural)
import           Lens.Micro ((^.))
import           NoThunks.Class (NoThunks (..))
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Shelley.Eras
import           Ouroboros.Consensus.Shelley.Ledger.Block
import           Ouroboros.Consensus.Shelley.Ledger.Ledger
                     (ShelleyLedgerConfig (shelleyLedgerGlobals),
                     Ticked (TickedShelleyLedgerState, tickedShelleyLedgerState),
                     getPParams)
import           Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
import           Ouroboros.Consensus.Util (ShowProxy (..))
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)

data instance GenTx (ShelleyBlock proto era) = ShelleyTx !SL.TxId !(Tx era)
  deriving stock    ((forall x.
 GenTx (ShelleyBlock proto era)
 -> Rep (GenTx (ShelleyBlock proto era)) x)
-> (forall x.
    Rep (GenTx (ShelleyBlock proto era)) x
    -> GenTx (ShelleyBlock proto era))
-> Generic (GenTx (ShelleyBlock proto era))
forall x.
Rep (GenTx (ShelleyBlock proto era)) x
-> GenTx (ShelleyBlock proto era)
forall x.
GenTx (ShelleyBlock proto era)
-> Rep (GenTx (ShelleyBlock proto era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (GenTx (ShelleyBlock proto era)) x
-> GenTx (ShelleyBlock proto era)
forall proto era x.
GenTx (ShelleyBlock proto era)
-> Rep (GenTx (ShelleyBlock proto era)) x
$cfrom :: forall proto era x.
GenTx (ShelleyBlock proto era)
-> Rep (GenTx (ShelleyBlock proto era)) x
from :: forall x.
GenTx (ShelleyBlock proto era)
-> Rep (GenTx (ShelleyBlock proto era)) x
$cto :: forall proto era x.
Rep (GenTx (ShelleyBlock proto era)) x
-> GenTx (ShelleyBlock proto era)
to :: forall x.
Rep (GenTx (ShelleyBlock proto era)) x
-> GenTx (ShelleyBlock proto era)
Generic)

deriving instance ShelleyBasedEra era => NoThunks (GenTx (ShelleyBlock proto era))

deriving instance ShelleyBasedEra era => Eq (GenTx (ShelleyBlock proto era))

instance (Typeable era, Typeable proto)
  => ShowProxy (GenTx (ShelleyBlock proto era)) where

data instance Validated (GenTx (ShelleyBlock proto era)) =
    ShelleyValidatedTx
      !SL.TxId
      !(SL.Validated (Tx era))
  deriving stock ((forall x.
 Validated (GenTx (ShelleyBlock proto era))
 -> Rep (Validated (GenTx (ShelleyBlock proto era))) x)
-> (forall x.
    Rep (Validated (GenTx (ShelleyBlock proto era))) x
    -> Validated (GenTx (ShelleyBlock proto era)))
-> Generic (Validated (GenTx (ShelleyBlock proto era)))
forall x.
Rep (Validated (GenTx (ShelleyBlock proto era))) x
-> Validated (GenTx (ShelleyBlock proto era))
forall x.
Validated (GenTx (ShelleyBlock proto era))
-> Rep (Validated (GenTx (ShelleyBlock proto era))) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (Validated (GenTx (ShelleyBlock proto era))) x
-> Validated (GenTx (ShelleyBlock proto era))
forall proto era x.
Validated (GenTx (ShelleyBlock proto era))
-> Rep (Validated (GenTx (ShelleyBlock proto era))) x
$cfrom :: forall proto era x.
Validated (GenTx (ShelleyBlock proto era))
-> Rep (Validated (GenTx (ShelleyBlock proto era))) x
from :: forall x.
Validated (GenTx (ShelleyBlock proto era))
-> Rep (Validated (GenTx (ShelleyBlock proto era))) x
$cto :: forall proto era x.
Rep (Validated (GenTx (ShelleyBlock proto era))) x
-> Validated (GenTx (ShelleyBlock proto era))
to :: forall x.
Rep (Validated (GenTx (ShelleyBlock proto era))) x
-> Validated (GenTx (ShelleyBlock proto era))
Generic)

deriving instance ShelleyBasedEra era => NoThunks (Validated (GenTx (ShelleyBlock proto era)))

deriving instance ShelleyBasedEra era => Eq (Validated (GenTx (ShelleyBlock proto era)))

deriving instance ShelleyBasedEra era => Show (Validated (GenTx (ShelleyBlock proto era)))

instance (Typeable era, Typeable proto)
  => ShowProxy (Validated (GenTx (ShelleyBlock proto era))) where

type instance ApplyTxErr (ShelleyBlock proto era) = SL.ApplyTxError era

-- orphaned instance
instance Typeable era => ShowProxy (SL.ApplyTxError era) where


-- |'txInBlockSize' is used to estimate how many transactions we can grab from
-- the Mempool to put into the block we are going to forge without exceeding
-- the maximum block body size according to the ledger. If we exceed that
-- limit, we will have forged a block that is invalid according to the ledger.
-- We ourselves won't even adopt it, causing us to lose our slot, something we
-- must try to avoid.
--
-- For this reason it is better to overestimate the size of a transaction than
-- to underestimate. The only downside is that we maybe could have put one (or
-- more?) transactions extra in that block.
--
-- As the sum of the serialised transaction sizes is not equal to the size of
-- the serialised block body ('TxSeq') consisting of those transactions
-- (see cardano-node#1545 for an example), we account for some extra overhead
-- per transaction as a safety margin.
--
-- Also see 'perTxOverhead'.
fixedBlockBodyOverhead :: Num a => a
fixedBlockBodyOverhead :: forall a. Num a => a
fixedBlockBodyOverhead = a
1024

-- | See 'fixedBlockBodyOverhead'.
perTxOverhead :: Num a => a
perTxOverhead :: forall a. Num a => a
perTxOverhead = a
4

instance (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era))
      => LedgerSupportsMempool (ShelleyBlock proto era) where
  txInvariant :: GenTx (ShelleyBlock proto era) -> Bool
txInvariant = Bool -> GenTx (ShelleyBlock proto era) -> Bool
forall a b. a -> b -> a
const Bool
True

  applyTx :: LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)),
      Validated (GenTx (ShelleyBlock proto era)))
applyTx = LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)),
      Validated (GenTx (ShelleyBlock proto era)))
forall era proto.
ShelleyBasedEra era =>
LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (TickedLedgerState (ShelleyBlock proto era),
      Validated (GenTx (ShelleyBlock proto era)))
applyShelleyTx

  reapplyTx :: HasCallStack =>
LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)))
reapplyTx = LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)))
forall era proto.
ShelleyBasedEra era =>
LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> TickedLedgerState (ShelleyBlock proto era)
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (TickedLedgerState (ShelleyBlock proto era))
reapplyShelleyTx

  txForgetValidated :: Validated (GenTx (ShelleyBlock proto era))
-> GenTx (ShelleyBlock proto era)
txForgetValidated (ShelleyValidatedTx TxId
txid Validated (Tx era)
vtx) = TxId -> Tx era -> GenTx (ShelleyBlock proto era)
forall proto era. TxId -> Tx era -> GenTx (ShelleyBlock proto era)
ShelleyTx TxId
txid (Validated (Tx era) -> Tx era
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx era)
vtx)

mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx :: forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx Tx era
tx = TxId -> Tx era -> GenTx (ShelleyBlock proto era)
forall proto era. TxId -> Tx era -> GenTx (ShelleyBlock proto era)
ShelleyTx (forall era. EraTxBody era => TxBody era -> TxId
SL.txIdTxBody @era (Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL)) Tx era
tx

mkShelleyValidatedTx :: forall era proto.
     ShelleyBasedEra era
  => SL.Validated (Tx era)
  -> Validated (GenTx (ShelleyBlock proto era))
mkShelleyValidatedTx :: forall era proto.
ShelleyBasedEra era =>
Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
mkShelleyValidatedTx Validated (Tx era)
vtx = TxId
-> Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
forall proto era.
TxId
-> Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
ShelleyValidatedTx TxId
txid Validated (Tx era)
vtx
  where
    txid :: TxId
txid = forall era. EraTxBody era => TxBody era -> TxId
SL.txIdTxBody @era (Validated (Tx era) -> Tx era
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx era)
vtx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL)

newtype instance TxId (GenTx (ShelleyBlock proto era)) = ShelleyTxId SL.TxId
  deriving newtype (TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
(TxId (GenTx (ShelleyBlock proto era))
 -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> Eq (TxId (GenTx (ShelleyBlock proto era)))
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c== :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
== :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c/= :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
/= :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
Eq, Eq (TxId (GenTx (ShelleyBlock proto era)))
Eq (TxId (GenTx (ShelleyBlock proto era))) =>
(TxId (GenTx (ShelleyBlock proto era))
 -> TxId (GenTx (ShelleyBlock proto era)) -> Ordering)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)))
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)))
-> Ord (TxId (GenTx (ShelleyBlock proto era)))
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Ordering
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
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 proto era. Eq (TxId (GenTx (ShelleyBlock proto era)))
forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Ordering
forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
$ccompare :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Ordering
compare :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Ordering
$c< :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
< :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c<= :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
<= :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c> :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
> :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c>= :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
>= :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$cmax :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
max :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
$cmin :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
min :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
Ord, Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String
(Context
 -> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo))
-> (Context
    -> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo))
-> (Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String)
-> NoThunks (TxId (GenTx (ShelleyBlock proto era)))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall proto era.
Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
forall proto era.
Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String
$cnoThunks :: forall proto era.
Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall proto era.
Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String
showTypeOf :: Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String
NoThunks)

deriving newtype instance (Typeable era, Typeable proto, Crypto (ProtoCrypto proto))
                       => EncCBOR (TxId (GenTx (ShelleyBlock proto era)))
deriving newtype instance (Typeable era, Typeable proto, Crypto (ProtoCrypto proto))
                       => DecCBOR (TxId (GenTx (ShelleyBlock proto era)))

instance (Typeable era, Typeable proto)
  => ShowProxy (TxId (GenTx (ShelleyBlock proto era))) where

instance ShelleyBasedEra era => HasTxId (GenTx (ShelleyBlock proto era)) where
  txId :: GenTx (ShelleyBlock proto era)
-> TxId (GenTx (ShelleyBlock proto era))
txId (ShelleyTx TxId
i Tx era
_) = TxId -> TxId (GenTx (ShelleyBlock proto era))
forall proto era. TxId -> TxId (GenTx (ShelleyBlock proto era))
ShelleyTxId TxId
i

instance ShelleyBasedEra era => ConvertRawTxId (GenTx (ShelleyBlock proto era)) where
  toRawTxIdHash :: TxId (GenTx (ShelleyBlock proto era)) -> ShortByteString
toRawTxIdHash (ShelleyTxId TxId
i) =
      Hash HASH EraIndependentTxBody -> ShortByteString
forall h a. Hash h a -> ShortByteString
Hash.hashToBytesShort (Hash HASH EraIndependentTxBody -> ShortByteString)
-> (TxId -> Hash HASH EraIndependentTxBody)
-> TxId
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
SL.extractHash (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody)
-> (TxId -> SafeHash EraIndependentTxBody)
-> TxId
-> Hash HASH EraIndependentTxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId -> SafeHash EraIndependentTxBody
SL.unTxId (TxId -> ShortByteString) -> TxId -> ShortByteString
forall a b. (a -> b) -> a -> b
$ TxId
i

instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where
  extractTxs :: ShelleyBlock proto era -> [GenTx (ShelleyBlock proto era)]
extractTxs =
        (Tx era -> GenTx (ShelleyBlock proto era))
-> [Tx era] -> [GenTx (ShelleyBlock proto era)]
forall a b. (a -> b) -> [a] -> [b]
map Tx era -> GenTx (ShelleyBlock proto era)
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx
      ([Tx era] -> [GenTx (ShelleyBlock proto era)])
-> (ShelleyBlock proto era -> [Tx era])
-> ShelleyBlock proto era
-> [GenTx (ShelleyBlock proto era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq era -> [Tx era]
txSeqToList
      (TxSeq era -> [Tx era])
-> (ShelleyBlock proto era -> TxSeq era)
-> ShelleyBlock proto era
-> [Tx era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (ShelleyProtocolHeader proto) era -> TxSeq era
forall h era. Block h era -> TxSeq era
SL.bbody
      (Block (ShelleyProtocolHeader proto) era -> TxSeq era)
-> (ShelleyBlock proto era
    -> Block (ShelleyProtocolHeader proto) era)
-> ShelleyBlock proto era
-> TxSeq era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
forall proto era.
ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
shelleyBlockRaw
    where
      txSeqToList :: TxSeq era -> [Tx era]
      txSeqToList :: TxSeq era -> [Tx era]
txSeqToList = StrictSeq (Tx era) -> [Tx era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (Tx era) -> [Tx era])
-> (TxSeq era -> StrictSeq (Tx era)) -> TxSeq era -> [Tx era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraSegWits era => TxSeq era -> StrictSeq (Tx era)
fromTxSeq @era

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

instance ShelleyCompatible proto era => ToCBOR (GenTx (ShelleyBlock proto era)) where
  -- No need to encode the 'TxId', it's just a hash of the 'SL.TxBody' inside
  -- 'SL.Tx', so it can be recomputed.
  toCBOR :: GenTx (ShelleyBlock proto era) -> Encoding
toCBOR (ShelleyTx TxId
_txid Tx era
tx) = (Tx era -> Encoding) -> Tx era -> Encoding
forall a. (a -> Encoding) -> a -> Encoding
wrapCBORinCBOR Tx era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Tx era
tx

instance ShelleyCompatible proto era => FromCBOR (GenTx (ShelleyBlock proto era)) where
  fromCBOR :: forall s. Decoder s (GenTx (ShelleyBlock proto era))
fromCBOR = (Tx era -> GenTx (ShelleyBlock proto era))
-> Decoder s (Tx era) -> Decoder s (GenTx (ShelleyBlock proto era))
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx era -> GenTx (ShelleyBlock proto era)
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx (Decoder s (Tx era) -> Decoder s (GenTx (ShelleyBlock proto era)))
-> Decoder s (Tx era) -> Decoder s (GenTx (ShelleyBlock proto era))
forall a b. (a -> b) -> a -> b
$ (forall s. Decoder s (ByteString -> Tx era))
-> forall s. Decoder s (Tx era)
forall a.
(forall s. Decoder s (ByteString -> a)) -> forall s. Decoder s a
unwrapCBORinCBOR
    ((forall s. Decoder s (ByteString -> Tx era))
 -> forall s. Decoder s (Tx era))
-> (forall s. Decoder s (ByteString -> Tx era))
-> forall s. Decoder s (Tx era)
forall a b. (a -> b) -> a -> b
$ forall era t s. Era era => Decoder s t -> Decoder s t
eraDecoder @era (Decoder s (ByteString -> Tx era)
 -> Decoder s (ByteString -> Tx era))
-> Decoder s (ByteString -> Tx era)
-> Decoder s (ByteString -> Tx era)
forall a b. (a -> b) -> a -> b
$ ((FullByteString -> Tx era)
-> (ByteString -> FullByteString) -> ByteString -> Tx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FullByteString
Full) ((FullByteString -> Tx era) -> ByteString -> Tx era)
-> (Annotator (Tx era) -> FullByteString -> Tx era)
-> Annotator (Tx era)
-> ByteString
-> Tx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotator (Tx era) -> FullByteString -> Tx era
forall a. Annotator a -> FullByteString -> a
runAnnotator (Annotator (Tx era) -> ByteString -> Tx era)
-> Decoder s (Annotator (Tx era))
-> Decoder s (ByteString -> Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator (Tx era))
forall s. Decoder s (Annotator (Tx era))
forall a s. DecCBOR a => Decoder s a
decCBOR

{-------------------------------------------------------------------------------
  Pretty-printing
-------------------------------------------------------------------------------}

instance ShelleyBasedEra era => Condense (GenTx (ShelleyBlock proto era)) where
  condense :: GenTx (ShelleyBlock proto era) -> String
condense (ShelleyTx TxId
_ Tx era
tx ) = Tx era -> String
forall a. Show a => a -> String
show Tx era
tx

instance Condense (GenTxId (ShelleyBlock proto era)) where
  condense :: GenTxId (ShelleyBlock proto era) -> String
condense (ShelleyTxId TxId
i) = String
"txid: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall a. Show a => a -> String
show TxId
i

instance ShelleyBasedEra era => Show (GenTx (ShelleyBlock proto era)) where
  show :: GenTx (ShelleyBlock proto era) -> String
show = GenTx (ShelleyBlock proto era) -> String
forall a. Condense a => a -> String
condense

instance Show (GenTxId (ShelleyBlock proto era)) where
  show :: GenTxId (ShelleyBlock proto era) -> String
show = GenTxId (ShelleyBlock proto era) -> String
forall a. Condense a => a -> String
condense

{-------------------------------------------------------------------------------
  Applying transactions
-------------------------------------------------------------------------------}

applyShelleyTx :: forall era proto.
     ShelleyBasedEra era
  => LedgerConfig (ShelleyBlock proto era)
  -> WhetherToIntervene
  -> SlotNo
  -> GenTx (ShelleyBlock proto era)
  -> TickedLedgerState (ShelleyBlock proto era)
  -> Except (ApplyTxErr (ShelleyBlock proto era))
       ( TickedLedgerState (ShelleyBlock proto era)
       , Validated (GenTx (ShelleyBlock proto era))
       )
applyShelleyTx :: forall era proto.
ShelleyBasedEra era =>
LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (TickedLedgerState (ShelleyBlock proto era),
      Validated (GenTx (ShelleyBlock proto era)))
applyShelleyTx LedgerConfig (ShelleyBlock proto era)
cfg WhetherToIntervene
wti SlotNo
slot (ShelleyTx TxId
_ Tx era
tx) TickedLedgerState (ShelleyBlock proto era)
st = do
    (LedgerState era
mempoolState', Validated (Tx era)
vtx) <-
       Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> ExceptT
     (ApplyTxError era) Identity (LedgerState era, Validated (Tx era))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> LedgerState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (LedgerState era, Validated (Tx era))
applyShelleyBasedTx
         (ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg)
         (NewEpochState era -> SlotNo -> LedgerEnv era
forall era.
EraGov era =>
NewEpochState era -> SlotNo -> MempoolEnv era
SL.mkMempoolEnv   NewEpochState era
innerSt SlotNo
slot)
         (NewEpochState era -> LedgerState era
forall era. NewEpochState era -> MempoolState era
SL.mkMempoolState NewEpochState era
innerSt)
         WhetherToIntervene
wti
         Tx era
tx

    let st' :: TickedLedgerState (ShelleyBlock proto era)
st' = (forall (f :: * -> *).
 Applicative f =>
 (LedgerState era -> f (LedgerState era))
 -> TickedLedgerState (ShelleyBlock proto era)
 -> f (TickedLedgerState (ShelleyBlock proto era)))
-> LedgerState era
-> TickedLedgerState (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> b -> s -> t
set (LedgerState era -> f (LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *).
Applicative f =>
(LedgerState era -> f (LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *) era proto.
Functor f =>
(LedgerState era -> f (LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens LedgerState era
mempoolState' TickedLedgerState (ShelleyBlock proto era)
st

    (TickedLedgerState (ShelleyBlock proto era),
 Validated (GenTx (ShelleyBlock proto era)))
-> ExceptT
     (ApplyTxError era)
     Identity
     (TickedLedgerState (ShelleyBlock proto era),
      Validated (GenTx (ShelleyBlock proto era)))
forall a. a -> ExceptT (ApplyTxError era) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TickedLedgerState (ShelleyBlock proto era)
st', Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
forall era proto.
ShelleyBasedEra era =>
Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
mkShelleyValidatedTx Validated (Tx era)
vtx)
  where
    innerSt :: NewEpochState era
innerSt = TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
st

reapplyShelleyTx ::
     ShelleyBasedEra era
  => LedgerConfig (ShelleyBlock proto era)
  -> SlotNo
  -> Validated (GenTx (ShelleyBlock proto era))
  -> TickedLedgerState (ShelleyBlock proto era)
  -> Except (ApplyTxErr (ShelleyBlock proto era)) (TickedLedgerState (ShelleyBlock proto era))
reapplyShelleyTx :: forall era proto.
ShelleyBasedEra era =>
LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> TickedLedgerState (ShelleyBlock proto era)
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (TickedLedgerState (ShelleyBlock proto era))
reapplyShelleyTx LedgerConfig (ShelleyBlock proto era)
cfg SlotNo
slot Validated (GenTx (ShelleyBlock proto era))
vgtx TickedLedgerState (ShelleyBlock proto era)
st = do
    MempoolState era
mempoolState' <-
        Either (ApplyTxError era) (MempoolState era)
-> ExceptT (ApplyTxError era) Identity (MempoolState era)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either (ApplyTxError era) (MempoolState era)
 -> ExceptT (ApplyTxError era) Identity (MempoolState era))
-> Either (ApplyTxError era) (MempoolState era)
-> ExceptT (ApplyTxError era) Identity (MempoolState era)
forall a b. (a -> b) -> a -> b
$
        Globals
-> MempoolEnv era
-> MempoolState era
-> Validated (Tx era)
-> Either (ApplyTxError era) (MempoolState era)
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Validated (Tx era)
-> Either (ApplyTxError era) (MempoolState era)
SL.reapplyTx
          (ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg)
          (NewEpochState era -> SlotNo -> MempoolEnv era
forall era.
EraGov era =>
NewEpochState era -> SlotNo -> MempoolEnv era
SL.mkMempoolEnv   NewEpochState era
innerSt SlotNo
slot)
          (NewEpochState era -> MempoolState era
forall era. NewEpochState era -> MempoolState era
SL.mkMempoolState NewEpochState era
innerSt)
          Validated (Tx era)
vtx

    TickedLedgerState (ShelleyBlock proto era)
-> ExceptT
     (ApplyTxError era)
     Identity
     (TickedLedgerState (ShelleyBlock proto era))
forall a. a -> ExceptT (ApplyTxError era) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TickedLedgerState (ShelleyBlock proto era)
 -> ExceptT
      (ApplyTxError era)
      Identity
      (TickedLedgerState (ShelleyBlock proto era)))
-> TickedLedgerState (ShelleyBlock proto era)
-> ExceptT
     (ApplyTxError era)
     Identity
     (TickedLedgerState (ShelleyBlock proto era))
forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *).
 Applicative f =>
 (MempoolState era -> f (MempoolState era))
 -> TickedLedgerState (ShelleyBlock proto era)
 -> f (TickedLedgerState (ShelleyBlock proto era)))
-> MempoolState era
-> TickedLedgerState (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> b -> s -> t
set (MempoolState era -> f (MempoolState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *).
Applicative f =>
(MempoolState era -> f (MempoolState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *) era proto.
Functor f =>
(LedgerState era -> f (LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens MempoolState era
mempoolState' TickedLedgerState (ShelleyBlock proto era)
st
  where
    ShelleyValidatedTx TxId
_txid Validated (Tx era)
vtx = Validated (GenTx (ShelleyBlock proto era))
vgtx

    innerSt :: NewEpochState era
innerSt = TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
st

-- | The lens combinator
set ::
     (forall f. Applicative f => (a -> f b) -> s -> f t)
  -> b -> s -> t
set :: forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> b -> s -> t
set forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t
lens b
inner s
outer =
    Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ (a -> Identity b) -> s -> Identity t
forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t
lens (\a
_ -> b -> Identity b
forall a. a -> Identity a
Identity b
inner) s
outer

theLedgerLens ::
     Functor f
  => (SL.LedgerState era -> f (SL.LedgerState era))
  -> TickedLedgerState (ShelleyBlock proto era)
  -> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens :: forall (f :: * -> *) era proto.
Functor f =>
(LedgerState era -> f (LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens LedgerState era -> f (LedgerState era)
f TickedLedgerState (ShelleyBlock proto era)
x =
        (\NewEpochState era
y -> TickedLedgerState (ShelleyBlock proto era)
x{tickedShelleyLedgerState = y})
    (NewEpochState era -> TickedLedgerState (ShelleyBlock proto era))
-> f (NewEpochState era)
-> f (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LedgerState era -> f (LedgerState era))
-> NewEpochState era -> f (NewEpochState era)
forall (f :: * -> *) era.
Functor f =>
(MempoolState era -> f (MempoolState era))
-> NewEpochState era -> f (NewEpochState era)
SL.overNewEpochState LedgerState era -> f (LedgerState era)
f (TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
x)

{-------------------------------------------------------------------------------
  Tx Limits
-------------------------------------------------------------------------------}

-- | A non-exported newtype wrapper just to give a 'Semigroup' instance
newtype TxErrorSG era = TxErrorSG { forall era. TxErrorSG era -> ApplyTxError era
unTxErrorSG :: SL.ApplyTxError era }

instance Semigroup (TxErrorSG era) where
  TxErrorSG (SL.ApplyTxError NonEmpty (PredicateFailure (EraRule "LEDGER" era))
x) <> :: TxErrorSG era -> TxErrorSG era -> TxErrorSG era
<> TxErrorSG (SL.ApplyTxError NonEmpty (PredicateFailure (EraRule "LEDGER" era))
y) =
    ApplyTxError era -> TxErrorSG era
forall era. ApplyTxError era -> TxErrorSG era
TxErrorSG (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
x NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a. Semigroup a => a -> a -> a
<> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
y))

validateMaybe ::
     SL.ApplyTxError era
  -> Maybe a
  -> V.Validation (TxErrorSG era) a
validateMaybe :: forall era a.
ApplyTxError era -> Maybe a -> Validation (TxErrorSG era) a
validateMaybe ApplyTxError era
err Maybe a
mb = TxErrorSG era
-> (Maybe a -> Maybe a) -> Maybe a -> Validation (TxErrorSG era) a
forall (v :: * -> * -> *) e a b.
Validate v =>
e -> (a -> Maybe b) -> a -> v e b
V.validate (ApplyTxError era -> TxErrorSG era
forall era. ApplyTxError era -> TxErrorSG era
TxErrorSG ApplyTxError era
err) Maybe a -> Maybe a
forall a. a -> a
id Maybe a
mb

runValidation ::
     V.Validation (TxErrorSG era) a
  -> Except (SL.ApplyTxError era) a
runValidation :: forall era a.
Validation (TxErrorSG era) a -> Except (ApplyTxError era) a
runValidation = Either (ApplyTxError era) a
-> ExceptT (ApplyTxError era) Identity a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either (ApplyTxError era) a
 -> ExceptT (ApplyTxError era) Identity a)
-> (Validation (TxErrorSG era) a -> Either (ApplyTxError era) a)
-> Validation (TxErrorSG era) a
-> ExceptT (ApplyTxError era) Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxErrorSG era -> ApplyTxError era
forall era. TxErrorSG era -> ApplyTxError era
unTxErrorSG (TxErrorSG era -> ApplyTxError era)
-> (a -> a)
-> Either (TxErrorSG era) a
-> Either (ApplyTxError era) a
forall b c b' c'.
(b -> c) -> (b' -> c') -> Either b b' -> Either c c'
forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ a -> a
forall a. a -> a
id) (Either (TxErrorSG era) a -> Either (ApplyTxError era) a)
-> (Validation (TxErrorSG era) a -> Either (TxErrorSG era) a)
-> Validation (TxErrorSG era) a
-> Either (ApplyTxError era) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation (TxErrorSG era) a -> Either (TxErrorSG era) a
forall e a. Validation e a -> Either e a
V.toEither

-----

txsMaxBytes ::
     ShelleyCompatible proto era
  => TickedLedgerState (ShelleyBlock proto era)
  -> IgnoringOverflow ByteSize32
txsMaxBytes :: forall proto era.
ShelleyCompatible proto era =>
TickedLedgerState (ShelleyBlock proto era)
-> IgnoringOverflow ByteSize32
txsMaxBytes TickedShelleyLedgerState { NewEpochState era
tickedShelleyLedgerState :: forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState } =
    -- `maxBlockBodySize` is expected to be bigger than `fixedBlockBodyOverhead`
      ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
IgnoringOverflow
    (ByteSize32 -> IgnoringOverflow ByteSize32)
-> ByteSize32 -> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
ByteSize32
    (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32
maxBlockBodySize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
forall a. Num a => a
fixedBlockBodyOverhead
  where
    maxBlockBodySize :: Word32
maxBlockBodySize = NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams NewEpochState era
tickedShelleyLedgerState PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxBBSizeL

txInBlockSize ::
     (ShelleyCompatible proto era, MaxTxSizeUTxO era)
  => TickedLedgerState (ShelleyBlock proto era)
  -> GenTx (ShelleyBlock proto era)
  -> V.Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
txInBlockSize :: forall proto era.
(ShelleyCompatible proto era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
txInBlockSize TickedLedgerState (ShelleyBlock proto era)
st (ShelleyTx TxId
_txid Tx era
tx') =
    ApplyTxError era
-> Maybe (IgnoringOverflow ByteSize32)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
forall era a.
ApplyTxError era -> Maybe a -> Validation (TxErrorSG era) a
validateMaybe (Integer -> Integer -> ApplyTxError era
forall era.
MaxTxSizeUTxO era =>
Integer -> Integer -> ApplyTxError era
maxTxSizeUTxO Integer
txsz Integer
limit) (Maybe (IgnoringOverflow ByteSize32)
 -> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32))
-> Maybe (IgnoringOverflow ByteSize32)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
forall a b. (a -> b) -> a -> b
$ do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Integer
txsz Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
limit
      IgnoringOverflow ByteSize32 -> Maybe (IgnoringOverflow ByteSize32)
forall a. a -> Maybe a
Just (IgnoringOverflow ByteSize32
 -> Maybe (IgnoringOverflow ByteSize32))
-> IgnoringOverflow ByteSize32
-> Maybe (IgnoringOverflow ByteSize32)
forall a b. (a -> b) -> a -> b
$ ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
IgnoringOverflow (ByteSize32 -> IgnoringOverflow ByteSize32)
-> ByteSize32 -> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
ByteSize32 (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$ Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
txsz Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
forall a. Num a => a
perTxOverhead
  where
    txsz :: Integer
txsz = Tx era
tx' Tx era -> Getting Integer (Tx era) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer (Tx era) Integer
forall era. EraTx era => SimpleGetter (Tx era) Integer
SimpleGetter (Tx era) Integer
sizeTxF

    pparams :: PParams era
pparams = NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams (NewEpochState era -> PParams era)
-> NewEpochState era -> PParams era
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
st
    limit :: Integer
limit   = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era
pparams PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
L.ppMaxTxSizeL) :: Integer

class MaxTxSizeUTxO era where
  maxTxSizeUTxO ::
       Integer
       -- ^ Actual transaction size
    -> Integer
       -- ^ Maximum transaction size
    -> SL.ApplyTxError era

instance MaxTxSizeUTxO ShelleyEra where
  maxTxSizeUTxO :: Integer -> Integer -> ApplyTxError ShelleyEra
maxTxSizeUTxO Integer
txSize Integer
txSizeLimit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" ShelleyEra))
-> ApplyTxError ShelleyEra
NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
-> ApplyTxError ShelleyEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
 -> ApplyTxError ShelleyEra)
-> (ShelleyLedgerPredFailure ShelleyEra
    -> NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
-> ShelleyLedgerPredFailure ShelleyEra
-> ApplyTxError ShelleyEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure ShelleyEra
-> NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ShelleyLedgerPredFailure ShelleyEra -> ApplyTxError ShelleyEra)
-> ShelleyLedgerPredFailure ShelleyEra -> ApplyTxError ShelleyEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" ShelleyEra)
-> ShelleyLedgerPredFailure ShelleyEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
ShelleyEra.UtxowFailure
    (PredicateFailure (EraRule "UTXOW" ShelleyEra)
 -> ShelleyLedgerPredFailure ShelleyEra)
-> PredicateFailure (EraRule "UTXOW" ShelleyEra)
-> ShelleyLedgerPredFailure ShelleyEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" ShelleyEra)
-> ShelleyUtxowPredFailure ShelleyEra
forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
ShelleyEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" ShelleyEra)
 -> ShelleyUtxowPredFailure ShelleyEra)
-> PredicateFailure (EraRule "UTXO" ShelleyEra)
-> ShelleyUtxowPredFailure ShelleyEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ Integer -> ShelleyUtxoPredFailure ShelleyEra
forall era. Mismatch 'RelLTEQ Integer -> ShelleyUtxoPredFailure era
ShelleyEra.MaxTxSizeUTxO
    (Mismatch 'RelLTEQ Integer -> ShelleyUtxoPredFailure ShelleyEra)
-> Mismatch 'RelLTEQ Integer -> ShelleyUtxoPredFailure ShelleyEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: Integer
mismatchSupplied = Integer
txSize
                 , mismatchExpected :: Integer
mismatchExpected = Integer
txSizeLimit }

instance MaxTxSizeUTxO AllegraEra where
  maxTxSizeUTxO :: Integer -> Integer -> ApplyTxError AllegraEra
maxTxSizeUTxO Integer
txSize Integer
txSizeLimit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" AllegraEra))
-> ApplyTxError AllegraEra
NonEmpty (ShelleyLedgerPredFailure AllegraEra)
-> ApplyTxError AllegraEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ShelleyLedgerPredFailure AllegraEra)
 -> ApplyTxError AllegraEra)
-> (ShelleyLedgerPredFailure AllegraEra
    -> NonEmpty (ShelleyLedgerPredFailure AllegraEra))
-> ShelleyLedgerPredFailure AllegraEra
-> ApplyTxError AllegraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure AllegraEra
-> NonEmpty (ShelleyLedgerPredFailure AllegraEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ShelleyLedgerPredFailure AllegraEra -> ApplyTxError AllegraEra)
-> ShelleyLedgerPredFailure AllegraEra -> ApplyTxError AllegraEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" AllegraEra)
-> ShelleyLedgerPredFailure AllegraEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
ShelleyEra.UtxowFailure
    (PredicateFailure (EraRule "UTXOW" AllegraEra)
 -> ShelleyLedgerPredFailure AllegraEra)
-> PredicateFailure (EraRule "UTXOW" AllegraEra)
-> ShelleyLedgerPredFailure AllegraEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" AllegraEra)
-> ShelleyUtxowPredFailure AllegraEra
forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
ShelleyEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" AllegraEra)
 -> ShelleyUtxowPredFailure AllegraEra)
-> PredicateFailure (EraRule "UTXO" AllegraEra)
-> ShelleyUtxowPredFailure AllegraEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ Integer -> AllegraUtxoPredFailure AllegraEra
forall era. Mismatch 'RelLTEQ Integer -> AllegraUtxoPredFailure era
AllegraEra.MaxTxSizeUTxO
    (Mismatch 'RelLTEQ Integer -> AllegraUtxoPredFailure AllegraEra)
-> Mismatch 'RelLTEQ Integer -> AllegraUtxoPredFailure AllegraEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: Integer
mismatchSupplied = Integer
txSize
                 , mismatchExpected :: Integer
mismatchExpected = Integer
txSizeLimit }

instance MaxTxSizeUTxO MaryEra where
  maxTxSizeUTxO :: Integer -> Integer -> ApplyTxError MaryEra
maxTxSizeUTxO Integer
txSize Integer
txSizeLimit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" MaryEra))
-> ApplyTxError MaryEra
NonEmpty (ShelleyLedgerPredFailure MaryEra) -> ApplyTxError MaryEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ShelleyLedgerPredFailure MaryEra)
 -> ApplyTxError MaryEra)
-> (ShelleyLedgerPredFailure MaryEra
    -> NonEmpty (ShelleyLedgerPredFailure MaryEra))
-> ShelleyLedgerPredFailure MaryEra
-> ApplyTxError MaryEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure MaryEra
-> NonEmpty (ShelleyLedgerPredFailure MaryEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ShelleyLedgerPredFailure MaryEra -> ApplyTxError MaryEra)
-> ShelleyLedgerPredFailure MaryEra -> ApplyTxError MaryEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" MaryEra)
-> ShelleyLedgerPredFailure MaryEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
ShelleyEra.UtxowFailure
    (PredicateFailure (EraRule "UTXOW" MaryEra)
 -> ShelleyLedgerPredFailure MaryEra)
-> PredicateFailure (EraRule "UTXOW" MaryEra)
-> ShelleyLedgerPredFailure MaryEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" MaryEra)
-> ShelleyUtxowPredFailure MaryEra
forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
ShelleyEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" MaryEra)
 -> ShelleyUtxowPredFailure MaryEra)
-> PredicateFailure (EraRule "UTXO" MaryEra)
-> ShelleyUtxowPredFailure MaryEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ Integer -> AllegraUtxoPredFailure MaryEra
forall era. Mismatch 'RelLTEQ Integer -> AllegraUtxoPredFailure era
AllegraEra.MaxTxSizeUTxO
    (Mismatch 'RelLTEQ Integer -> AllegraUtxoPredFailure MaryEra)
-> Mismatch 'RelLTEQ Integer -> AllegraUtxoPredFailure MaryEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: Integer
mismatchSupplied = Integer
txSize
                 , mismatchExpected :: Integer
mismatchExpected = Integer
txSizeLimit }

instance MaxTxSizeUTxO AlonzoEra where
  maxTxSizeUTxO :: Integer -> Integer -> ApplyTxError AlonzoEra
maxTxSizeUTxO Integer
txSize Integer
txSizeLimit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" AlonzoEra))
-> ApplyTxError AlonzoEra
NonEmpty (ShelleyLedgerPredFailure AlonzoEra)
-> ApplyTxError AlonzoEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ShelleyLedgerPredFailure AlonzoEra)
 -> ApplyTxError AlonzoEra)
-> (ShelleyLedgerPredFailure AlonzoEra
    -> NonEmpty (ShelleyLedgerPredFailure AlonzoEra))
-> ShelleyLedgerPredFailure AlonzoEra
-> ApplyTxError AlonzoEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure AlonzoEra
-> NonEmpty (ShelleyLedgerPredFailure AlonzoEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ShelleyLedgerPredFailure AlonzoEra -> ApplyTxError AlonzoEra)
-> ShelleyLedgerPredFailure AlonzoEra -> ApplyTxError AlonzoEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" AlonzoEra)
-> ShelleyLedgerPredFailure AlonzoEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
ShelleyEra.UtxowFailure
    (PredicateFailure (EraRule "UTXOW" AlonzoEra)
 -> ShelleyLedgerPredFailure AlonzoEra)
-> PredicateFailure (EraRule "UTXOW" AlonzoEra)
-> ShelleyLedgerPredFailure AlonzoEra
forall a b. (a -> b) -> a -> b
$ ShelleyUtxowPredFailure AlonzoEra
-> AlonzoUtxowPredFailure AlonzoEra
forall era.
ShelleyUtxowPredFailure era -> AlonzoUtxowPredFailure era
AlonzoEra.ShelleyInAlonzoUtxowPredFailure
    (ShelleyUtxowPredFailure AlonzoEra
 -> AlonzoUtxowPredFailure AlonzoEra)
-> ShelleyUtxowPredFailure AlonzoEra
-> AlonzoUtxowPredFailure AlonzoEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" AlonzoEra)
-> ShelleyUtxowPredFailure AlonzoEra
forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
ShelleyEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" AlonzoEra)
 -> ShelleyUtxowPredFailure AlonzoEra)
-> PredicateFailure (EraRule "UTXO" AlonzoEra)
-> ShelleyUtxowPredFailure AlonzoEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ Integer -> AlonzoUtxoPredFailure AlonzoEra
forall era. Mismatch 'RelLTEQ Integer -> AlonzoUtxoPredFailure era
AlonzoEra.MaxTxSizeUTxO
    (Mismatch 'RelLTEQ Integer -> AlonzoUtxoPredFailure AlonzoEra)
-> Mismatch 'RelLTEQ Integer -> AlonzoUtxoPredFailure AlonzoEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: Integer
mismatchSupplied = Integer
txSize
                 , mismatchExpected :: Integer
mismatchExpected = Integer
txSizeLimit }

instance MaxTxSizeUTxO BabbageEra where
  maxTxSizeUTxO :: Integer -> Integer -> ApplyTxError BabbageEra
maxTxSizeUTxO Integer
txSize Integer
txSizeLimit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" BabbageEra))
-> ApplyTxError BabbageEra
NonEmpty (ShelleyLedgerPredFailure BabbageEra)
-> ApplyTxError BabbageEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ShelleyLedgerPredFailure BabbageEra)
 -> ApplyTxError BabbageEra)
-> (ShelleyLedgerPredFailure BabbageEra
    -> NonEmpty (ShelleyLedgerPredFailure BabbageEra))
-> ShelleyLedgerPredFailure BabbageEra
-> ApplyTxError BabbageEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure BabbageEra
-> NonEmpty (ShelleyLedgerPredFailure BabbageEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ShelleyLedgerPredFailure BabbageEra -> ApplyTxError BabbageEra)
-> ShelleyLedgerPredFailure BabbageEra -> ApplyTxError BabbageEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" BabbageEra)
-> ShelleyLedgerPredFailure BabbageEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
ShelleyEra.UtxowFailure
    (PredicateFailure (EraRule "UTXOW" BabbageEra)
 -> ShelleyLedgerPredFailure BabbageEra)
-> PredicateFailure (EraRule "UTXOW" BabbageEra)
-> ShelleyLedgerPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" BabbageEra)
-> BabbageUtxowPredFailure BabbageEra
forall era.
PredicateFailure (EraRule "UTXO" era)
-> BabbageUtxowPredFailure era
BabbageEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" BabbageEra)
 -> BabbageUtxowPredFailure BabbageEra)
-> PredicateFailure (EraRule "UTXO" BabbageEra)
-> BabbageUtxowPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ AlonzoUtxoPredFailure BabbageEra
-> BabbageUtxoPredFailure BabbageEra
forall era. AlonzoUtxoPredFailure era -> BabbageUtxoPredFailure era
BabbageEra.AlonzoInBabbageUtxoPredFailure
    (AlonzoUtxoPredFailure BabbageEra
 -> BabbageUtxoPredFailure BabbageEra)
-> AlonzoUtxoPredFailure BabbageEra
-> BabbageUtxoPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ Integer -> AlonzoUtxoPredFailure BabbageEra
forall era. Mismatch 'RelLTEQ Integer -> AlonzoUtxoPredFailure era
AlonzoEra.MaxTxSizeUTxO
    (Mismatch 'RelLTEQ Integer -> AlonzoUtxoPredFailure BabbageEra)
-> Mismatch 'RelLTEQ Integer -> AlonzoUtxoPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: Integer
mismatchSupplied = Integer
txSize
                 , mismatchExpected :: Integer
mismatchExpected = Integer
txSizeLimit }

instance MaxTxSizeUTxO ConwayEra where
  maxTxSizeUTxO :: Integer -> Integer -> ApplyTxError ConwayEra
maxTxSizeUTxO Integer
txSize Integer
txSizeLimit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra))
-> ApplyTxError ConwayEra
NonEmpty (ConwayLedgerPredFailure ConwayEra)
-> ApplyTxError ConwayEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ConwayLedgerPredFailure ConwayEra)
 -> ApplyTxError ConwayEra)
-> (ConwayLedgerPredFailure ConwayEra
    -> NonEmpty (ConwayLedgerPredFailure ConwayEra))
-> ConwayLedgerPredFailure ConwayEra
-> ApplyTxError ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayLedgerPredFailure ConwayEra
-> NonEmpty (ConwayLedgerPredFailure ConwayEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ConwayLedgerPredFailure ConwayEra -> ApplyTxError ConwayEra)
-> ConwayLedgerPredFailure ConwayEra -> ApplyTxError ConwayEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" ConwayEra)
-> ConwayLedgerPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ConwayLedgerPredFailure era
ConwayEra.ConwayUtxowFailure
    (PredicateFailure (EraRule "UTXOW" ConwayEra)
 -> ConwayLedgerPredFailure ConwayEra)
-> PredicateFailure (EraRule "UTXOW" ConwayEra)
-> ConwayLedgerPredFailure ConwayEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" ConwayEra)
-> ConwayUtxowPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "UTXO" era) -> ConwayUtxowPredFailure era
ConwayEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" ConwayEra)
 -> ConwayUtxowPredFailure ConwayEra)
-> PredicateFailure (EraRule "UTXO" ConwayEra)
-> ConwayUtxowPredFailure ConwayEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ Integer -> ConwayUtxoPredFailure ConwayEra
forall era. Mismatch 'RelLTEQ Integer -> ConwayUtxoPredFailure era
ConwayEra.MaxTxSizeUTxO
    (Mismatch 'RelLTEQ Integer -> ConwayUtxoPredFailure ConwayEra)
-> Mismatch 'RelLTEQ Integer -> ConwayUtxoPredFailure ConwayEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: Integer
mismatchSupplied = Integer
txSize
                 , mismatchExpected :: Integer
mismatchExpected = Integer
txSizeLimit }

-----

instance ShelleyCompatible p ShelleyEra => TxLimits (ShelleyBlock p ShelleyEra) where
  type TxMeasure (ShelleyBlock p ShelleyEra) = IgnoringOverflow ByteSize32
  txMeasure :: LedgerConfig (ShelleyBlock p ShelleyEra)
-> TickedLedgerState (ShelleyBlock p ShelleyEra)
-> GenTx (ShelleyBlock p ShelleyEra)
-> Except
     (ApplyTxErr (ShelleyBlock p ShelleyEra))
     (TxMeasure (ShelleyBlock p ShelleyEra))
txMeasure              LedgerConfig (ShelleyBlock p ShelleyEra)
_cfg TickedLedgerState (ShelleyBlock p ShelleyEra)
st GenTx (ShelleyBlock p ShelleyEra)
tx = Validation
  (TxErrorSG ShelleyEra) (TxMeasure (ShelleyBlock p ShelleyEra))
-> Except
     (ApplyTxError ShelleyEra) (TxMeasure (ShelleyBlock p ShelleyEra))
forall era a.
Validation (TxErrorSG era) a -> Except (ApplyTxError era) a
runValidation (Validation
   (TxErrorSG ShelleyEra) (TxMeasure (ShelleyBlock p ShelleyEra))
 -> Except
      (ApplyTxError ShelleyEra) (TxMeasure (ShelleyBlock p ShelleyEra)))
-> Validation
     (TxErrorSG ShelleyEra) (TxMeasure (ShelleyBlock p ShelleyEra))
-> Except
     (ApplyTxError ShelleyEra) (TxMeasure (ShelleyBlock p ShelleyEra))
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock p ShelleyEra)
-> GenTx (ShelleyBlock p ShelleyEra)
-> Validation (TxErrorSG ShelleyEra) (IgnoringOverflow ByteSize32)
forall proto era.
(ShelleyCompatible proto era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
txInBlockSize TickedLedgerState (ShelleyBlock p ShelleyEra)
st GenTx (ShelleyBlock p ShelleyEra)
tx
  blockCapacityTxMeasure :: LedgerConfig (ShelleyBlock p ShelleyEra)
-> TickedLedgerState (ShelleyBlock p ShelleyEra)
-> TxMeasure (ShelleyBlock p ShelleyEra)
blockCapacityTxMeasure LedgerConfig (ShelleyBlock p ShelleyEra)
_cfg       = TickedLedgerState (ShelleyBlock p ShelleyEra)
-> IgnoringOverflow ByteSize32
TickedLedgerState (ShelleyBlock p ShelleyEra)
-> TxMeasure (ShelleyBlock p ShelleyEra)
forall proto era.
ShelleyCompatible proto era =>
TickedLedgerState (ShelleyBlock proto era)
-> IgnoringOverflow ByteSize32
txsMaxBytes

instance ShelleyCompatible p AllegraEra => TxLimits (ShelleyBlock p AllegraEra) where
  type TxMeasure (ShelleyBlock p AllegraEra) = IgnoringOverflow ByteSize32
  txMeasure :: LedgerConfig (ShelleyBlock p AllegraEra)
-> TickedLedgerState (ShelleyBlock p AllegraEra)
-> GenTx (ShelleyBlock p AllegraEra)
-> Except
     (ApplyTxErr (ShelleyBlock p AllegraEra))
     (TxMeasure (ShelleyBlock p AllegraEra))
txMeasure              LedgerConfig (ShelleyBlock p AllegraEra)
_cfg TickedLedgerState (ShelleyBlock p AllegraEra)
st GenTx (ShelleyBlock p AllegraEra)
tx = Validation
  (TxErrorSG AllegraEra) (TxMeasure (ShelleyBlock p AllegraEra))
-> Except
     (ApplyTxError AllegraEra) (TxMeasure (ShelleyBlock p AllegraEra))
forall era a.
Validation (TxErrorSG era) a -> Except (ApplyTxError era) a
runValidation (Validation
   (TxErrorSG AllegraEra) (TxMeasure (ShelleyBlock p AllegraEra))
 -> Except
      (ApplyTxError AllegraEra) (TxMeasure (ShelleyBlock p AllegraEra)))
-> Validation
     (TxErrorSG AllegraEra) (TxMeasure (ShelleyBlock p AllegraEra))
-> Except
     (ApplyTxError AllegraEra) (TxMeasure (ShelleyBlock p AllegraEra))
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock p AllegraEra)
-> GenTx (ShelleyBlock p AllegraEra)
-> Validation (TxErrorSG AllegraEra) (IgnoringOverflow ByteSize32)
forall proto era.
(ShelleyCompatible proto era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
txInBlockSize TickedLedgerState (ShelleyBlock p AllegraEra)
st GenTx (ShelleyBlock p AllegraEra)
tx
  blockCapacityTxMeasure :: LedgerConfig (ShelleyBlock p AllegraEra)
-> TickedLedgerState (ShelleyBlock p AllegraEra)
-> TxMeasure (ShelleyBlock p AllegraEra)
blockCapacityTxMeasure LedgerConfig (ShelleyBlock p AllegraEra)
_cfg       = TickedLedgerState (ShelleyBlock p AllegraEra)
-> IgnoringOverflow ByteSize32
TickedLedgerState (ShelleyBlock p AllegraEra)
-> TxMeasure (ShelleyBlock p AllegraEra)
forall proto era.
ShelleyCompatible proto era =>
TickedLedgerState (ShelleyBlock proto era)
-> IgnoringOverflow ByteSize32
txsMaxBytes

instance ShelleyCompatible p MaryEra => TxLimits (ShelleyBlock p MaryEra) where
  type TxMeasure (ShelleyBlock p MaryEra) = IgnoringOverflow ByteSize32
  txMeasure :: LedgerConfig (ShelleyBlock p MaryEra)
-> TickedLedgerState (ShelleyBlock p MaryEra)
-> GenTx (ShelleyBlock p MaryEra)
-> Except
     (ApplyTxErr (ShelleyBlock p MaryEra))
     (TxMeasure (ShelleyBlock p MaryEra))
txMeasure              LedgerConfig (ShelleyBlock p MaryEra)
_cfg TickedLedgerState (ShelleyBlock p MaryEra)
st GenTx (ShelleyBlock p MaryEra)
tx = Validation (TxErrorSG MaryEra) (TxMeasure (ShelleyBlock p MaryEra))
-> Except
     (ApplyTxError MaryEra) (TxMeasure (ShelleyBlock p MaryEra))
forall era a.
Validation (TxErrorSG era) a -> Except (ApplyTxError era) a
runValidation (Validation
   (TxErrorSG MaryEra) (TxMeasure (ShelleyBlock p MaryEra))
 -> Except
      (ApplyTxError MaryEra) (TxMeasure (ShelleyBlock p MaryEra)))
-> Validation
     (TxErrorSG MaryEra) (TxMeasure (ShelleyBlock p MaryEra))
-> Except
     (ApplyTxError MaryEra) (TxMeasure (ShelleyBlock p MaryEra))
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock p MaryEra)
-> GenTx (ShelleyBlock p MaryEra)
-> Validation (TxErrorSG MaryEra) (IgnoringOverflow ByteSize32)
forall proto era.
(ShelleyCompatible proto era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
txInBlockSize TickedLedgerState (ShelleyBlock p MaryEra)
st GenTx (ShelleyBlock p MaryEra)
tx
  blockCapacityTxMeasure :: LedgerConfig (ShelleyBlock p MaryEra)
-> TickedLedgerState (ShelleyBlock p MaryEra)
-> TxMeasure (ShelleyBlock p MaryEra)
blockCapacityTxMeasure LedgerConfig (ShelleyBlock p MaryEra)
_cfg       = TickedLedgerState (ShelleyBlock p MaryEra)
-> IgnoringOverflow ByteSize32
TickedLedgerState (ShelleyBlock p MaryEra)
-> TxMeasure (ShelleyBlock p MaryEra)
forall proto era.
ShelleyCompatible proto era =>
TickedLedgerState (ShelleyBlock proto era)
-> IgnoringOverflow ByteSize32
txsMaxBytes

-----

data AlonzoMeasure = AlonzoMeasure {
    AlonzoMeasure -> IgnoringOverflow ByteSize32
byteSize :: !(IgnoringOverflow ByteSize32)
  , AlonzoMeasure -> ExUnits' Natural
exUnits  :: !(ExUnits' Natural)
  } deriving stock (AlonzoMeasure -> AlonzoMeasure -> Bool
(AlonzoMeasure -> AlonzoMeasure -> Bool)
-> (AlonzoMeasure -> AlonzoMeasure -> Bool) -> Eq AlonzoMeasure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AlonzoMeasure -> AlonzoMeasure -> Bool
== :: AlonzoMeasure -> AlonzoMeasure -> Bool
$c/= :: AlonzoMeasure -> AlonzoMeasure -> Bool
/= :: AlonzoMeasure -> AlonzoMeasure -> Bool
Eq, (forall x. AlonzoMeasure -> Rep AlonzoMeasure x)
-> (forall x. Rep AlonzoMeasure x -> AlonzoMeasure)
-> Generic AlonzoMeasure
forall x. Rep AlonzoMeasure x -> AlonzoMeasure
forall x. AlonzoMeasure -> Rep AlonzoMeasure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AlonzoMeasure -> Rep AlonzoMeasure x
from :: forall x. AlonzoMeasure -> Rep AlonzoMeasure x
$cto :: forall x. Rep AlonzoMeasure x -> AlonzoMeasure
to :: forall x. Rep AlonzoMeasure x -> AlonzoMeasure
Generic, Int -> AlonzoMeasure -> ShowS
[AlonzoMeasure] -> ShowS
AlonzoMeasure -> String
(Int -> AlonzoMeasure -> ShowS)
-> (AlonzoMeasure -> String)
-> ([AlonzoMeasure] -> ShowS)
-> Show AlonzoMeasure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AlonzoMeasure -> ShowS
showsPrec :: Int -> AlonzoMeasure -> ShowS
$cshow :: AlonzoMeasure -> String
show :: AlonzoMeasure -> String
$cshowList :: [AlonzoMeasure] -> ShowS
showList :: [AlonzoMeasure] -> ShowS
Show)
    deriving anyclass (Context -> AlonzoMeasure -> IO (Maybe ThunkInfo)
Proxy AlonzoMeasure -> String
(Context -> AlonzoMeasure -> IO (Maybe ThunkInfo))
-> (Context -> AlonzoMeasure -> IO (Maybe ThunkInfo))
-> (Proxy AlonzoMeasure -> String)
-> NoThunks AlonzoMeasure
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> AlonzoMeasure -> IO (Maybe ThunkInfo)
noThunks :: Context -> AlonzoMeasure -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> AlonzoMeasure -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> AlonzoMeasure -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy AlonzoMeasure -> String
showTypeOf :: Proxy AlonzoMeasure -> String
NoThunks)
    deriving (Eq AlonzoMeasure
AlonzoMeasure
Eq AlonzoMeasure =>
AlonzoMeasure
-> (AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure)
-> (AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure)
-> (AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure)
-> Measure AlonzoMeasure
AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
forall a.
Eq a =>
a -> (a -> a -> a) -> (a -> a -> a) -> (a -> a -> a) -> Measure a
$czero :: AlonzoMeasure
zero :: AlonzoMeasure
$cplus :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
plus :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
$cmin :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
min :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
$cmax :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
max :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
Measure)
         via (InstantiatedAt Generic AlonzoMeasure)

instance HasByteSize AlonzoMeasure where
  txMeasureByteSize :: AlonzoMeasure -> ByteSize32
txMeasureByteSize = IgnoringOverflow ByteSize32 -> ByteSize32
forall a. IgnoringOverflow a -> a
unIgnoringOverflow (IgnoringOverflow ByteSize32 -> ByteSize32)
-> (AlonzoMeasure -> IgnoringOverflow ByteSize32)
-> AlonzoMeasure
-> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoMeasure -> IgnoringOverflow ByteSize32
byteSize

instance Semigroup AlonzoMeasure where
  AlonzoMeasure IgnoringOverflow ByteSize32
b1 ExUnits' Natural
e1 <> :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
<> AlonzoMeasure IgnoringOverflow ByteSize32
b2 ExUnits' Natural
e2 =
    IgnoringOverflow ByteSize32 -> ExUnits' Natural -> AlonzoMeasure
AlonzoMeasure (IgnoringOverflow ByteSize32
b1 IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32 -> IgnoringOverflow ByteSize32
forall a. Semigroup a => a -> a -> a
<> IgnoringOverflow ByteSize32
b2) (ExUnits' Natural
e1 ExUnits' Natural -> ExUnits' Natural -> ExUnits' Natural
forall a. Semigroup a => a -> a -> a
<> ExUnits' Natural
e2)

instance Monoid AlonzoMeasure where
  mappend :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
mappend = AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: AlonzoMeasure
mempty = IgnoringOverflow ByteSize32 -> ExUnits' Natural -> AlonzoMeasure
AlonzoMeasure IgnoringOverflow ByteSize32
forall a. Monoid a => a
mempty ExUnits' Natural
forall a. Monoid a => a
mempty

instance TxMeasureMetrics AlonzoMeasure where
  txMeasureMetricTxSizeBytes :: AlonzoMeasure -> ByteSize32
txMeasureMetricTxSizeBytes = IgnoringOverflow ByteSize32 -> ByteSize32
forall msr. TxMeasureMetrics msr => msr -> ByteSize32
txMeasureMetricTxSizeBytes (IgnoringOverflow ByteSize32 -> ByteSize32)
-> (AlonzoMeasure -> IgnoringOverflow ByteSize32)
-> AlonzoMeasure
-> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoMeasure -> IgnoringOverflow ByteSize32
byteSize
  txMeasureMetricExUnitsMemory :: AlonzoMeasure -> Natural
txMeasureMetricExUnitsMemory = ExUnits' Natural -> Natural
forall a. ExUnits' a -> a
exUnitsMem' (ExUnits' Natural -> Natural)
-> (AlonzoMeasure -> ExUnits' Natural) -> AlonzoMeasure -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoMeasure -> ExUnits' Natural
exUnits
  txMeasureMetricExUnitsSteps :: AlonzoMeasure -> Natural
txMeasureMetricExUnitsSteps = ExUnits' Natural -> Natural
forall a. ExUnits' a -> a
exUnitsSteps' (ExUnits' Natural -> Natural)
-> (AlonzoMeasure -> ExUnits' Natural) -> AlonzoMeasure -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoMeasure -> ExUnits' Natural
exUnits
  txMeasureMetricRefScriptsSizeBytes :: AlonzoMeasure -> ByteSize32
txMeasureMetricRefScriptsSizeBytes AlonzoMeasure
_ = ByteSize32
forall a. Monoid a => a
mempty

fromExUnits :: ExUnits -> ExUnits' Natural
fromExUnits :: ExUnits -> ExUnits' Natural
fromExUnits = ExUnits -> ExUnits' Natural
unWrapExUnits

blockCapacityAlonzoMeasure ::
     forall proto era.
     (ShelleyCompatible proto era, L.AlonzoEraPParams era)
  => TickedLedgerState (ShelleyBlock proto era)
  -> AlonzoMeasure
blockCapacityAlonzoMeasure :: forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era) =>
TickedLedgerState (ShelleyBlock proto era) -> AlonzoMeasure
blockCapacityAlonzoMeasure TickedLedgerState (ShelleyBlock proto era)
ledgerState =
    AlonzoMeasure {
        byteSize :: IgnoringOverflow ByteSize32
byteSize = TickedLedgerState (ShelleyBlock proto era)
-> IgnoringOverflow ByteSize32
forall proto era.
ShelleyCompatible proto era =>
TickedLedgerState (ShelleyBlock proto era)
-> IgnoringOverflow ByteSize32
txsMaxBytes TickedLedgerState (ShelleyBlock proto era)
ledgerState
      , exUnits :: ExUnits' Natural
exUnits  = ExUnits -> ExUnits' Natural
fromExUnits (ExUnits -> ExUnits' Natural) -> ExUnits -> ExUnits' Natural
forall a b. (a -> b) -> a -> b
$ PParams era
pparams PParams era -> Getting ExUnits (PParams era) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams era) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxBlockExUnitsL
      }
  where
    pparams :: PParams era
pparams = NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams (NewEpochState era -> PParams era)
-> NewEpochState era -> PParams era
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
ledgerState

txMeasureAlonzo ::
     forall proto era.
     ( ShelleyCompatible proto era
     , L.AlonzoEraPParams era
     , L.AlonzoEraTxWits era
     , ExUnitsTooBigUTxO era
     , MaxTxSizeUTxO era
     )
  => TickedLedgerState (ShelleyBlock proto era)
  -> GenTx (ShelleyBlock proto era)
  -> V.Validation (TxErrorSG era) AlonzoMeasure
txMeasureAlonzo :: forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era,
 AlonzoEraTxWits era, ExUnitsTooBigUTxO era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) AlonzoMeasure
txMeasureAlonzo TickedLedgerState (ShelleyBlock proto era)
st tx :: GenTx (ShelleyBlock proto era)
tx@(ShelleyTx TxId
_txid Tx era
tx') =
    IgnoringOverflow ByteSize32 -> ExUnits' Natural -> AlonzoMeasure
AlonzoMeasure (IgnoringOverflow ByteSize32 -> ExUnits' Natural -> AlonzoMeasure)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
-> Validation (TxErrorSG era) (ExUnits' Natural -> AlonzoMeasure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
forall proto era.
(ShelleyCompatible proto era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
txInBlockSize TickedLedgerState (ShelleyBlock proto era)
st GenTx (ShelleyBlock proto era)
tx Validation (TxErrorSG era) (ExUnits' Natural -> AlonzoMeasure)
-> Validation (TxErrorSG era) (ExUnits' Natural)
-> Validation (TxErrorSG era) AlonzoMeasure
forall a b.
Validation (TxErrorSG era) (a -> b)
-> Validation (TxErrorSG era) a -> Validation (TxErrorSG era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Validation (TxErrorSG era) (ExUnits' Natural)
exunits
  where
    txsz :: ExUnits
txsz = Tx era -> ExUnits
forall era. (EraTx era, AlonzoEraTxWits era) => Tx era -> ExUnits
totExUnits Tx era
tx'

    pparams :: PParams era
pparams = NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams (NewEpochState era -> PParams era)
-> NewEpochState era -> PParams era
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
st
    limit :: ExUnits
limit   = PParams era
pparams PParams era -> Getting ExUnits (PParams era) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams era) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
L.ppMaxTxExUnitsL

    exunits :: Validation (TxErrorSG era) (ExUnits' Natural)
exunits =
      ApplyTxError era
-> Maybe (ExUnits' Natural)
-> Validation (TxErrorSG era) (ExUnits' Natural)
forall era a.
ApplyTxError era -> Maybe a -> Validation (TxErrorSG era) a
validateMaybe (ExUnits -> ExUnits -> ApplyTxError era
forall era.
ExUnitsTooBigUTxO era =>
ExUnits -> ExUnits -> ApplyTxError era
exUnitsTooBigUTxO ExUnits
txsz ExUnits
limit) (Maybe (ExUnits' Natural)
 -> Validation (TxErrorSG era) (ExUnits' Natural))
-> Maybe (ExUnits' Natural)
-> Validation (TxErrorSG era) (ExUnits' Natural)
forall a b. (a -> b) -> a -> b
$ do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> Bool) -> ExUnits -> ExUnits -> Bool
pointWiseExUnits Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
(<=) ExUnits
txsz ExUnits
limit
        ExUnits' Natural -> Maybe (ExUnits' Natural)
forall a. a -> Maybe a
Just (ExUnits' Natural -> Maybe (ExUnits' Natural))
-> ExUnits' Natural -> Maybe (ExUnits' Natural)
forall a b. (a -> b) -> a -> b
$ ExUnits -> ExUnits' Natural
fromExUnits ExUnits
txsz

class ExUnitsTooBigUTxO era where
  exUnitsTooBigUTxO :: ExUnits -> ExUnits -> SL.ApplyTxError era

instance ExUnitsTooBigUTxO AlonzoEra where
  exUnitsTooBigUTxO :: ExUnits -> ExUnits -> ApplyTxError AlonzoEra
exUnitsTooBigUTxO ExUnits
txsz ExUnits
limit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" AlonzoEra))
-> ApplyTxError AlonzoEra
NonEmpty (ShelleyLedgerPredFailure AlonzoEra)
-> ApplyTxError AlonzoEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ShelleyLedgerPredFailure AlonzoEra)
 -> ApplyTxError AlonzoEra)
-> (ShelleyLedgerPredFailure AlonzoEra
    -> NonEmpty (ShelleyLedgerPredFailure AlonzoEra))
-> ShelleyLedgerPredFailure AlonzoEra
-> ApplyTxError AlonzoEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure AlonzoEra
-> NonEmpty (ShelleyLedgerPredFailure AlonzoEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ShelleyLedgerPredFailure AlonzoEra -> ApplyTxError AlonzoEra)
-> ShelleyLedgerPredFailure AlonzoEra -> ApplyTxError AlonzoEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" AlonzoEra)
-> ShelleyLedgerPredFailure AlonzoEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
ShelleyEra.UtxowFailure
    (PredicateFailure (EraRule "UTXOW" AlonzoEra)
 -> ShelleyLedgerPredFailure AlonzoEra)
-> PredicateFailure (EraRule "UTXOW" AlonzoEra)
-> ShelleyLedgerPredFailure AlonzoEra
forall a b. (a -> b) -> a -> b
$ ShelleyUtxowPredFailure AlonzoEra
-> AlonzoUtxowPredFailure AlonzoEra
forall era.
ShelleyUtxowPredFailure era -> AlonzoUtxowPredFailure era
AlonzoEra.ShelleyInAlonzoUtxowPredFailure
    (ShelleyUtxowPredFailure AlonzoEra
 -> AlonzoUtxowPredFailure AlonzoEra)
-> ShelleyUtxowPredFailure AlonzoEra
-> AlonzoUtxowPredFailure AlonzoEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" AlonzoEra)
-> ShelleyUtxowPredFailure AlonzoEra
forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
ShelleyEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" AlonzoEra)
 -> ShelleyUtxowPredFailure AlonzoEra)
-> PredicateFailure (EraRule "UTXO" AlonzoEra)
-> ShelleyUtxowPredFailure AlonzoEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure AlonzoEra
forall era. Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure era
AlonzoEra.ExUnitsTooBigUTxO
    (Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure AlonzoEra)
-> Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure AlonzoEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: ExUnits
mismatchSupplied = ExUnits
txsz
                 , mismatchExpected :: ExUnits
mismatchExpected = ExUnits
limit }

instance ExUnitsTooBigUTxO BabbageEra where
  exUnitsTooBigUTxO :: ExUnits -> ExUnits -> ApplyTxError BabbageEra
exUnitsTooBigUTxO ExUnits
txsz ExUnits
limit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" BabbageEra))
-> ApplyTxError BabbageEra
NonEmpty (ShelleyLedgerPredFailure BabbageEra)
-> ApplyTxError BabbageEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ShelleyLedgerPredFailure BabbageEra)
 -> ApplyTxError BabbageEra)
-> (ShelleyLedgerPredFailure BabbageEra
    -> NonEmpty (ShelleyLedgerPredFailure BabbageEra))
-> ShelleyLedgerPredFailure BabbageEra
-> ApplyTxError BabbageEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure BabbageEra
-> NonEmpty (ShelleyLedgerPredFailure BabbageEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ShelleyLedgerPredFailure BabbageEra -> ApplyTxError BabbageEra)
-> ShelleyLedgerPredFailure BabbageEra -> ApplyTxError BabbageEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" BabbageEra)
-> ShelleyLedgerPredFailure BabbageEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
ShelleyEra.UtxowFailure
    (PredicateFailure (EraRule "UTXOW" BabbageEra)
 -> ShelleyLedgerPredFailure BabbageEra)
-> PredicateFailure (EraRule "UTXOW" BabbageEra)
-> ShelleyLedgerPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ AlonzoUtxowPredFailure BabbageEra
-> BabbageUtxowPredFailure BabbageEra
forall era.
AlonzoUtxowPredFailure era -> BabbageUtxowPredFailure era
BabbageEra.AlonzoInBabbageUtxowPredFailure
    (AlonzoUtxowPredFailure BabbageEra
 -> BabbageUtxowPredFailure BabbageEra)
-> AlonzoUtxowPredFailure BabbageEra
-> BabbageUtxowPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ ShelleyUtxowPredFailure BabbageEra
-> AlonzoUtxowPredFailure BabbageEra
forall era.
ShelleyUtxowPredFailure era -> AlonzoUtxowPredFailure era
AlonzoEra.ShelleyInAlonzoUtxowPredFailure
    (ShelleyUtxowPredFailure BabbageEra
 -> AlonzoUtxowPredFailure BabbageEra)
-> ShelleyUtxowPredFailure BabbageEra
-> AlonzoUtxowPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" BabbageEra)
-> ShelleyUtxowPredFailure BabbageEra
forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
ShelleyEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" BabbageEra)
 -> ShelleyUtxowPredFailure BabbageEra)
-> PredicateFailure (EraRule "UTXO" BabbageEra)
-> ShelleyUtxowPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ AlonzoUtxoPredFailure BabbageEra
-> BabbageUtxoPredFailure BabbageEra
forall era. AlonzoUtxoPredFailure era -> BabbageUtxoPredFailure era
BabbageEra.AlonzoInBabbageUtxoPredFailure
    (AlonzoUtxoPredFailure BabbageEra
 -> BabbageUtxoPredFailure BabbageEra)
-> AlonzoUtxoPredFailure BabbageEra
-> BabbageUtxoPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure BabbageEra
forall era. Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure era
AlonzoEra.ExUnitsTooBigUTxO
    (Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure BabbageEra)
-> Mismatch 'RelLTEQ ExUnits -> AlonzoUtxoPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: ExUnits
mismatchSupplied = ExUnits
txsz
                 , mismatchExpected :: ExUnits
mismatchExpected = ExUnits
limit }

instance ExUnitsTooBigUTxO ConwayEra where
  exUnitsTooBigUTxO :: ExUnits -> ExUnits -> ApplyTxError ConwayEra
exUnitsTooBigUTxO ExUnits
txsz ExUnits
limit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra))
-> ApplyTxError ConwayEra
NonEmpty (ConwayLedgerPredFailure ConwayEra)
-> ApplyTxError ConwayEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ConwayLedgerPredFailure ConwayEra)
 -> ApplyTxError ConwayEra)
-> (ConwayLedgerPredFailure ConwayEra
    -> NonEmpty (ConwayLedgerPredFailure ConwayEra))
-> ConwayLedgerPredFailure ConwayEra
-> ApplyTxError ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayLedgerPredFailure ConwayEra
-> NonEmpty (ConwayLedgerPredFailure ConwayEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ConwayLedgerPredFailure ConwayEra -> ApplyTxError ConwayEra)
-> ConwayLedgerPredFailure ConwayEra -> ApplyTxError ConwayEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXOW" ConwayEra)
-> ConwayLedgerPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ConwayLedgerPredFailure era
ConwayEra.ConwayUtxowFailure
    (PredicateFailure (EraRule "UTXOW" ConwayEra)
 -> ConwayLedgerPredFailure ConwayEra)
-> PredicateFailure (EraRule "UTXOW" ConwayEra)
-> ConwayLedgerPredFailure ConwayEra
forall a b. (a -> b) -> a -> b
$ PredicateFailure (EraRule "UTXO" ConwayEra)
-> ConwayUtxowPredFailure ConwayEra
forall era.
PredicateFailure (EraRule "UTXO" era) -> ConwayUtxowPredFailure era
ConwayEra.UtxoFailure
    (PredicateFailure (EraRule "UTXO" ConwayEra)
 -> ConwayUtxowPredFailure ConwayEra)
-> PredicateFailure (EraRule "UTXO" ConwayEra)
-> ConwayUtxowPredFailure ConwayEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ ExUnits -> ConwayUtxoPredFailure ConwayEra
forall era. Mismatch 'RelLTEQ ExUnits -> ConwayUtxoPredFailure era
ConwayEra.ExUnitsTooBigUTxO
    (Mismatch 'RelLTEQ ExUnits -> ConwayUtxoPredFailure ConwayEra)
-> Mismatch 'RelLTEQ ExUnits -> ConwayUtxoPredFailure ConwayEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: ExUnits
mismatchSupplied = ExUnits
txsz
                 , mismatchExpected :: ExUnits
mismatchExpected = ExUnits
limit }

-----

instance ( ShelleyCompatible p AlonzoEra
         ) => TxLimits (ShelleyBlock p AlonzoEra) where

  type TxMeasure (ShelleyBlock p AlonzoEra) = AlonzoMeasure
  txMeasure :: LedgerConfig (ShelleyBlock p AlonzoEra)
-> TickedLedgerState (ShelleyBlock p AlonzoEra)
-> GenTx (ShelleyBlock p AlonzoEra)
-> Except
     (ApplyTxErr (ShelleyBlock p AlonzoEra))
     (TxMeasure (ShelleyBlock p AlonzoEra))
txMeasure              LedgerConfig (ShelleyBlock p AlonzoEra)
_cfg TickedLedgerState (ShelleyBlock p AlonzoEra)
st GenTx (ShelleyBlock p AlonzoEra)
tx = Validation
  (TxErrorSG AlonzoEra) (TxMeasure (ShelleyBlock p AlonzoEra))
-> Except
     (ApplyTxError AlonzoEra) (TxMeasure (ShelleyBlock p AlonzoEra))
forall era a.
Validation (TxErrorSG era) a -> Except (ApplyTxError era) a
runValidation (Validation
   (TxErrorSG AlonzoEra) (TxMeasure (ShelleyBlock p AlonzoEra))
 -> Except
      (ApplyTxError AlonzoEra) (TxMeasure (ShelleyBlock p AlonzoEra)))
-> Validation
     (TxErrorSG AlonzoEra) (TxMeasure (ShelleyBlock p AlonzoEra))
-> Except
     (ApplyTxError AlonzoEra) (TxMeasure (ShelleyBlock p AlonzoEra))
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock p AlonzoEra)
-> GenTx (ShelleyBlock p AlonzoEra)
-> Validation (TxErrorSG AlonzoEra) AlonzoMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era,
 AlonzoEraTxWits era, ExUnitsTooBigUTxO era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) AlonzoMeasure
txMeasureAlonzo TickedLedgerState (ShelleyBlock p AlonzoEra)
st GenTx (ShelleyBlock p AlonzoEra)
tx
  blockCapacityTxMeasure :: LedgerConfig (ShelleyBlock p AlonzoEra)
-> TickedLedgerState (ShelleyBlock p AlonzoEra)
-> TxMeasure (ShelleyBlock p AlonzoEra)
blockCapacityTxMeasure LedgerConfig (ShelleyBlock p AlonzoEra)
_cfg       = TickedLedgerState (ShelleyBlock p AlonzoEra)
-> TxMeasure (ShelleyBlock p AlonzoEra)
TickedLedgerState (ShelleyBlock p AlonzoEra) -> AlonzoMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era) =>
TickedLedgerState (ShelleyBlock proto era) -> AlonzoMeasure
blockCapacityAlonzoMeasure

-----

data ConwayMeasure = ConwayMeasure {
    ConwayMeasure -> AlonzoMeasure
alonzoMeasure  :: !AlonzoMeasure
  , ConwayMeasure -> IgnoringOverflow ByteSize32
refScriptsSize :: !(IgnoringOverflow ByteSize32)
  } deriving stock (ConwayMeasure -> ConwayMeasure -> Bool
(ConwayMeasure -> ConwayMeasure -> Bool)
-> (ConwayMeasure -> ConwayMeasure -> Bool) -> Eq ConwayMeasure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConwayMeasure -> ConwayMeasure -> Bool
== :: ConwayMeasure -> ConwayMeasure -> Bool
$c/= :: ConwayMeasure -> ConwayMeasure -> Bool
/= :: ConwayMeasure -> ConwayMeasure -> Bool
Eq, (forall x. ConwayMeasure -> Rep ConwayMeasure x)
-> (forall x. Rep ConwayMeasure x -> ConwayMeasure)
-> Generic ConwayMeasure
forall x. Rep ConwayMeasure x -> ConwayMeasure
forall x. ConwayMeasure -> Rep ConwayMeasure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ConwayMeasure -> Rep ConwayMeasure x
from :: forall x. ConwayMeasure -> Rep ConwayMeasure x
$cto :: forall x. Rep ConwayMeasure x -> ConwayMeasure
to :: forall x. Rep ConwayMeasure x -> ConwayMeasure
Generic, Int -> ConwayMeasure -> ShowS
[ConwayMeasure] -> ShowS
ConwayMeasure -> String
(Int -> ConwayMeasure -> ShowS)
-> (ConwayMeasure -> String)
-> ([ConwayMeasure] -> ShowS)
-> Show ConwayMeasure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConwayMeasure -> ShowS
showsPrec :: Int -> ConwayMeasure -> ShowS
$cshow :: ConwayMeasure -> String
show :: ConwayMeasure -> String
$cshowList :: [ConwayMeasure] -> ShowS
showList :: [ConwayMeasure] -> ShowS
Show)
    deriving anyclass (Context -> ConwayMeasure -> IO (Maybe ThunkInfo)
Proxy ConwayMeasure -> String
(Context -> ConwayMeasure -> IO (Maybe ThunkInfo))
-> (Context -> ConwayMeasure -> IO (Maybe ThunkInfo))
-> (Proxy ConwayMeasure -> String)
-> NoThunks ConwayMeasure
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ConwayMeasure -> IO (Maybe ThunkInfo)
noThunks :: Context -> ConwayMeasure -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ConwayMeasure -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ConwayMeasure -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ConwayMeasure -> String
showTypeOf :: Proxy ConwayMeasure -> String
NoThunks)
    deriving (Eq ConwayMeasure
ConwayMeasure
Eq ConwayMeasure =>
ConwayMeasure
-> (ConwayMeasure -> ConwayMeasure -> ConwayMeasure)
-> (ConwayMeasure -> ConwayMeasure -> ConwayMeasure)
-> (ConwayMeasure -> ConwayMeasure -> ConwayMeasure)
-> Measure ConwayMeasure
ConwayMeasure -> ConwayMeasure -> ConwayMeasure
forall a.
Eq a =>
a -> (a -> a -> a) -> (a -> a -> a) -> (a -> a -> a) -> Measure a
$czero :: ConwayMeasure
zero :: ConwayMeasure
$cplus :: ConwayMeasure -> ConwayMeasure -> ConwayMeasure
plus :: ConwayMeasure -> ConwayMeasure -> ConwayMeasure
$cmin :: ConwayMeasure -> ConwayMeasure -> ConwayMeasure
min :: ConwayMeasure -> ConwayMeasure -> ConwayMeasure
$cmax :: ConwayMeasure -> ConwayMeasure -> ConwayMeasure
max :: ConwayMeasure -> ConwayMeasure -> ConwayMeasure
Measure)
         via (InstantiatedAt Generic ConwayMeasure)

instance Semigroup ConwayMeasure where
  ConwayMeasure AlonzoMeasure
a1 IgnoringOverflow ByteSize32
r1 <> :: ConwayMeasure -> ConwayMeasure -> ConwayMeasure
<> ConwayMeasure AlonzoMeasure
a2 IgnoringOverflow ByteSize32
r2 =
    AlonzoMeasure -> IgnoringOverflow ByteSize32 -> ConwayMeasure
ConwayMeasure (AlonzoMeasure
a1 AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
forall a. Semigroup a => a -> a -> a
<> AlonzoMeasure
a2) (IgnoringOverflow ByteSize32
r1 IgnoringOverflow ByteSize32
-> IgnoringOverflow ByteSize32 -> IgnoringOverflow ByteSize32
forall a. Semigroup a => a -> a -> a
<> IgnoringOverflow ByteSize32
r2)

instance Monoid ConwayMeasure where
  mappend :: ConwayMeasure -> ConwayMeasure -> ConwayMeasure
mappend = ConwayMeasure -> ConwayMeasure -> ConwayMeasure
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ConwayMeasure
mempty = AlonzoMeasure -> IgnoringOverflow ByteSize32 -> ConwayMeasure
ConwayMeasure AlonzoMeasure
forall a. Monoid a => a
mempty IgnoringOverflow ByteSize32
forall a. Monoid a => a
mempty

instance HasByteSize ConwayMeasure where
  txMeasureByteSize :: ConwayMeasure -> ByteSize32
txMeasureByteSize = AlonzoMeasure -> ByteSize32
forall a. HasByteSize a => a -> ByteSize32
txMeasureByteSize (AlonzoMeasure -> ByteSize32)
-> (ConwayMeasure -> AlonzoMeasure) -> ConwayMeasure -> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayMeasure -> AlonzoMeasure
alonzoMeasure

instance TxMeasureMetrics ConwayMeasure where
  txMeasureMetricTxSizeBytes :: ConwayMeasure -> ByteSize32
txMeasureMetricTxSizeBytes = AlonzoMeasure -> ByteSize32
forall msr. TxMeasureMetrics msr => msr -> ByteSize32
txMeasureMetricTxSizeBytes (AlonzoMeasure -> ByteSize32)
-> (ConwayMeasure -> AlonzoMeasure) -> ConwayMeasure -> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayMeasure -> AlonzoMeasure
alonzoMeasure
  txMeasureMetricExUnitsMemory :: ConwayMeasure -> Natural
txMeasureMetricExUnitsMemory = AlonzoMeasure -> Natural
forall msr. TxMeasureMetrics msr => msr -> Natural
txMeasureMetricExUnitsMemory (AlonzoMeasure -> Natural)
-> (ConwayMeasure -> AlonzoMeasure) -> ConwayMeasure -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayMeasure -> AlonzoMeasure
alonzoMeasure
  txMeasureMetricExUnitsSteps :: ConwayMeasure -> Natural
txMeasureMetricExUnitsSteps = AlonzoMeasure -> Natural
forall msr. TxMeasureMetrics msr => msr -> Natural
txMeasureMetricExUnitsSteps (AlonzoMeasure -> Natural)
-> (ConwayMeasure -> AlonzoMeasure) -> ConwayMeasure -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayMeasure -> AlonzoMeasure
alonzoMeasure
  txMeasureMetricRefScriptsSizeBytes :: ConwayMeasure -> ByteSize32
txMeasureMetricRefScriptsSizeBytes =
    IgnoringOverflow ByteSize32 -> ByteSize32
forall a. IgnoringOverflow a -> a
unIgnoringOverflow (IgnoringOverflow ByteSize32 -> ByteSize32)
-> (ConwayMeasure -> IgnoringOverflow ByteSize32)
-> ConwayMeasure
-> ByteSize32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayMeasure -> IgnoringOverflow ByteSize32
refScriptsSize

blockCapacityConwayMeasure ::
     forall proto era.
     ( ShelleyCompatible proto era
     , L.AlonzoEraPParams era
     )
  => TickedLedgerState (ShelleyBlock proto era)
  -> ConwayMeasure
blockCapacityConwayMeasure :: forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era) =>
TickedLedgerState (ShelleyBlock proto era) -> ConwayMeasure
blockCapacityConwayMeasure TickedLedgerState (ShelleyBlock proto era)
st =
    ConwayMeasure {
        alonzoMeasure :: AlonzoMeasure
alonzoMeasure  = TickedLedgerState (ShelleyBlock proto era) -> AlonzoMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era) =>
TickedLedgerState (ShelleyBlock proto era) -> AlonzoMeasure
blockCapacityAlonzoMeasure TickedLedgerState (ShelleyBlock proto era)
st
      , refScriptsSize :: IgnoringOverflow ByteSize32
refScriptsSize = ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
IgnoringOverflow (ByteSize32 -> IgnoringOverflow ByteSize32)
-> ByteSize32 -> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
ByteSize32 (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$
          -- For post-Conway eras, this will become a protocol parameter.
          Int
SL.maxRefScriptSizePerBlock
      }

txMeasureConway ::
     forall proto era.
     ( ShelleyCompatible proto era
     , L.AlonzoEraTxWits era
     , L.BabbageEraTxBody era
     , ExUnitsTooBigUTxO era
     , MaxTxSizeUTxO era
     , TxRefScriptsSizeTooBig era
     )
  => TickedLedgerState (ShelleyBlock proto era)
  -> GenTx (ShelleyBlock proto era)
  -> V.Validation (TxErrorSG era) ConwayMeasure
txMeasureConway :: forall proto era.
(ShelleyCompatible proto era, AlonzoEraTxWits era,
 BabbageEraTxBody era, ExUnitsTooBigUTxO era, MaxTxSizeUTxO era,
 TxRefScriptsSizeTooBig era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) ConwayMeasure
txMeasureConway TickedLedgerState (ShelleyBlock proto era)
st tx :: GenTx (ShelleyBlock proto era)
tx@(ShelleyTx TxId
_txid Tx era
tx') =
    AlonzoMeasure -> IgnoringOverflow ByteSize32 -> ConwayMeasure
ConwayMeasure (AlonzoMeasure -> IgnoringOverflow ByteSize32 -> ConwayMeasure)
-> Validation (TxErrorSG era) AlonzoMeasure
-> Validation
     (TxErrorSG era) (IgnoringOverflow ByteSize32 -> ConwayMeasure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) AlonzoMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era,
 AlonzoEraTxWits era, ExUnitsTooBigUTxO era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) AlonzoMeasure
txMeasureAlonzo TickedLedgerState (ShelleyBlock proto era)
st GenTx (ShelleyBlock proto era)
tx Validation
  (TxErrorSG era) (IgnoringOverflow ByteSize32 -> ConwayMeasure)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
-> Validation (TxErrorSG era) ConwayMeasure
forall a b.
Validation (TxErrorSG era) (a -> b)
-> Validation (TxErrorSG era) a -> Validation (TxErrorSG era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
refScriptBytes
  where
    utxo :: UTxO era
utxo = NewEpochState era -> UTxO era
forall era. NewEpochState era -> UTxO era
SL.getUTxO (NewEpochState era -> UTxO era)
-> (TickedLedgerState (ShelleyBlock proto era)
    -> NewEpochState era)
-> TickedLedgerState (ShelleyBlock proto era)
-> UTxO era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState (TickedLedgerState (ShelleyBlock proto era) -> UTxO era)
-> TickedLedgerState (ShelleyBlock proto era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era)
st
    txsz :: Int
txsz = UTxO era -> Tx era -> Int
forall era.
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx era -> Int
SL.txNonDistinctRefScriptsSize UTxO era
utxo Tx era
tx' :: Int

    -- For post-Conway eras, this will become a protocol parameter.
    limit :: Int
limit = Int
SL.maxRefScriptSizePerTx

    refScriptBytes :: Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
refScriptBytes =
      ApplyTxError era
-> Maybe (IgnoringOverflow ByteSize32)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
forall era a.
ApplyTxError era -> Maybe a -> Validation (TxErrorSG era) a
validateMaybe (Int -> Int -> ApplyTxError era
forall era.
TxRefScriptsSizeTooBig era =>
Int -> Int -> ApplyTxError era
txRefScriptsSizeTooBig Int
txsz Int
limit) (Maybe (IgnoringOverflow ByteSize32)
 -> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32))
-> Maybe (IgnoringOverflow ByteSize32)
-> Validation (TxErrorSG era) (IgnoringOverflow ByteSize32)
forall a b. (a -> b) -> a -> b
$ do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
txsz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit
        IgnoringOverflow ByteSize32 -> Maybe (IgnoringOverflow ByteSize32)
forall a. a -> Maybe a
Just (IgnoringOverflow ByteSize32
 -> Maybe (IgnoringOverflow ByteSize32))
-> IgnoringOverflow ByteSize32
-> Maybe (IgnoringOverflow ByteSize32)
forall a b. (a -> b) -> a -> b
$ ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
IgnoringOverflow (ByteSize32 -> IgnoringOverflow ByteSize32)
-> ByteSize32 -> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
ByteSize32 (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
txsz

class TxRefScriptsSizeTooBig era where
  txRefScriptsSizeTooBig :: Int -> Int -> SL.ApplyTxError era

instance TxRefScriptsSizeTooBig ConwayEra where
  txRefScriptsSizeTooBig :: Int -> Int -> ApplyTxError ConwayEra
txRefScriptsSizeTooBig Int
txsz Int
limit =
      NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra))
-> ApplyTxError ConwayEra
NonEmpty (ConwayLedgerPredFailure ConwayEra)
-> ApplyTxError ConwayEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
SL.ApplyTxError (NonEmpty (ConwayLedgerPredFailure ConwayEra)
 -> ApplyTxError ConwayEra)
-> (ConwayLedgerPredFailure ConwayEra
    -> NonEmpty (ConwayLedgerPredFailure ConwayEra))
-> ConwayLedgerPredFailure ConwayEra
-> ApplyTxError ConwayEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayLedgerPredFailure ConwayEra
-> NonEmpty (ConwayLedgerPredFailure ConwayEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ConwayLedgerPredFailure ConwayEra -> ApplyTxError ConwayEra)
-> ConwayLedgerPredFailure ConwayEra -> ApplyTxError ConwayEra
forall a b. (a -> b) -> a -> b
$ Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure ConwayEra
forall era. Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure era
ConwayEra.ConwayTxRefScriptsSizeTooBig
    (Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure ConwayEra)
-> Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure ConwayEra
forall a b. (a -> b) -> a -> b
$ L.Mismatch { mismatchSupplied :: Int
mismatchSupplied = Int
txsz
                 , mismatchExpected :: Int
mismatchExpected = Int
limit }

-----

txMeasureBabbage ::
     forall proto era.
     ( ShelleyCompatible proto era
     , L.AlonzoEraTxWits era
     , L.BabbageEraTxBody era
     , ExUnitsTooBigUTxO era
     , MaxTxSizeUTxO era
     )
  => TickedLedgerState (ShelleyBlock proto era)
  -> GenTx (ShelleyBlock proto era)
  -> V.Validation (TxErrorSG era) ConwayMeasure
txMeasureBabbage :: forall proto era.
(ShelleyCompatible proto era, AlonzoEraTxWits era,
 BabbageEraTxBody era, ExUnitsTooBigUTxO era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) ConwayMeasure
txMeasureBabbage TickedLedgerState (ShelleyBlock proto era)
st tx :: GenTx (ShelleyBlock proto era)
tx@(ShelleyTx TxId
_txid Tx era
tx') =
    (\AlonzoMeasure
x -> AlonzoMeasure -> IgnoringOverflow ByteSize32 -> ConwayMeasure
ConwayMeasure AlonzoMeasure
x IgnoringOverflow ByteSize32
refScriptBytes) (AlonzoMeasure -> ConwayMeasure)
-> Validation (TxErrorSG era) AlonzoMeasure
-> Validation (TxErrorSG era) ConwayMeasure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) AlonzoMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era,
 AlonzoEraTxWits era, ExUnitsTooBigUTxO era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) AlonzoMeasure
txMeasureAlonzo TickedLedgerState (ShelleyBlock proto era)
st GenTx (ShelleyBlock proto era)
tx
  where
    utxo :: UTxO era
utxo = NewEpochState era -> UTxO era
forall era. NewEpochState era -> UTxO era
SL.getUTxO (NewEpochState era -> UTxO era) -> NewEpochState era -> UTxO era
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
st

    -- The Babbage rules should have checked this ref script size against a
    -- limit, but they did not. Now that Cardano @mainnet@ is in Conway, that
    -- omission is no longer an attack vector. Any other chain intending to
    -- ever use Babbage as its current era ought to patch this.
    refScriptBytes :: IgnoringOverflow ByteSize32
refScriptBytes =
        ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
IgnoringOverflow
      (ByteSize32 -> IgnoringOverflow ByteSize32)
-> ByteSize32 -> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
ByteSize32
      (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UTxO era -> Tx era -> Int
forall era.
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx era -> Int
SL.txNonDistinctRefScriptsSize UTxO era
utxo Tx era
tx' :: Int)

-- | We anachronistically use 'ConwayMeasure' in Babbage.
instance ( ShelleyCompatible p BabbageEra
         ) => TxLimits (ShelleyBlock p BabbageEra) where

  type TxMeasure (ShelleyBlock p BabbageEra) = ConwayMeasure
  txMeasure :: LedgerConfig (ShelleyBlock p BabbageEra)
-> TickedLedgerState (ShelleyBlock p BabbageEra)
-> GenTx (ShelleyBlock p BabbageEra)
-> Except
     (ApplyTxErr (ShelleyBlock p BabbageEra))
     (TxMeasure (ShelleyBlock p BabbageEra))
txMeasure              LedgerConfig (ShelleyBlock p BabbageEra)
_cfg TickedLedgerState (ShelleyBlock p BabbageEra)
st GenTx (ShelleyBlock p BabbageEra)
tx = Validation
  (TxErrorSG BabbageEra) (TxMeasure (ShelleyBlock p BabbageEra))
-> Except
     (ApplyTxError BabbageEra) (TxMeasure (ShelleyBlock p BabbageEra))
forall era a.
Validation (TxErrorSG era) a -> Except (ApplyTxError era) a
runValidation (Validation
   (TxErrorSG BabbageEra) (TxMeasure (ShelleyBlock p BabbageEra))
 -> Except
      (ApplyTxError BabbageEra) (TxMeasure (ShelleyBlock p BabbageEra)))
-> Validation
     (TxErrorSG BabbageEra) (TxMeasure (ShelleyBlock p BabbageEra))
-> Except
     (ApplyTxError BabbageEra) (TxMeasure (ShelleyBlock p BabbageEra))
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock p BabbageEra)
-> GenTx (ShelleyBlock p BabbageEra)
-> Validation (TxErrorSG BabbageEra) ConwayMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraTxWits era,
 BabbageEraTxBody era, ExUnitsTooBigUTxO era, MaxTxSizeUTxO era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) ConwayMeasure
txMeasureBabbage TickedLedgerState (ShelleyBlock p BabbageEra)
st GenTx (ShelleyBlock p BabbageEra)
tx
  blockCapacityTxMeasure :: LedgerConfig (ShelleyBlock p BabbageEra)
-> TickedLedgerState (ShelleyBlock p BabbageEra)
-> TxMeasure (ShelleyBlock p BabbageEra)
blockCapacityTxMeasure LedgerConfig (ShelleyBlock p BabbageEra)
_cfg       = TickedLedgerState (ShelleyBlock p BabbageEra)
-> TxMeasure (ShelleyBlock p BabbageEra)
TickedLedgerState (ShelleyBlock p BabbageEra) -> ConwayMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era) =>
TickedLedgerState (ShelleyBlock proto era) -> ConwayMeasure
blockCapacityConwayMeasure

instance ( ShelleyCompatible p ConwayEra
         ) => TxLimits (ShelleyBlock p ConwayEra) where

  type TxMeasure (ShelleyBlock p ConwayEra) = ConwayMeasure
  txMeasure :: LedgerConfig (ShelleyBlock p ConwayEra)
-> TickedLedgerState (ShelleyBlock p ConwayEra)
-> GenTx (ShelleyBlock p ConwayEra)
-> Except
     (ApplyTxErr (ShelleyBlock p ConwayEra))
     (TxMeasure (ShelleyBlock p ConwayEra))
txMeasure              LedgerConfig (ShelleyBlock p ConwayEra)
_cfg TickedLedgerState (ShelleyBlock p ConwayEra)
st GenTx (ShelleyBlock p ConwayEra)
tx = Validation
  (TxErrorSG ConwayEra) (TxMeasure (ShelleyBlock p ConwayEra))
-> Except
     (ApplyTxError ConwayEra) (TxMeasure (ShelleyBlock p ConwayEra))
forall era a.
Validation (TxErrorSG era) a -> Except (ApplyTxError era) a
runValidation (Validation
   (TxErrorSG ConwayEra) (TxMeasure (ShelleyBlock p ConwayEra))
 -> Except
      (ApplyTxError ConwayEra) (TxMeasure (ShelleyBlock p ConwayEra)))
-> Validation
     (TxErrorSG ConwayEra) (TxMeasure (ShelleyBlock p ConwayEra))
-> Except
     (ApplyTxError ConwayEra) (TxMeasure (ShelleyBlock p ConwayEra))
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock p ConwayEra)
-> GenTx (ShelleyBlock p ConwayEra)
-> Validation (TxErrorSG ConwayEra) ConwayMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraTxWits era,
 BabbageEraTxBody era, ExUnitsTooBigUTxO era, MaxTxSizeUTxO era,
 TxRefScriptsSizeTooBig era) =>
TickedLedgerState (ShelleyBlock proto era)
-> GenTx (ShelleyBlock proto era)
-> Validation (TxErrorSG era) ConwayMeasure
txMeasureConway TickedLedgerState (ShelleyBlock p ConwayEra)
st GenTx (ShelleyBlock p ConwayEra)
tx
  blockCapacityTxMeasure :: LedgerConfig (ShelleyBlock p ConwayEra)
-> TickedLedgerState (ShelleyBlock p ConwayEra)
-> TxMeasure (ShelleyBlock p ConwayEra)
blockCapacityTxMeasure LedgerConfig (ShelleyBlock p ConwayEra)
_cfg       = TickedLedgerState (ShelleyBlock p ConwayEra)
-> TxMeasure (ShelleyBlock p ConwayEra)
TickedLedgerState (ShelleyBlock p ConwayEra) -> ConwayMeasure
forall proto era.
(ShelleyCompatible proto era, AlonzoEraPParams era) =>
TickedLedgerState (ShelleyBlock proto era) -> ConwayMeasure
blockCapacityConwayMeasure