{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | This module defines core type families which we know to vary from era to
-- era.
--
-- Families in this module should be indexed on era.
--
-- It is intended for qualified import:
-- > import qualified Cardano.Ledger.Core as Core
module Cardano.Ledger.Core (
  -- * Era-changing types
  EraTx (..),
  txIdTx,
  EraTxOut (..),
  bootAddrTxOutF,
  coinTxOutL,
  compactCoinTxOutL,
  isAdaOnlyTxOutF,
  EraTxBody (..),
  txIdTxBody,
  EraTxAuxData (..),
  hashTxAuxData,
  EraTxWits (..),
  EraScript (..),
  hashScript,
  isNativeScript,
  hashScriptTxWitsL,
  Value,
  EraPParams (..),
  mkCoinTxOut,

  -- * Era
  module Cardano.Ledger.Core.Era,
  -- $segWit
  EraSegWits (..),
  bBodySize,

  -- * Rewards
  RewardType (..),
  Reward (..),

  -- * Re-exports
  module Cardano.Ledger.Hashes,
  module Cardano.Ledger.Core.TxCert,
  module Cardano.Ledger.Core.PParams,
  module Cardano.Ledger.Core.Translation,
)
where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Address (
  Addr (..),
  BootstrapAddress,
  CompactAddr,
  Withdrawals,
  compactAddr,
  decompactAddr,
  isBootstrapCompactAddr,
 )
import Cardano.Ledger.BaseTypes (ProtVer (..))
import Cardano.Ledger.Binary (
  Annotator,
  DecCBOR,
  DecShareCBOR (Share),
  EncCBOR,
  EncCBORGroup,
  Interns,
  Sized (sizedValue),
  ToCBOR,
  encCBORGroup,
  mkSized,
  serialize',
 )
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Compactible (Compactible (..))
import Cardano.Ledger.Core.Era
import Cardano.Ledger.Core.PParams
import Cardano.Ledger.Core.Translation
import Cardano.Ledger.Core.TxCert
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Hashes hiding (GenDelegPair (..), GenDelegs (..), unsafeMakeSafeHash)
import Cardano.Ledger.Keys.Bootstrap (BootstrapWitness)
import Cardano.Ledger.Keys.WitVKey (WitVKey)
import Cardano.Ledger.MemoBytes
import Cardano.Ledger.Metadata
import Cardano.Ledger.Rewards (Reward (..), RewardType (..))
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.Val (Val (..), inject)
import Control.DeepSeq (NFData)
import Data.Aeson (ToJSON)
import qualified Data.ByteString as BS
import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Maybe.Strict (StrictMaybe)
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import Data.Void (Void)
import Data.Word (Word32, Word64)
import GHC.Stack (HasCallStack)
import Lens.Micro
import NoThunks.Class (NoThunks)

-- | A transaction.
class
  ( EraTxBody era
  , EraTxWits era
  , EraTxAuxData era
  , EraPParams era
  , -- NFData (Tx era), TODO: Add NFData constraints to Crypto class
    NoThunks (Tx era)
  , DecCBOR (Annotator (Tx era))
  , EncCBOR (Tx era)
  , ToCBOR (Tx era)
  , Show (Tx era)
  , Eq (Tx era)
  , EqRaw (Tx era)
  ) =>
  EraTx era
  where
  type Tx era = (r :: Type) | r -> era

  type TxUpgradeError era :: Type
  type TxUpgradeError era = Void

  mkBasicTx :: TxBody era -> Tx era

  bodyTxL :: Lens' (Tx era) (TxBody era)

  witsTxL :: Lens' (Tx era) (TxWits era)

  auxDataTxL :: Lens' (Tx era) (StrictMaybe (TxAuxData era))

  -- | For fee calculation and estimations of impact on block space
  sizeTxF :: SimpleGetter (Tx era) Integer

  -- | For end use by eg. diffusion layer in transaction submission protocol
  wireSizeTxF :: SimpleGetter (Tx era) Word32

  -- | Using information from the transaction validate the supplied native script.
  validateNativeScript :: Tx era -> NativeScript era -> Bool

  -- | Minimum fee calculation excluding witnesses
  getMinFeeTx ::
    PParams era ->
    Tx era ->
    -- | Size in bytes of reference scripts present in this transaction
    Int ->
    Coin

  upgradeTx ::
    EraTx (PreviousEra era) =>
    Tx (PreviousEra era) ->
    Either (TxUpgradeError era) (Tx era)

class
  ( EraTxOut era
  , EraTxCert era
  , EraPParams era
  , HashAnnotated (TxBody era) EraIndependentTxBody
  , DecCBOR (Annotator (TxBody era))
  , EncCBOR (TxBody era)
  , ToCBOR (TxBody era)
  , NoThunks (TxBody era)
  , NFData (TxBody era)
  , Show (TxBody era)
  , Eq (TxBody era)
  , EqRaw (TxBody era)
  ) =>
  EraTxBody era
  where
  -- | The body of a transaction.
  type TxBody era = (r :: Type) | r -> era

  type TxBodyUpgradeError era :: Type
  type TxBodyUpgradeError era = Void

  mkBasicTxBody :: TxBody era

  inputsTxBodyL :: Lens' (TxBody era) (Set TxIn)

  outputsTxBodyL :: Lens' (TxBody era) (StrictSeq (TxOut era))

  feeTxBodyL :: Lens' (TxBody era) Coin

  withdrawalsTxBodyL :: Lens' (TxBody era) Withdrawals

  auxDataHashTxBodyL :: Lens' (TxBody era) (StrictMaybe TxAuxDataHash)

  -- | This getter will produce all inputs from the UTxO map that this transaction might
  -- spend, which ones will depend on the validity of the transaction itself. Starting in
  -- Alonzo this will include collateral inputs.
  spendableInputsTxBodyF :: SimpleGetter (TxBody era) (Set TxIn)

  -- | This getter will produce all inputs from the UTxO map that this transaction is
  -- referencing, even if some of them cannot be spent by the transaction. For example
  -- starting with Babbage era it will also include reference inputs.
  allInputsTxBodyF :: SimpleGetter (TxBody era) (Set TxIn)

  certsTxBodyL :: Lens' (TxBody era) (StrictSeq (TxCert era))

  -- | Compute the total deposits from the certificates in a TxBody.
  --
  -- This is the contribution of a TxBody towards the consumed amount by the transaction
  getTotalDepositsTxBody ::
    PParams era ->
    -- | Check whether stake pool is registered or not
    (KeyHash 'StakePool -> Bool) ->
    TxBody era ->
    Coin
  getTotalDepositsTxBody PParams era
pp KeyHash 'StakePool -> Bool
isPoolRegisted TxBody era
txBody =
    forall era (f :: * -> *).
(EraTxCert era, Foldable f) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> f (TxCert era) -> Coin
getTotalDepositsTxCerts PParams era
pp KeyHash 'StakePool -> Bool
isPoolRegisted (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)

  -- | Compute the total refunds from the Certs of a TxBody.
  --
  -- This is the contribution of a TxBody towards produced amount by the transaction
  getTotalRefundsTxBody ::
    PParams era ->
    -- | Lookup current deposit for Staking credential if one is registered
    (Credential 'Staking -> Maybe Coin) ->
    -- | Lookup current deposit for DRep credential if one is registered
    (Credential 'DRepRole -> Maybe Coin) ->
    TxBody era ->
    Coin
  getTotalRefundsTxBody PParams era
pp Credential 'Staking -> Maybe Coin
lookupStakingDeposit Credential 'DRepRole -> Maybe Coin
lookupDRepDeposit TxBody era
txBody =
    forall era (f :: * -> *).
(EraTxCert era, Foldable f) =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> f (TxCert era)
-> Coin
getTotalRefundsTxCerts PParams era
pp Credential 'Staking -> Maybe Coin
lookupStakingDeposit Credential 'DRepRole -> Maybe Coin
lookupDRepDeposit (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)

  -- | This function is not used in the ledger rules. It is only used by the downstream
  -- tooling to figure out how many witnesses should be supplied for Genesis keys.
  getGenesisKeyHashCountTxBody :: TxBody era -> Int
  getGenesisKeyHashCountTxBody TxBody era
_ = Int
0

  -- | Upgrade the transaction body from the previous era.
  --
  -- This can fail where elements of the transaction body are deprecated.
  -- Compare this to `translateEraThroughCBOR`:
  -- - `upgradeTxBody` will use the Haskell representation, but will not
  --   preserve the serialised form. However, it will be suitable for iterated
  --   translation through eras.
  -- - `translateEraThroughCBOR` will preserve the binary representation, but is
  --   not guaranteed to work through multiple eras - that is, the serialised
  --   representation from era n is guaranteed valid in era n + 1, but not
  --   necessarily in era n + 2.
  upgradeTxBody ::
    EraTxBody (PreviousEra era) =>
    TxBody (PreviousEra era) ->
    Either (TxBodyUpgradeError era) (TxBody era)

-- | Abstract interface into specific fields of a `TxOut`
class
  ( Val (Value era)
  , ToJSON (TxOut era)
  , DecCBOR (Value era)
  , DecCBOR (CompactForm (Value era))
  , EncCBOR (Value era)
  , ToCBOR (TxOut era)
  , EncCBOR (TxOut era)
  , DecCBOR (TxOut era)
  , DecShareCBOR (TxOut era)
  , Share (TxOut era) ~ Interns (Credential 'Staking)
  , NoThunks (TxOut era)
  , NFData (TxOut era)
  , Show (TxOut era)
  , Eq (TxOut era)
  , EraPParams era
  ) =>
  EraTxOut era
  where
  -- | The output of a UTxO for a particular era
  type TxOut era = (r :: Type) | r -> era

  {-# MINIMAL
    mkBasicTxOut
    , upgradeTxOut
    , valueEitherTxOutL
    , addrEitherTxOutL
    , (getMinCoinSizedTxOut | getMinCoinTxOut)
    #-}

  mkBasicTxOut :: HasCallStack => Addr -> Value era -> TxOut era

  -- | Every era, except Shelley, must be able to upgrade a `TxOut` from a previous era.
  upgradeTxOut :: EraTxOut (PreviousEra era) => TxOut (PreviousEra era) -> TxOut era

  valueTxOutL :: Lens' (TxOut era) (Value era)
  valueTxOutL =
    forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
      ( \TxOut era
txOut -> case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL of
          Left Value era
value -> Value era
value
          Right CompactForm (Value era)
cValue -> forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm (Value era)
cValue
      )
      (\TxOut era
txOut Value era
value -> TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. a -> Either a b
Left Value era
value)
  {-# INLINE valueTxOutL #-}

  compactValueTxOutL :: HasCallStack => Lens' (TxOut era) (CompactForm (Value era))
  compactValueTxOutL =
    forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
      ( \TxOut era
txOut -> case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL of
          Left Value era
value -> forall a. (HasCallStack, Val a) => a -> CompactForm a
toCompactPartial Value era
value
          Right CompactForm (Value era)
cValue -> CompactForm (Value era)
cValue
      )
      (\TxOut era
txOut CompactForm (Value era)
cValue -> TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. b -> Either a b
Right CompactForm (Value era)
cValue)
  {-# INLINE compactValueTxOutL #-}

  -- | Lens for getting and setting in TxOut either an address or its compact
  -- version by doing the least amount of work.
  valueEitherTxOutL :: Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))

  addrTxOutL :: Lens' (TxOut era) Addr
  addrTxOutL =
    forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
      ( \TxOut era
txOut -> case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either Addr CompactAddr)
addrEitherTxOutL of
          Left Addr
addr -> Addr
addr
          Right CompactAddr
cAddr -> HasCallStack => CompactAddr -> Addr
decompactAddr CompactAddr
cAddr
      )
      (\TxOut era
txOut Addr
addr -> TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era.
EraTxOut era =>
Lens' (TxOut era) (Either Addr CompactAddr)
addrEitherTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. a -> Either a b
Left Addr
addr)
  {-# INLINE addrTxOutL #-}

  compactAddrTxOutL :: Lens' (TxOut era) CompactAddr
  compactAddrTxOutL =
    forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
      ( \TxOut era
txOut -> case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either Addr CompactAddr)
addrEitherTxOutL of
          Left Addr
addr -> Addr -> CompactAddr
compactAddr Addr
addr
          Right CompactAddr
cAddr -> CompactAddr
cAddr
      )
      (\TxOut era
txOut CompactAddr
cAddr -> TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era.
EraTxOut era =>
Lens' (TxOut era) (Either Addr CompactAddr)
addrEitherTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. b -> Either a b
Right CompactAddr
cAddr)
  {-# INLINE compactAddrTxOutL #-}

  -- | Lens for getting and setting in TxOut either an address or its compact
  -- version by doing the least amount of work.
  --
  -- The utility of this function comes from the fact that TxOut usually stores
  -- the address in either one of two forms: compacted or unpacked. In order to
  -- avoid extroneous conversions in `getTxOutAddr` and `getTxOutCompactAddr` we
  -- can define just this functionality. Also sometimes it is crucial to know at
  -- the callsite which form of address we have readily available without any
  -- conversions (eg. searching millions of TxOuts for a particular address)
  addrEitherTxOutL :: Lens' (TxOut era) (Either Addr CompactAddr)

  -- | Produce the minimum lovelace that a given transaction output must
  -- contain. Information about the size of the TxOut is required in some eras.
  -- Use `getMinCoinTxOut` if you don't have the size readily available to you.
  getMinCoinSizedTxOut :: PParams era -> Sized (TxOut era) -> Coin
  getMinCoinSizedTxOut PParams era
pp = forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sized a -> a
sizedValue

  -- | Same as `getMinCoinSizedTxOut`, except information about the size of
  -- TxOut will be computed by serializing the TxOut. If the size turns out to
  -- be not needed, then serialization will have no overhead, since it is
  -- computed lazily.
  getMinCoinTxOut :: PParams era -> TxOut era -> Coin
  getMinCoinTxOut PParams era
pp TxOut era
txOut =
    let ProtVer Version
version Natural
_ = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
     in forall era.
EraTxOut era =>
PParams era -> Sized (TxOut era) -> Coin
getMinCoinSizedTxOut PParams era
pp (forall a. EncCBOR a => Version -> a -> Sized a
mkSized Version
version TxOut era
txOut)

bootAddrTxOutF ::
  EraTxOut era => SimpleGetter (TxOut era) (Maybe BootstrapAddress)
bootAddrTxOutF :: forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
bootAddrTxOutF = forall s a. (s -> a) -> SimpleGetter s a
to forall a b. (a -> b) -> a -> b
$ \TxOut era
txOut ->
  case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either Addr CompactAddr)
addrEitherTxOutL of
    Left (AddrBootstrap BootstrapAddress
bootstrapAddr) -> forall a. a -> Maybe a
Just BootstrapAddress
bootstrapAddr
    Right CompactAddr
cAddr
      | CompactAddr -> Bool
isBootstrapCompactAddr CompactAddr
cAddr -> do
          AddrBootstrap BootstrapAddress
bootstrapAddr <- forall a. a -> Maybe a
Just (HasCallStack => CompactAddr -> Addr
decompactAddr CompactAddr
cAddr)
          forall a. a -> Maybe a
Just BootstrapAddress
bootstrapAddr
    Either Addr CompactAddr
_ -> forall a. Maybe a
Nothing
{-# INLINE bootAddrTxOutF #-}

coinTxOutL :: (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL :: forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    ( \TxOut era
txOut ->
        case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL of
          Left Value era
val -> forall t. Val t => t -> Coin
coin Value era
val
          Right CompactForm (Value era)
cVal -> forall a. Compactible a => CompactForm a -> a
fromCompact (forall t. Val t => CompactForm t -> CompactForm Coin
coinCompact CompactForm (Value era)
cVal)
    )
    ( \TxOut era
txOut Coin
c ->
        case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL of
          Left Value era
val -> TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall t. Val t => (Coin -> Coin) -> t -> t
modifyCoin (forall a b. a -> b -> a
const Coin
c) Value era
val
          Right CompactForm (Value era)
cVal ->
            TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era.
(EraTxOut era, HasCallStack) =>
Lens' (TxOut era) (CompactForm (Value era))
compactValueTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall t.
Val t =>
(CompactForm Coin -> CompactForm Coin)
-> CompactForm t -> CompactForm t
modifyCompactCoin (forall a b. a -> b -> a
const (forall a. (HasCallStack, Val a) => a -> CompactForm a
toCompactPartial Coin
c)) CompactForm (Value era)
cVal
    )
{-# INLINE coinTxOutL #-}

compactCoinTxOutL :: (HasCallStack, EraTxOut era) => Lens' (TxOut era) (CompactForm Coin)
compactCoinTxOutL :: forall era.
(HasCallStack, EraTxOut era) =>
Lens' (TxOut era) (CompactForm Coin)
compactCoinTxOutL =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    ( \TxOut era
txOut ->
        case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL of
          Left Value era
val -> forall a. (HasCallStack, Val a) => a -> CompactForm a
toCompactPartial (forall t. Val t => t -> Coin
coin Value era
val)
          Right CompactForm (Value era)
cVal -> forall t. Val t => CompactForm t -> CompactForm Coin
coinCompact CompactForm (Value era)
cVal
    )
    ( \TxOut era
txOut CompactForm Coin
cCoin ->
        case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL of
          Left Value era
val -> TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall t. Val t => (Coin -> Coin) -> t -> t
modifyCoin (forall a b. a -> b -> a
const (forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
cCoin)) Value era
val
          Right CompactForm (Value era)
cVal ->
            TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era.
(EraTxOut era, HasCallStack) =>
Lens' (TxOut era) (CompactForm (Value era))
compactValueTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall t.
Val t =>
(CompactForm Coin -> CompactForm Coin)
-> CompactForm t -> CompactForm t
modifyCompactCoin (forall a b. a -> b -> a
const CompactForm Coin
cCoin) CompactForm (Value era)
cVal
    )
{-# INLINE compactCoinTxOutL #-}

-- | This is a getter that implements an efficient way to check whether 'TxOut'
-- contains ADA only.
isAdaOnlyTxOutF :: EraTxOut era => SimpleGetter (TxOut era) Bool
isAdaOnlyTxOutF :: forall era. EraTxOut era => SimpleGetter (TxOut era) Bool
isAdaOnlyTxOutF = forall s a. (s -> a) -> SimpleGetter s a
to forall a b. (a -> b) -> a -> b
$ \TxOut era
txOut ->
  case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Either (Value era) (CompactForm (Value era)))
valueEitherTxOutL of
    Left Value era
val -> forall t. Val t => t -> Bool
isAdaOnly Value era
val
    Right CompactForm (Value era)
cVal -> forall t. Val t => CompactForm t -> Bool
isAdaOnlyCompact CompactForm (Value era)
cVal

toCompactPartial :: (HasCallStack, Val a) => a -> CompactForm a
toCompactPartial :: forall a. (HasCallStack, Val a) => a -> CompactForm a
toCompactPartial a
v =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal value in TxOut: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
v) forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact a
v

-- A version of mkBasicTxOut, which has only a Coin (no multiAssets) for every EraTxOut era.
mkCoinTxOut :: EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut :: forall era. EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut Addr
addr = forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t s. Inject t s => t -> s
inject

-- | A value is something which quantifies a transaction output.
type family Value era :: Type

-- | TxAuxData which may be attached to a transaction
class
  ( Era era
  , Eq (TxAuxData era)
  , EqRaw (TxAuxData era)
  , Show (TxAuxData era)
  , NoThunks (TxAuxData era)
  , ToCBOR (TxAuxData era)
  , EncCBOR (TxAuxData era)
  , DecCBOR (Annotator (TxAuxData era))
  , HashAnnotated (TxAuxData era) EraIndependentTxAuxData
  ) =>
  EraTxAuxData era
  where
  type TxAuxData era = (r :: Type) | r -> era

  mkBasicTxAuxData :: TxAuxData era

  metadataTxAuxDataL :: Lens' (TxAuxData era) (Map Word64 Metadatum)

  -- | Every era, except Shelley, must be able to upgrade a `TxAuxData` from a previous
  -- era.
  --
  -- /Warning/ - Important to note that any memoized binary representation will not be
  -- preserved. If you need to retain underlying bytes you can use `translateEraThroughCBOR`
  upgradeTxAuxData :: EraTxAuxData (PreviousEra era) => TxAuxData (PreviousEra era) -> TxAuxData era

  validateTxAuxData :: ProtVer -> TxAuxData era -> Bool

-- | Compute a hash of `TxAuxData`
hashTxAuxData :: EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData :: forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData = SafeHash EraIndependentTxAuxData -> TxAuxDataHash
TxAuxDataHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated

-- | A collection of witnesses in a Tx
class
  ( EraScript era
  , Eq (TxWits era)
  , EqRaw (TxWits era)
  , Show (TxWits era)
  , Monoid (TxWits era)
  , NoThunks (TxWits era)
  , ToCBOR (TxWits era)
  , EncCBOR (TxWits era)
  , DecCBOR (Annotator (TxWits era))
  ) =>
  EraTxWits era
  where
  type TxWits era = (r :: Type) | r -> era

  mkBasicTxWits :: TxWits era
  mkBasicTxWits = forall a. Monoid a => a
mempty

  addrTxWitsL :: Lens' (TxWits era) (Set (WitVKey 'Witness))

  bootAddrTxWitsL :: Lens' (TxWits era) (Set BootstrapWitness)

  scriptTxWitsL :: Lens' (TxWits era) (Map ScriptHash (Script era))

  upgradeTxWits :: EraTxWits (PreviousEra era) => TxWits (PreviousEra era) -> TxWits era

-- | This is a helper lens that will hash the scripts when adding as witnesses.
hashScriptTxWitsL ::
  EraTxWits era =>
  Lens (TxWits era) (TxWits era) (Map ScriptHash (Script era)) [Script era]
hashScriptTxWitsL :: forall era.
EraTxWits era =>
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
hashScriptTxWitsL =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (\TxWits era
wits -> TxWits era
wits forall s a. s -> Getting a s a -> a
^. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL)
    (\TxWits era
wits [Script era]
ss -> TxWits era
wits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
s, Script era
s) | Script era
s <- [Script era]
ss])
{-# INLINEABLE hashScriptTxWitsL #-}

-----------------------------------------------------------------------------
-- Script Validation
-----------------------------------------------------------------------------

-- | Typeclass for script data types. Allows for script validation and hashing.
--   You must understand the role of SafeToHash and scriptPrefixTag to make new
--   instances. 'scriptPrefixTag' is a magic number representing the tag of the
--   script language. For each new script language defined, a new tag is chosen
--   and the tag is included in the script hash for a script. The safeToHash
--   constraint ensures that Scripts are never reserialised.
class
  ( Era era
  , Show (Script era)
  , Eq (Script era)
  , EqRaw (Script era)
  , ToCBOR (Script era)
  , EncCBOR (Script era)
  , DecCBOR (Annotator (Script era))
  , NoThunks (Script era)
  , SafeToHash (Script era)
  , Eq (NativeScript era)
  , Show (NativeScript era)
  , NFData (NativeScript era)
  , NoThunks (NativeScript era)
  , EncCBOR (NativeScript era)
  , DecCBOR (Annotator (NativeScript era))
  ) =>
  EraScript era
  where
  -- | Scripts which may lock transaction outputs in this era
  type Script era = (r :: Type) | r -> era

  type NativeScript era = (r :: Type) | r -> era

  -- | Every era, except Shelley, must be able to upgrade a `Script` from a previous era.
  --
  -- /Warning/ - Important to note that any memoized binary representation will not be
  -- preserved, you need to retain underlying bytes you can use `translateEraThroughCBOR`
  upgradeScript :: EraScript (PreviousEra era) => Script (PreviousEra era) -> Script era

  scriptPrefixTag :: Script era -> BS.ByteString

  getNativeScript :: Script era -> Maybe (NativeScript era)

  fromNativeScript :: NativeScript era -> Script era

isNativeScript :: EraScript era => Script era -> Bool
isNativeScript :: forall era. EraScript era => Script era -> Bool
isNativeScript = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> Maybe (NativeScript era)
getNativeScript

-- | Compute `ScriptHash` of a `Script` for a particular era.
hashScript :: forall era. EraScript era => Script era -> ScriptHash
hashScript :: forall era. EraScript era => Script era -> ScriptHash
hashScript =
  Hash ADDRHASH EraIndependentScript -> ScriptHash
ScriptHash
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a b. Hash h a -> Hash h b
Hash.castHash
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith
      (\Script era
x -> forall era. EraScript era => Script era -> ByteString
scriptPrefixTag @era Script era
x forall a. Semigroup a => a -> a -> a
<> forall t. SafeToHash t => t -> ByteString
originalBytes Script era
x)

--------------------------------------------------------------------------------
-- Segregated Witness
--------------------------------------------------------------------------------

-- $segWit
-- * Segregated Witness
--
-- The idea of segregated witnessing is to alter the encoding of transactions in
-- a block such that the witnesses (the information needed to verify the
-- validity of the transactions) can be stored separately from the body (the
-- information needed to update the ledger state). In this way, a node which
-- only cares about replaying transactions need not even decode the witness
-- information.
--
-- In order to do this, we introduce two concepts:
-- - A 'TxSeq`, which represents the decoded structure of a sequence of
--   transactions as represented in the encoded block; that is, with witnessing,
--   metadata and other non-body parts split separately.

-- | Indicates that an era supports segregated witnessing.
--
--   This class embodies an isomorphism between 'TxSeq era' and 'StrictSeq
--   (Tx era)', witnessed by 'fromTxSeq' and 'toTxSeq'.
class
  ( EraTx era
  , Eq (TxSeq era)
  , Show (TxSeq era)
  , EncCBORGroup (TxSeq era)
  , DecCBOR (Annotator (TxSeq era))
  ) =>
  EraSegWits era
  where
  type TxSeq era = (r :: Type) | r -> era

  fromTxSeq :: TxSeq era -> StrictSeq (Tx era)
  toTxSeq :: StrictSeq (Tx era) -> TxSeq era

  -- | Get the block body hash from the TxSeq. Note that this is not a regular
  -- "hash the stored bytes" function since the block body hash forms a small
  -- Merkle tree.
  hashTxSeq :: TxSeq era -> Hash.Hash HASH EraIndependentBlockBody

  -- | The number of segregated components
  numSegComponents :: Word64

bBodySize :: forall era. EraSegWits era => ProtVer -> TxSeq era -> Int
bBodySize :: forall era. EraSegWits era => ProtVer -> TxSeq era -> Int
bBodySize (ProtVer Version
v Natural
_) = ByteString -> Int
BS.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncCBORGroup a => a -> Encoding
encCBORGroup

txIdTx :: EraTx era => Tx era -> TxId
txIdTx :: forall era. EraTx era => Tx era -> TxId
txIdTx Tx era
tx = forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)

txIdTxBody :: EraTxBody era => TxBody era -> TxId
txIdTxBody :: forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody = SafeHash EraIndependentTxBody -> TxId
TxId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated