diff --git a/eras/allegra/impl/cardano-ledger-allegra.cabal b/eras/allegra/impl/cardano-ledger-allegra.cabal index 87f90997b23..e72f5684bcb 100644 --- a/eras/allegra/impl/cardano-ledger-allegra.cabal +++ b/eras/allegra/impl/cardano-ledger-allegra.cabal @@ -34,6 +34,7 @@ library Cardano.Ledger.Allegra.Tx Cardano.Ledger.Allegra.TxAuxData Cardano.Ledger.Allegra.TxBody + Cardano.Ledger.Allegra.TxBody.Internal hs-source-dirs: src other-modules: diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs index dc86fb1989c..80e136f9535 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs @@ -1,23 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Cardano.Ledger.Allegra.TxBody ( AllegraEraTxBody (..), AllegraTxBody ( @@ -38,346 +18,4 @@ module Cardano.Ledger.Allegra.TxBody ( ) where -import Cardano.Ledger.Allegra.Era (AllegraEra) -import Cardano.Ledger.Allegra.Scripts (ValidityInterval (..)) -import Cardano.Ledger.Allegra.TxCert () -import Cardano.Ledger.Allegra.TxOut () -import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) -import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (SJust, SNothing)) -import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR (..), ToCBOR) -import Cardano.Ledger.Binary.Coders ( - Decode (..), - Encode (..), - Field, - decode, - encode, - encodeKeyedStrictMaybe, - field, - invalidField, - ofield, - (!>), - ) -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Compactible (Compactible (..)) -import Cardano.Ledger.Core -import Cardano.Ledger.Crypto (Crypto, StandardCrypto) -import Cardano.Ledger.MemoBytes ( - EqRaw, - Mem, - MemoBytes, - MemoHashIndex, - Memoized (RawType), - getMemoRawType, - getMemoSafeHash, - lensMemoRawType, - mkMemoized, - ) -import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) -import Cardano.Ledger.Shelley.Core -import Cardano.Ledger.Shelley.PParams (Update (..), upgradeUpdate) -import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) -import Cardano.Ledger.TxIn (TxIn (..)) -import Control.DeepSeq (NFData (..)) -import qualified Data.Map.Strict as Map -import Data.Sequence.Strict (StrictSeq, fromList) -import Data.Set (Set, empty) -import GHC.Generics (Generic) -import Lens.Micro -import NoThunks.Class (NoThunks (..)) - -class EraTxBody era => AllegraEraTxBody era where - vldtTxBodyL :: Lens' (TxBody era) ValidityInterval - --- ======================================================= - -data AllegraTxBodyRaw ma era = AllegraTxBodyRaw - { atbrInputs :: !(Set (TxIn (EraCrypto era))) - , atbrOutputs :: !(StrictSeq (TxOut era)) - , atbrCerts :: !(StrictSeq (TxCert era)) - , atbrWithdrawals :: !(Withdrawals (EraCrypto era)) - , atbrTxFee :: !Coin - , atbrValidityInterval :: !ValidityInterval - , atbrUpdate :: !(StrictMaybe (Update era)) - , atbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) - , atbrMint :: !ma - } - -deriving instance - (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era), NFData ma) => - NFData (AllegraTxBodyRaw ma era) - -deriving instance - (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era), Eq ma) => - Eq (AllegraTxBodyRaw ma era) - -deriving instance - (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era), Show ma) => - Show (AllegraTxBodyRaw ma era) - -deriving instance Generic (AllegraTxBodyRaw ma era) - -deriving instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era), NoThunks ma) => - NoThunks (AllegraTxBodyRaw ma era) - -instance (DecCBOR ma, Monoid ma, AllegraEraTxBody era) => DecCBOR (AllegraTxBodyRaw ma era) where - decCBOR = - decode - ( SparseKeyed - "AllegraTxBodyRaw" - emptyAllegraTxBodyRaw - bodyFields - [(0, "atbrInputs"), (1, "atbrOutputs"), (2, "atbrTxFee")] - ) - -instance AllegraEraTxBody era => DecCBOR (Annotator (AllegraTxBodyRaw () era)) where - decCBOR = pure <$> decCBOR - --- Sparse encodings of AllegraTxBodyRaw, the key values are fixed by backward compatibility --- concerns as we want the ShelleyTxBody to deserialise as AllegraTxBody. --- txXparse and bodyFields should be Duals, visual inspection helps ensure this. -instance - (EraTxOut era, EraTxCert era, Eq ma, EncCBOR ma, Monoid ma) => - EncCBOR (AllegraTxBodyRaw ma era) - where - encCBOR (AllegraTxBodyRaw inp out cert wdrl fee (ValidityInterval bot top) up hash frge) = - encode $ - Keyed - ( \i o f topx c w u h botx forg -> - AllegraTxBodyRaw i o c w f (ValidityInterval botx topx) u h forg - ) - !> Key 0 (To inp) -- We don't have to send these in TxBodyX order - !> Key 1 (To out) -- Just hack up a fake constructor with the lambda. - !> Key 2 (To fee) - !> encodeKeyedStrictMaybe 3 top - !> Omit null (Key 4 (To cert)) - !> Omit (null . unWithdrawals) (Key 5 (To wdrl)) - !> encodeKeyedStrictMaybe 6 up - !> encodeKeyedStrictMaybe 7 hash - !> encodeKeyedStrictMaybe 8 bot - !> Omit (== mempty) (Key 9 (To frge)) - -bodyFields :: (DecCBOR ma, EraTxOut era, EraTxCert era) => Word -> Field (AllegraTxBodyRaw ma era) -bodyFields 0 = field (\x tx -> tx {atbrInputs = x}) From -bodyFields 1 = field (\x tx -> tx {atbrOutputs = x}) From -bodyFields 2 = field (\x tx -> tx {atbrTxFee = x}) From -bodyFields 3 = - ofield - ( \x tx -> - tx - { atbrValidityInterval = - (atbrValidityInterval tx) {invalidHereafter = x} - } - ) - From -bodyFields 4 = field (\x tx -> tx {atbrCerts = x}) From -bodyFields 5 = field (\x tx -> tx {atbrWithdrawals = x}) From -bodyFields 6 = ofield (\x tx -> tx {atbrUpdate = x}) From -bodyFields 7 = ofield (\x tx -> tx {atbrAuxDataHash = x}) From -bodyFields 8 = - ofield - ( \x tx -> - tx - { atbrValidityInterval = - (atbrValidityInterval tx) {invalidBefore = x} - } - ) - From -bodyFields 9 = field (\x tx -> tx {atbrMint = x}) From -bodyFields n = invalidField n - -emptyAllegraTxBodyRaw :: Monoid ma => AllegraTxBodyRaw ma era -emptyAllegraTxBodyRaw = - AllegraTxBodyRaw - empty - (fromList []) - (fromList []) - (Withdrawals Map.empty) - (Coin 0) - (ValidityInterval SNothing SNothing) - SNothing - SNothing - mempty - --- =========================================================================== --- Wrap it all up in a newtype, hiding the insides with a pattern construtor. - -newtype AllegraTxBody e = TxBodyConstr (MemoBytes (AllegraTxBodyRaw ()) e) - deriving newtype (SafeToHash, ToCBOR) - -instance Memoized AllegraTxBody where - type RawType AllegraTxBody = AllegraTxBodyRaw () - -deriving instance - (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => - Eq (AllegraTxBody era) - -deriving instance - (Era era, Show (TxOut era), Show (TxCert era), Compactible (Value era), Show (PParamsUpdate era)) => - Show (AllegraTxBody era) - -deriving instance Generic (AllegraTxBody era) - -deriving newtype instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => - NoThunks (AllegraTxBody era) - -deriving newtype instance - ( NFData (TxOut era) - , NFData (TxCert era) - , NFData (PParamsUpdate era) - , Era era - ) => - NFData (AllegraTxBody era) - --- | Encodes memoized bytes created upon construction. -instance Era era => EncCBOR (AllegraTxBody era) - -deriving via - Mem (AllegraTxBodyRaw ()) era - instance - AllegraEraTxBody era => DecCBOR (Annotator (AllegraTxBody era)) - -type instance MemoHashIndex (AllegraTxBodyRaw c) = EraIndependentTxBody - -instance (c ~ EraCrypto era, Era era) => HashAnnotated (AllegraTxBody era) EraIndependentTxBody c where - hashAnnotated = getMemoSafeHash - --- | A pattern to keep the newtype and the MemoBytes hidden -pattern AllegraTxBody :: - (EraTxOut era, EraTxCert era) => - Set (TxIn (EraCrypto era)) -> - StrictSeq (TxOut era) -> - StrictSeq (TxCert era) -> - Withdrawals (EraCrypto era) -> - Coin -> - ValidityInterval -> - StrictMaybe (Update era) -> - StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> - AllegraTxBody era -pattern AllegraTxBody - { atbInputs - , atbOutputs - , atbCerts - , atbWithdrawals - , atbTxFee - , atbValidityInterval - , atbUpdate - , atbAuxDataHash - } <- - ( getMemoRawType -> - AllegraTxBodyRaw - { atbrInputs = atbInputs - , atbrOutputs = atbOutputs - , atbrCerts = atbCerts - , atbrWithdrawals = atbWithdrawals - , atbrTxFee = atbTxFee - , atbrValidityInterval = atbValidityInterval - , atbrUpdate = atbUpdate - , atbrAuxDataHash = atbAuxDataHash - } - ) - where - AllegraTxBody - inputs - outputs - certs - withdrawals - txFee - validityInterval - update - auxDataHash = - mkMemoized $ - AllegraTxBodyRaw - { atbrInputs = inputs - , atbrOutputs = outputs - , atbrCerts = certs - , atbrWithdrawals = withdrawals - , atbrTxFee = txFee - , atbrValidityInterval = validityInterval - , atbrUpdate = update - , atbrAuxDataHash = auxDataHash - , atbrMint = () - } - -{-# COMPLETE AllegraTxBody #-} - -instance Crypto c => EraTxBody (AllegraEra c) where - {-# SPECIALIZE instance EraTxBody (AllegraEra StandardCrypto) #-} - - type TxBody (AllegraEra c) = AllegraTxBody (AllegraEra c) - - mkBasicTxBody = mkMemoized emptyAllegraTxBodyRaw - - inputsTxBodyL = - lensMemoRawType atbrInputs $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} - {-# INLINEABLE inputsTxBodyL #-} - - outputsTxBodyL = - lensMemoRawType atbrOutputs $ \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} - {-# INLINEABLE outputsTxBodyL #-} - - feeTxBodyL = - lensMemoRawType atbrTxFee $ \txBodyRaw fee -> txBodyRaw {atbrTxFee = fee} - {-# INLINEABLE feeTxBodyL #-} - - auxDataHashTxBodyL = - lensMemoRawType atbrAuxDataHash $ - \txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} - {-# INLINEABLE auxDataHashTxBodyL #-} - - spendableInputsTxBodyF = inputsTxBodyL - {-# INLINE spendableInputsTxBodyF #-} - - allInputsTxBodyF = inputsTxBodyL - {-# INLINEABLE allInputsTxBodyF #-} - - withdrawalsTxBodyL = - lensMemoRawType atbrWithdrawals $ - \txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} - {-# INLINEABLE withdrawalsTxBodyL #-} - - certsTxBodyL = - lensMemoRawType atbrCerts $ \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} - {-# INLINEABLE certsTxBodyL #-} - - getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody - - upgradeTxBody txBody = do - certs <- traverse upgradeTxCert (txBody ^. certsTxBodyL) - pure $ - AllegraTxBody - { atbInputs = txBody ^. inputsTxBodyL - , atbOutputs = upgradeTxOut <$> (txBody ^. outputsTxBodyL) - , atbCerts = certs - , atbWithdrawals = txBody ^. withdrawalsTxBodyL - , atbTxFee = txBody ^. feeTxBodyL - , atbValidityInterval = ttlToValidityInterval (txBody ^. ttlTxBodyL) - , atbUpdate = upgradeUpdate () <$> (txBody ^. updateTxBodyL) - , atbAuxDataHash = txBody ^. auxDataHashTxBodyL - } - where - ttlToValidityInterval :: SlotNo -> ValidityInterval - ttlToValidityInterval ttl = ValidityInterval SNothing (SJust ttl) - -instance Crypto c => ShelleyEraTxBody (AllegraEra c) where - {-# SPECIALIZE instance ShelleyEraTxBody (AllegraEra StandardCrypto) #-} - - ttlTxBodyL = notSupportedInThisEraL - {-# INLINEABLE ttlTxBodyL #-} - - updateTxBodyL = - lensMemoRawType atbrUpdate $ \txBodyRaw update -> txBodyRaw {atbrUpdate = update} - {-# INLINEABLE updateTxBodyL #-} - -instance Crypto c => AllegraEraTxBody (AllegraEra c) where - {-# SPECIALIZE instance AllegraEraTxBody (AllegraEra StandardCrypto) #-} - - vldtTxBodyL = - lensMemoRawType atbrValidityInterval $ - \txBodyRaw vldt -> txBodyRaw {atbrValidityInterval = vldt} - {-# INLINEABLE vldtTxBodyL #-} - -instance - (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => - EqRaw (AllegraTxBody era) +import Cardano.Ledger.Allegra.TxBody.Internal diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs new file mode 100644 index 00000000000..277d8a1dab3 --- /dev/null +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Provides Allegra TxBody internals +-- +-- = Warning +-- +-- This module is considered __internal__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +module Cardano.Ledger.Allegra.TxBody.Internal ( + AllegraEraTxBody (..), + AllegraTxBody ( + .., + AllegraTxBody, + atbAuxDataHash, + atbCerts, + atbInputs, + atbOutputs, + atbTxFee, + atbUpdate, + atbValidityInterval, + atbWithdrawals + ), + emptyAllegraTxBodyRaw, + AllegraTxBodyRaw (..), + StrictMaybe (..), + ValidityInterval (..), +) +where + +import Cardano.Ledger.Allegra.Era (AllegraEra) +import Cardano.Ledger.Allegra.Scripts (ValidityInterval (..)) +import Cardano.Ledger.Allegra.TxCert () +import Cardano.Ledger.Allegra.TxOut () +import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) +import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (SJust, SNothing)) +import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR (..), ToCBOR) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Encode (..), + Field, + decode, + encode, + encodeKeyedStrictMaybe, + field, + invalidField, + ofield, + (!>), + ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Compactible (Compactible (..)) +import Cardano.Ledger.Core +import Cardano.Ledger.Crypto (Crypto, StandardCrypto) +import Cardano.Ledger.MemoBytes ( + EqRaw, + Mem, + MemoBytes, + MemoHashIndex, + Memoized (RawType), + getMemoRawType, + getMemoSafeHash, + lensMemoRawType, + mkMemoized, + ) +import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.PParams (Update (..), upgradeUpdate) +import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) +import Cardano.Ledger.TxIn (TxIn (..)) +import Control.DeepSeq (NFData (..)) +import qualified Data.Map.Strict as Map +import Data.Sequence.Strict (StrictSeq, fromList) +import Data.Set (Set, empty) +import GHC.Generics (Generic) +import Lens.Micro +import NoThunks.Class (NoThunks (..)) + +class EraTxBody era => AllegraEraTxBody era where + vldtTxBodyL :: Lens' (TxBody era) ValidityInterval + +-- ======================================================= + +data AllegraTxBodyRaw ma era = AllegraTxBodyRaw + { atbrInputs :: !(Set (TxIn (EraCrypto era))) + , atbrOutputs :: !(StrictSeq (TxOut era)) + , atbrCerts :: !(StrictSeq (TxCert era)) + , atbrWithdrawals :: !(Withdrawals (EraCrypto era)) + , atbrTxFee :: !Coin + , atbrValidityInterval :: !ValidityInterval + , atbrUpdate :: !(StrictMaybe (Update era)) + , atbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) + , atbrMint :: !ma + } + +deriving instance + (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era), NFData ma) => + NFData (AllegraTxBodyRaw ma era) + +deriving instance + (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era), Eq ma) => + Eq (AllegraTxBodyRaw ma era) + +deriving instance + (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era), Show ma) => + Show (AllegraTxBodyRaw ma era) + +deriving instance Generic (AllegraTxBodyRaw ma era) + +deriving instance + (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era), NoThunks ma) => + NoThunks (AllegraTxBodyRaw ma era) + +instance (DecCBOR ma, Monoid ma, AllegraEraTxBody era) => DecCBOR (AllegraTxBodyRaw ma era) where + decCBOR = + decode + ( SparseKeyed + "AllegraTxBodyRaw" + emptyAllegraTxBodyRaw + bodyFields + [(0, "atbrInputs"), (1, "atbrOutputs"), (2, "atbrTxFee")] + ) + +instance AllegraEraTxBody era => DecCBOR (Annotator (AllegraTxBodyRaw () era)) where + decCBOR = pure <$> decCBOR + +-- Sparse encodings of AllegraTxBodyRaw, the key values are fixed by backward compatibility +-- concerns as we want the ShelleyTxBody to deserialise as AllegraTxBody. +-- txXparse and bodyFields should be Duals, visual inspection helps ensure this. +instance + (EraTxOut era, EraTxCert era, Eq ma, EncCBOR ma, Monoid ma) => + EncCBOR (AllegraTxBodyRaw ma era) + where + encCBOR (AllegraTxBodyRaw inp out cert wdrl fee (ValidityInterval bot top) up hash frge) = + encode $ + Keyed + ( \i o f topx c w u h botx forg -> + AllegraTxBodyRaw i o c w f (ValidityInterval botx topx) u h forg + ) + !> Key 0 (To inp) -- We don't have to send these in TxBodyX order + !> Key 1 (To out) -- Just hack up a fake constructor with the lambda. + !> Key 2 (To fee) + !> encodeKeyedStrictMaybe 3 top + !> Omit null (Key 4 (To cert)) + !> Omit (null . unWithdrawals) (Key 5 (To wdrl)) + !> encodeKeyedStrictMaybe 6 up + !> encodeKeyedStrictMaybe 7 hash + !> encodeKeyedStrictMaybe 8 bot + !> Omit (== mempty) (Key 9 (To frge)) + +bodyFields :: (DecCBOR ma, EraTxOut era, EraTxCert era) => Word -> Field (AllegraTxBodyRaw ma era) +bodyFields 0 = field (\x tx -> tx {atbrInputs = x}) From +bodyFields 1 = field (\x tx -> tx {atbrOutputs = x}) From +bodyFields 2 = field (\x tx -> tx {atbrTxFee = x}) From +bodyFields 3 = + ofield + ( \x tx -> + tx + { atbrValidityInterval = + (atbrValidityInterval tx) {invalidHereafter = x} + } + ) + From +bodyFields 4 = field (\x tx -> tx {atbrCerts = x}) From +bodyFields 5 = field (\x tx -> tx {atbrWithdrawals = x}) From +bodyFields 6 = ofield (\x tx -> tx {atbrUpdate = x}) From +bodyFields 7 = ofield (\x tx -> tx {atbrAuxDataHash = x}) From +bodyFields 8 = + ofield + ( \x tx -> + tx + { atbrValidityInterval = + (atbrValidityInterval tx) {invalidBefore = x} + } + ) + From +bodyFields 9 = field (\x tx -> tx {atbrMint = x}) From +bodyFields n = invalidField n + +emptyAllegraTxBodyRaw :: Monoid ma => AllegraTxBodyRaw ma era +emptyAllegraTxBodyRaw = + AllegraTxBodyRaw + empty + (fromList []) + (fromList []) + (Withdrawals Map.empty) + (Coin 0) + (ValidityInterval SNothing SNothing) + SNothing + SNothing + mempty + +-- =========================================================================== +-- Wrap it all up in a newtype, hiding the insides with a pattern construtor. + +newtype AllegraTxBody e = TxBodyConstr (MemoBytes (AllegraTxBodyRaw ()) e) + deriving newtype (SafeToHash, ToCBOR) + +instance Memoized AllegraTxBody where + type RawType AllegraTxBody = AllegraTxBodyRaw () + +deriving instance + (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => + Eq (AllegraTxBody era) + +deriving instance + (Era era, Show (TxOut era), Show (TxCert era), Compactible (Value era), Show (PParamsUpdate era)) => + Show (AllegraTxBody era) + +deriving instance Generic (AllegraTxBody era) + +deriving newtype instance + (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => + NoThunks (AllegraTxBody era) + +deriving newtype instance + ( NFData (TxOut era) + , NFData (TxCert era) + , NFData (PParamsUpdate era) + , Era era + ) => + NFData (AllegraTxBody era) + +-- | Encodes memoized bytes created upon construction. +instance Era era => EncCBOR (AllegraTxBody era) + +deriving via + Mem (AllegraTxBodyRaw ()) era + instance + AllegraEraTxBody era => DecCBOR (Annotator (AllegraTxBody era)) + +type instance MemoHashIndex (AllegraTxBodyRaw c) = EraIndependentTxBody + +instance (c ~ EraCrypto era, Era era) => HashAnnotated (AllegraTxBody era) EraIndependentTxBody c where + hashAnnotated = getMemoSafeHash + +-- | A pattern to keep the newtype and the MemoBytes hidden +pattern AllegraTxBody :: + (EraTxOut era, EraTxCert era) => + Set (TxIn (EraCrypto era)) -> + StrictSeq (TxOut era) -> + StrictSeq (TxCert era) -> + Withdrawals (EraCrypto era) -> + Coin -> + ValidityInterval -> + StrictMaybe (Update era) -> + StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> + AllegraTxBody era +pattern AllegraTxBody + { atbInputs + , atbOutputs + , atbCerts + , atbWithdrawals + , atbTxFee + , atbValidityInterval + , atbUpdate + , atbAuxDataHash + } <- + ( getMemoRawType -> + AllegraTxBodyRaw + { atbrInputs = atbInputs + , atbrOutputs = atbOutputs + , atbrCerts = atbCerts + , atbrWithdrawals = atbWithdrawals + , atbrTxFee = atbTxFee + , atbrValidityInterval = atbValidityInterval + , atbrUpdate = atbUpdate + , atbrAuxDataHash = atbAuxDataHash + } + ) + where + AllegraTxBody + inputs + outputs + certs + withdrawals + txFee + validityInterval + update + auxDataHash = + mkMemoized $ + AllegraTxBodyRaw + { atbrInputs = inputs + , atbrOutputs = outputs + , atbrCerts = certs + , atbrWithdrawals = withdrawals + , atbrTxFee = txFee + , atbrValidityInterval = validityInterval + , atbrUpdate = update + , atbrAuxDataHash = auxDataHash + , atbrMint = () + } + +{-# COMPLETE AllegraTxBody #-} + +instance Crypto c => EraTxBody (AllegraEra c) where + {-# SPECIALIZE instance EraTxBody (AllegraEra StandardCrypto) #-} + + type TxBody (AllegraEra c) = AllegraTxBody (AllegraEra c) + + mkBasicTxBody = mkMemoized emptyAllegraTxBodyRaw + + inputsTxBodyL = + lensMemoRawType atbrInputs $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} + {-# INLINEABLE inputsTxBodyL #-} + + outputsTxBodyL = + lensMemoRawType atbrOutputs $ \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} + {-# INLINEABLE outputsTxBodyL #-} + + feeTxBodyL = + lensMemoRawType atbrTxFee $ \txBodyRaw fee -> txBodyRaw {atbrTxFee = fee} + {-# INLINEABLE feeTxBodyL #-} + + auxDataHashTxBodyL = + lensMemoRawType atbrAuxDataHash $ + \txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} + {-# INLINEABLE auxDataHashTxBodyL #-} + + spendableInputsTxBodyF = inputsTxBodyL + {-# INLINE spendableInputsTxBodyF #-} + + allInputsTxBodyF = inputsTxBodyL + {-# INLINEABLE allInputsTxBodyF #-} + + withdrawalsTxBodyL = + lensMemoRawType atbrWithdrawals $ + \txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} + {-# INLINEABLE withdrawalsTxBodyL #-} + + certsTxBodyL = + lensMemoRawType atbrCerts $ \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} + {-# INLINEABLE certsTxBodyL #-} + + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody + + upgradeTxBody txBody = do + certs <- traverse upgradeTxCert (txBody ^. certsTxBodyL) + pure $ + AllegraTxBody + { atbInputs = txBody ^. inputsTxBodyL + , atbOutputs = upgradeTxOut <$> (txBody ^. outputsTxBodyL) + , atbCerts = certs + , atbWithdrawals = txBody ^. withdrawalsTxBodyL + , atbTxFee = txBody ^. feeTxBodyL + , atbValidityInterval = ttlToValidityInterval (txBody ^. ttlTxBodyL) + , atbUpdate = upgradeUpdate () <$> (txBody ^. updateTxBodyL) + , atbAuxDataHash = txBody ^. auxDataHashTxBodyL + } + where + ttlToValidityInterval :: SlotNo -> ValidityInterval + ttlToValidityInterval ttl = ValidityInterval SNothing (SJust ttl) + +instance Crypto c => ShelleyEraTxBody (AllegraEra c) where + {-# SPECIALIZE instance ShelleyEraTxBody (AllegraEra StandardCrypto) #-} + + ttlTxBodyL = notSupportedInThisEraL + {-# INLINEABLE ttlTxBodyL #-} + + updateTxBodyL = + lensMemoRawType atbrUpdate $ \txBodyRaw update -> txBodyRaw {atbrUpdate = update} + {-# INLINEABLE updateTxBodyL #-} + +instance Crypto c => AllegraEraTxBody (AllegraEra c) where + {-# SPECIALIZE instance AllegraEraTxBody (AllegraEra StandardCrypto) #-} + + vldtTxBodyL = + lensMemoRawType atbrValidityInterval $ + \txBodyRaw vldt -> txBodyRaw {atbrValidityInterval = vldt} + {-# INLINEABLE vldtTxBodyL #-} + +instance + (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => + EqRaw (AllegraTxBody era) diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index befa926064c..e25cddfd988 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -44,8 +44,10 @@ library Cardano.Ledger.Alonzo.Tx Cardano.Ledger.Alonzo.TxAuxData Cardano.Ledger.Alonzo.TxBody + Cardano.Ledger.Alonzo.TxBody.Internal Cardano.Ledger.Alonzo.TxOut Cardano.Ledger.Alonzo.TxSeq + Cardano.Ledger.Alonzo.TxSeq.Internal Cardano.Ledger.Alonzo.TxWits Cardano.Ledger.Alonzo.UTxO diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs index 0cd630af704..9048a44c89f 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs @@ -1,27 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Cardano.Ledger.Alonzo.TxBody ( AlonzoTxOut (..), AlonzoEraTxOut (..), @@ -80,636 +56,4 @@ module Cardano.Ledger.Alonzo.TxBody ( ) where -import Cardano.Ledger.Alonzo.Era -import Cardano.Ledger.Alonzo.PParams () -import Cardano.Ledger.Alonzo.Scripts ( - AlonzoPlutusPurpose (..), - AsItem (..), - AsIx (..), - AsIxItem (..), - PlutusPurpose, - ) -import Cardano.Ledger.Alonzo.TxAuxData (AuxiliaryDataHash (..)) -import Cardano.Ledger.Alonzo.TxCert () -import Cardano.Ledger.Alonzo.TxOut -import Cardano.Ledger.BaseTypes ( - Network (..), - StrictMaybe (..), - ) -import Cardano.Ledger.Binary ( - Annotator, - DecCBOR (..), - EncCBOR (..), - ToCBOR (..), - ) -import Cardano.Ledger.Binary.Coders -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Crypto -import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) -import Cardano.Ledger.Mary (MaryEra) -import Cardano.Ledger.Mary.Core -import Cardano.Ledger.Mary.TxBody (MaryTxBody (..)) -import Cardano.Ledger.Mary.Value ( - MaryValue (MaryValue), - MultiAsset (..), - PolicyID (..), - policies, - ) -import Cardano.Ledger.MemoBytes ( - EqRaw, - Mem, - MemoBytes, - MemoHashIndex, - Memoized (..), - getMemoRawType, - getMemoSafeHash, - lensMemoRawType, - mkMemoized, - ) -import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeHash, SafeToHash) -import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (..), Update (..)) -import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) -import Cardano.Ledger.TxIn (TxIn (..)) -import Control.Arrow (left) -import Control.DeepSeq (NFData (..)) -import Control.Monad (when) -import Data.Default.Class (def) -import qualified Data.Map.Strict as Map -import Data.Maybe.Strict (isSJust) -import Data.OSet.Strict (OSet) -import qualified Data.OSet.Strict as OSet -import Data.Sequence.Strict (StrictSeq) -import qualified Data.Sequence.Strict as StrictSeq -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Typeable (Typeable) -import Data.Void (absurd) -import Data.Word (Word32) -import GHC.Generics (Generic) -import Lens.Micro -import NoThunks.Class (NoThunks) - -type ScriptIntegrityHash c = SafeHash c EraIndependentScriptIntegrity - -class (MaryEraTxBody era, AlonzoEraTxOut era) => AlonzoEraTxBody era where - collateralInputsTxBodyL :: Lens' (TxBody era) (Set (TxIn (EraCrypto era))) - - reqSignerHashesTxBodyL :: Lens' (TxBody era) (Set (KeyHash 'Witness (EraCrypto era))) - - scriptIntegrityHashTxBodyL :: - Lens' (TxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era))) - - networkIdTxBodyL :: Lens' (TxBody era) (StrictMaybe Network) - - -- | This function is called @rdptr@ in the spec. Given a `TxBody` and a plutus - -- purpose with an item, we should be able to find the plutus purpose as in index - redeemerPointer :: - TxBody era -> - PlutusPurpose AsItem era -> - StrictMaybe (PlutusPurpose AsIx era) - - -- | This is an inverse of `redeemerPointer`. Given purpose as an index return it as an item. - redeemerPointerInverse :: - TxBody era -> - PlutusPurpose AsIx era -> - StrictMaybe (PlutusPurpose AsIxItem era) - --- ====================================== - -data AlonzoTxBodyRaw era = AlonzoTxBodyRaw - { atbrInputs :: !(Set (TxIn (EraCrypto era))) - , atbrCollateral :: !(Set (TxIn (EraCrypto era))) - , atbrOutputs :: !(StrictSeq (TxOut era)) - , atbrCerts :: !(StrictSeq (TxCert era)) - , atbrWithdrawals :: !(Withdrawals (EraCrypto era)) - , atbrTxFee :: !Coin - , atbrValidityInterval :: !ValidityInterval - , atbrUpdate :: !(StrictMaybe (Update era)) - , atbrReqSignerHashes :: Set (KeyHash 'Witness (EraCrypto era)) - , atbrMint :: !(MultiAsset (EraCrypto era)) - , atbrScriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) - , atbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) - , atbrTxNetworkId :: !(StrictMaybe Network) - } - deriving (Generic, Typeable) - -deriving instance - (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => - Eq (AlonzoTxBodyRaw era) - -instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => - NoThunks (AlonzoTxBodyRaw era) - -instance - (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => - NFData (AlonzoTxBodyRaw era) - -deriving instance - (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => - Show (AlonzoTxBodyRaw era) - -newtype AlonzoTxBody era = TxBodyConstr (MemoBytes AlonzoTxBodyRaw era) - deriving (ToCBOR, Generic) - deriving newtype (SafeToHash) - -instance Memoized AlonzoTxBody where - type RawType AlonzoTxBody = AlonzoTxBodyRaw - -data AlonzoTxBodyUpgradeError - = -- | The TxBody contains a protocol parameter update that attempts to update - -- the min UTxO. Since this doesn't exist in Alonzo, we fail if an attempt is - -- made to update it. - ATBUEMinUTxOUpdated - deriving (Show) - -instance Crypto c => EraTxBody (AlonzoEra c) where - {-# SPECIALIZE instance EraTxBody (AlonzoEra StandardCrypto) #-} - - type TxBody (AlonzoEra c) = AlonzoTxBody (AlonzoEra c) - type TxBodyUpgradeError (AlonzoEra c) = AlonzoTxBodyUpgradeError - - mkBasicTxBody = mkMemoized emptyAlonzoTxBodyRaw - - inputsTxBodyL = - lensMemoRawType atbrInputs (\txBodyRaw inputs_ -> txBodyRaw {atbrInputs = inputs_}) - {-# INLINEABLE inputsTxBodyL #-} - - outputsTxBodyL = - lensMemoRawType atbrOutputs (\txBodyRaw outputs_ -> txBodyRaw {atbrOutputs = outputs_}) - {-# INLINEABLE outputsTxBodyL #-} - - feeTxBodyL = - lensMemoRawType atbrTxFee (\txBodyRaw fee_ -> txBodyRaw {atbrTxFee = fee_}) - {-# INLINEABLE feeTxBodyL #-} - - auxDataHashTxBodyL = - lensMemoRawType - atbrAuxDataHash - (\txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash}) - {-# INLINEABLE auxDataHashTxBodyL #-} - - spendableInputsTxBodyF = allInputsTxBodyF - {-# INLINE spendableInputsTxBodyF #-} - - allInputsTxBodyF = - to $ \txBody -> (txBody ^. inputsTxBodyL) `Set.union` (txBody ^. collateralInputsTxBodyL) - {-# INLINEABLE allInputsTxBodyF #-} - - withdrawalsTxBodyL = - lensMemoRawType - atbrWithdrawals - (\txBodyRaw withdrawals_ -> txBodyRaw {atbrWithdrawals = withdrawals_}) - {-# INLINEABLE withdrawalsTxBodyL #-} - - certsTxBodyL = - lensMemoRawType atbrCerts (\txBodyRaw certs_ -> txBodyRaw {atbrCerts = certs_}) - {-# INLINEABLE certsTxBodyL #-} - - getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody - - upgradeTxBody - MaryTxBody - { mtbInputs - , mtbOutputs - , mtbCerts - , mtbWithdrawals - , mtbTxFee - , mtbValidityInterval - , mtbUpdate - , mtbAuxDataHash - , mtbMint - } = do - certs <- - traverse - (left absurd . upgradeTxCert) - mtbCerts - - updates <- traverse upgradeUpdate mtbUpdate - pure $ - AlonzoTxBody - { atbInputs = mtbInputs - , atbOutputs = upgradeTxOut <$> mtbOutputs - , atbCerts = certs - , atbWithdrawals = mtbWithdrawals - , atbTxFee = mtbTxFee - , atbValidityInterval = mtbValidityInterval - , atbUpdate = updates - , atbAuxDataHash = mtbAuxDataHash - , atbMint = mtbMint - , atbCollateral = mempty - , atbReqSignerHashes = mempty - , atbScriptIntegrityHash = SNothing - , atbTxNetworkId = SNothing - } - where - upgradeUpdate :: - Update (MaryEra c) -> - Either AlonzoTxBodyUpgradeError (Update (AlonzoEra c)) - upgradeUpdate (Update pp epoch) = - Update <$> upgradeProposedPPUpdates pp <*> pure epoch - - upgradeProposedPPUpdates :: - ProposedPPUpdates (MaryEra c) -> - Either AlonzoTxBodyUpgradeError (ProposedPPUpdates (AlonzoEra c)) - upgradeProposedPPUpdates (ProposedPPUpdates m) = - ProposedPPUpdates - <$> traverse - ( \ppu -> do - when (isSJust $ ppu ^. ppuMinUTxOValueL) $ - Left ATBUEMinUTxOUpdated - pure $ upgradePParamsUpdate def ppu - ) - m - -instance Crypto c => ShelleyEraTxBody (AlonzoEra c) where - {-# SPECIALIZE instance ShelleyEraTxBody (AlonzoEra StandardCrypto) #-} - - ttlTxBodyL = notSupportedInThisEraL - - updateTxBodyL = - lensMemoRawType atbrUpdate (\txBodyRaw update_ -> txBodyRaw {atbrUpdate = update_}) - {-# INLINEABLE updateTxBodyL #-} - -instance Crypto c => AllegraEraTxBody (AlonzoEra c) where - {-# SPECIALIZE instance AllegraEraTxBody (AlonzoEra StandardCrypto) #-} - - vldtTxBodyL = - lensMemoRawType atbrValidityInterval (\txBodyRaw vldt_ -> txBodyRaw {atbrValidityInterval = vldt_}) - {-# INLINEABLE vldtTxBodyL #-} - -instance Crypto c => MaryEraTxBody (AlonzoEra c) where - {-# SPECIALIZE instance MaryEraTxBody (AlonzoEra StandardCrypto) #-} - - mintTxBodyL = - lensMemoRawType atbrMint (\txBodyRaw mint_ -> txBodyRaw {atbrMint = mint_}) - {-# INLINEABLE mintTxBodyL #-} - - mintValueTxBodyF = mintTxBodyL . to (MaryValue mempty) - {-# INLINEABLE mintValueTxBodyF #-} - - mintedTxBodyF = to (policies . atbrMint . getMemoRawType) - {-# INLINEABLE mintedTxBodyF #-} - -instance Crypto c => AlonzoEraTxBody (AlonzoEra c) where - {-# SPECIALIZE instance AlonzoEraTxBody (AlonzoEra StandardCrypto) #-} - - collateralInputsTxBodyL = - lensMemoRawType atbrCollateral (\txBodyRaw collateral_ -> txBodyRaw {atbrCollateral = collateral_}) - {-# INLINEABLE collateralInputsTxBodyL #-} - - reqSignerHashesTxBodyL = - lensMemoRawType - atbrReqSignerHashes - (\txBodyRaw reqSignerHashes_ -> txBodyRaw {atbrReqSignerHashes = reqSignerHashes_}) - {-# INLINEABLE reqSignerHashesTxBodyL #-} - - scriptIntegrityHashTxBodyL = - lensMemoRawType - atbrScriptIntegrityHash - (\txBodyRaw scriptIntegrityHash_ -> txBodyRaw {atbrScriptIntegrityHash = scriptIntegrityHash_}) - {-# INLINEABLE scriptIntegrityHashTxBodyL #-} - - networkIdTxBodyL = - lensMemoRawType atbrTxNetworkId (\txBodyRaw networkId -> txBodyRaw {atbrTxNetworkId = networkId}) - {-# INLINEABLE networkIdTxBodyL #-} - - redeemerPointer = alonzoRedeemerPointer - - redeemerPointerInverse = alonzoRedeemerPointerInverse - -deriving newtype instance - (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => - Eq (AlonzoTxBody era) - -deriving instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => - NoThunks (AlonzoTxBody era) - -deriving instance - (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => - NFData (AlonzoTxBody era) - -deriving instance - (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => - Show (AlonzoTxBody era) - -deriving via - (Mem AlonzoTxBodyRaw era) - instance - (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => - DecCBOR (Annotator (AlonzoTxBody era)) - -pattern AlonzoTxBody :: - (EraTxOut era, EraTxCert era) => - Set (TxIn (EraCrypto era)) -> - Set (TxIn (EraCrypto era)) -> - StrictSeq (TxOut era) -> - StrictSeq (TxCert era) -> - Withdrawals (EraCrypto era) -> - Coin -> - ValidityInterval -> - StrictMaybe (Update era) -> - Set (KeyHash 'Witness (EraCrypto era)) -> - MultiAsset (EraCrypto era) -> - StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -> - StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> - StrictMaybe Network -> - AlonzoTxBody era -pattern AlonzoTxBody - { atbInputs - , atbCollateral - , atbOutputs - , atbCerts - , atbWithdrawals - , atbTxFee - , atbValidityInterval - , atbUpdate - , atbReqSignerHashes - , atbMint - , atbScriptIntegrityHash - , atbAuxDataHash - , atbTxNetworkId - } <- - ( getMemoRawType -> - AlonzoTxBodyRaw - { atbrInputs = atbInputs - , atbrCollateral = atbCollateral - , atbrOutputs = atbOutputs - , atbrCerts = atbCerts - , atbrWithdrawals = atbWithdrawals - , atbrTxFee = atbTxFee - , atbrValidityInterval = atbValidityInterval - , atbrUpdate = atbUpdate - , atbrReqSignerHashes = atbReqSignerHashes - , atbrMint = atbMint - , atbrScriptIntegrityHash = atbScriptIntegrityHash - , atbrAuxDataHash = atbAuxDataHash - , atbrTxNetworkId = atbTxNetworkId - } - ) - where - AlonzoTxBody - inputs - collateral - outputs - certs - withdrawals - txFee - validityInterval - update - reqSignerHashes - mint - scriptIntegrityHash - auxDataHash - txNetworkId = - mkMemoized $ - AlonzoTxBodyRaw - { atbrInputs = inputs - , atbrCollateral = collateral - , atbrOutputs = outputs - , atbrCerts = certs - , atbrWithdrawals = withdrawals - , atbrTxFee = txFee - , atbrValidityInterval = validityInterval - , atbrUpdate = update - , atbrReqSignerHashes = reqSignerHashes - , atbrMint = mint - , atbrScriptIntegrityHash = scriptIntegrityHash - , atbrAuxDataHash = auxDataHash - , atbrTxNetworkId = txNetworkId - } - -{-# COMPLETE AlonzoTxBody #-} - -type instance MemoHashIndex AlonzoTxBodyRaw = EraIndependentTxBody - -instance c ~ EraCrypto era => HashAnnotated (AlonzoTxBody era) EraIndependentTxBody c where - hashAnnotated = getMemoSafeHash - --- ============================================================================== --- We define these accessor functions manually, because if we define them using --- the record syntax in the TxBody pattern, they inherit the (AlonzoBody era) --- constraint as a precondition. This is unnecessary, as one can see below --- they need not be constrained at all. This should be fixed in the GHC compiler. - -inputs' :: AlonzoTxBody era -> Set (TxIn (EraCrypto era)) -collateral' :: AlonzoTxBody era -> Set (TxIn (EraCrypto era)) -outputs' :: AlonzoTxBody era -> StrictSeq (TxOut era) -certs' :: AlonzoTxBody era -> StrictSeq (TxCert era) -txfee' :: AlonzoTxBody era -> Coin -withdrawals' :: AlonzoTxBody era -> Withdrawals (EraCrypto era) -vldt' :: AlonzoTxBody era -> ValidityInterval -update' :: AlonzoTxBody era -> StrictMaybe (Update era) -reqSignerHashes' :: AlonzoTxBody era -> Set (KeyHash 'Witness (EraCrypto era)) -adHash' :: AlonzoTxBody era -> StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -mint' :: AlonzoTxBody era -> MultiAsset (EraCrypto era) -scriptIntegrityHash' :: AlonzoTxBody era -> StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -txnetworkid' :: AlonzoTxBody era -> StrictMaybe Network -inputs' = atbrInputs . getMemoRawType - -collateral' = atbrCollateral . getMemoRawType - -outputs' = atbrOutputs . getMemoRawType - -certs' = atbrCerts . getMemoRawType - -withdrawals' = atbrWithdrawals . getMemoRawType - -txfee' = atbrTxFee . getMemoRawType - -vldt' = atbrValidityInterval . getMemoRawType - -update' = atbrUpdate . getMemoRawType - -reqSignerHashes' = atbrReqSignerHashes . getMemoRawType - -adHash' = atbrAuxDataHash . getMemoRawType - -mint' = atbrMint . getMemoRawType - -scriptIntegrityHash' = atbrScriptIntegrityHash . getMemoRawType - -txnetworkid' = atbrTxNetworkId . getMemoRawType - -instance - (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => - EqRaw (AlonzoTxBody era) - --------------------------------------------------------------------------------- --- Serialisation --------------------------------------------------------------------------------- - --- | Encodes memoized bytes created upon construction. -instance Era era => EncCBOR (AlonzoTxBody era) - -instance - (Era era, EncCBOR (TxOut era), EncCBOR (TxCert era), EncCBOR (PParamsUpdate era)) => - EncCBOR (AlonzoTxBodyRaw era) - where - encCBOR - AlonzoTxBodyRaw - { atbrInputs - , atbrCollateral - , atbrOutputs - , atbrCerts - , atbrWithdrawals - , atbrTxFee - , atbrValidityInterval = ValidityInterval bot top - , atbrUpdate - , atbrReqSignerHashes - , atbrMint - , atbrScriptIntegrityHash - , atbrAuxDataHash - , atbrTxNetworkId - } = - encode $ - Keyed - ( \i ifee o f t c w u b rsh mi sh ah ni -> - AlonzoTxBodyRaw i ifee o c w f (ValidityInterval b t) u rsh mi sh ah ni - ) - !> Key 0 (To atbrInputs) - !> Omit null (Key 13 (To atbrCollateral)) - !> Key 1 (To atbrOutputs) - !> Key 2 (To atbrTxFee) - !> encodeKeyedStrictMaybe 3 top - !> Omit null (Key 4 (To atbrCerts)) - !> Omit (null . unWithdrawals) (Key 5 (To atbrWithdrawals)) - !> encodeKeyedStrictMaybe 6 atbrUpdate - !> encodeKeyedStrictMaybe 8 bot - !> Omit null (Key 14 (To atbrReqSignerHashes)) - !> Omit (== mempty) (Key 9 (To atbrMint)) - !> encodeKeyedStrictMaybe 11 atbrScriptIntegrityHash - !> encodeKeyedStrictMaybe 7 atbrAuxDataHash - !> encodeKeyedStrictMaybe 15 atbrTxNetworkId - -instance - (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => - DecCBOR (AlonzoTxBodyRaw era) - where - decCBOR = - decode $ - SparseKeyed - "AlonzoTxBodyRaw" - emptyAlonzoTxBodyRaw - bodyFields - requiredFields - where - bodyFields :: Word -> Field (AlonzoTxBodyRaw era) - bodyFields 0 = field (\x tx -> tx {atbrInputs = x}) From - bodyFields 13 = field (\x tx -> tx {atbrCollateral = x}) From - bodyFields 1 = field (\x tx -> tx {atbrOutputs = x}) From - bodyFields 2 = field (\x tx -> tx {atbrTxFee = x}) From - bodyFields 3 = - ofield - (\x tx -> tx {atbrValidityInterval = (atbrValidityInterval tx) {invalidHereafter = x}}) - From - bodyFields 4 = field (\x tx -> tx {atbrCerts = x}) From - bodyFields 5 = field (\x tx -> tx {atbrWithdrawals = x}) From - bodyFields 6 = ofield (\x tx -> tx {atbrUpdate = x}) From - bodyFields 7 = ofield (\x tx -> tx {atbrAuxDataHash = x}) From - bodyFields 8 = - ofield - (\x tx -> tx {atbrValidityInterval = (atbrValidityInterval tx) {invalidBefore = x}}) - From - bodyFields 9 = field (\x tx -> tx {atbrMint = x}) From - bodyFields 11 = ofield (\x tx -> tx {atbrScriptIntegrityHash = x}) From - bodyFields 14 = field (\x tx -> tx {atbrReqSignerHashes = x}) From - bodyFields 15 = ofield (\x tx -> tx {atbrTxNetworkId = x}) From - bodyFields n = field (\_ t -> t) (Invalid n) - requiredFields = - [ (0, "inputs") - , (1, "outputs") - , (2, "fee") - ] - -emptyAlonzoTxBodyRaw :: AlonzoTxBodyRaw era -emptyAlonzoTxBodyRaw = - AlonzoTxBodyRaw - mempty - mempty - StrictSeq.empty - StrictSeq.empty - (Withdrawals mempty) - mempty - (ValidityInterval SNothing SNothing) - SNothing - mempty - mempty - SNothing - SNothing - SNothing - -instance - (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => - DecCBOR (Annotator (AlonzoTxBodyRaw era)) - where - decCBOR = pure <$> decCBOR - -alonzoRedeemerPointer :: - forall era. - MaryEraTxBody era => - TxBody era -> - AlonzoPlutusPurpose AsItem era -> - StrictMaybe (AlonzoPlutusPurpose AsIx era) -alonzoRedeemerPointer txBody = \case - AlonzoSpending txIn -> - AlonzoSpending <$> indexOf txIn (txBody ^. inputsTxBodyL) - AlonzoMinting policyID -> - AlonzoMinting <$> indexOf policyID (txBody ^. mintedTxBodyF :: Set (PolicyID (EraCrypto era))) - AlonzoCertifying txCert -> - AlonzoCertifying <$> indexOf txCert (txBody ^. certsTxBodyL) - AlonzoRewarding rewardAccount -> - AlonzoRewarding <$> indexOf rewardAccount (unWithdrawals (txBody ^. withdrawalsTxBodyL)) - -alonzoRedeemerPointerInverse :: - MaryEraTxBody era => - TxBody era -> - AlonzoPlutusPurpose AsIx era -> - StrictMaybe (AlonzoPlutusPurpose AsIxItem era) -alonzoRedeemerPointerInverse txBody = \case - AlonzoSpending idx -> - AlonzoSpending <$> fromIndex idx (txBody ^. inputsTxBodyL) - AlonzoMinting idx -> - AlonzoMinting <$> fromIndex idx (txBody ^. mintedTxBodyF) - AlonzoCertifying idx -> - AlonzoCertifying <$> fromIndex idx (txBody ^. certsTxBodyL) - AlonzoRewarding idx -> - AlonzoRewarding <$> fromIndex idx (unWithdrawals (txBody ^. withdrawalsTxBodyL)) - -class Indexable elem container where - indexOf :: AsItem Word32 elem -> container -> StrictMaybe (AsIx Word32 elem) - fromIndex :: AsIx Word32 elem -> container -> StrictMaybe (AsIxItem Word32 elem) - -instance Ord k => Indexable k (Set k) where - indexOf (AsItem n) s = case Set.lookupIndex n s of - Just x -> SJust (AsIx (fromIntegral @Int @Word32 x)) - Nothing -> SNothing - fromIndex (AsIx w32) s = - let i = fromIntegral @Word32 @Int w32 - in if i < Set.size s - then SJust $ AsIxItem w32 (Set.elemAt i s) - else SNothing - -instance Eq k => Indexable k (StrictSeq k) where - indexOf (AsItem n) seqx = case StrictSeq.findIndexL (== n) seqx of - Just m -> SJust (AsIx (fromIntegral @Int @Word32 m)) - Nothing -> SNothing - fromIndex (AsIx w32) seqx = - case StrictSeq.lookup (fromIntegral @Word32 @Int w32) seqx of - Nothing -> SNothing - Just x -> SJust $ AsIxItem w32 x - -instance Ord k => Indexable k (Map.Map k v) where - indexOf (AsItem n) mp = case Map.lookupIndex n mp of - Just x -> SJust (AsIx (fromIntegral @Int @Word32 x)) - Nothing -> SNothing - fromIndex (AsIx w32) mp = - let i = fromIntegral @Word32 @Int w32 - in if i < fromIntegral (Map.size mp) - then SJust . AsIxItem w32 . fst $ Map.elemAt i mp - else SNothing - -instance Ord k => Indexable k (OSet k) where - indexOf asItem = indexOf asItem . OSet.toStrictSeq - fromIndex asIndex = fromIndex asIndex . OSet.toStrictSeq +import Cardano.Ledger.Alonzo.TxBody.Internal diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs new file mode 100644 index 00000000000..a53c2c79b6a --- /dev/null +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs @@ -0,0 +1,725 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Provides Alonzo TxBody internals +-- +-- = Warning +-- +-- This module is considered __internal__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +module Cardano.Ledger.Alonzo.TxBody.Internal ( + AlonzoTxOut (..), + AlonzoEraTxOut (..), + -- Constructors are not exported for safety: + Addr28Extra, + DataHash32, + AlonzoTxBody ( + .., + AlonzoTxBody, + atbInputs, + atbCollateral, + atbOutputs, + atbCerts, + atbWithdrawals, + atbTxFee, + atbValidityInterval, + atbUpdate, + atbReqSignerHashes, + atbMint, + atbScriptIntegrityHash, + atbAuxDataHash, + atbTxNetworkId + ), + AlonzoTxBodyRaw (..), + AlonzoTxBodyUpgradeError (..), + AlonzoEraTxBody (..), + ShelleyEraTxBody (..), + AllegraEraTxBody (..), + MaryEraTxBody (..), + Indexable (..), + inputs', + collateral', + outputs', + certs', + withdrawals', + txfee', + vldt', + update', + reqSignerHashes', + mint', + scriptIntegrityHash', + adHash', + txnetworkid', + getAdaOnly, + decodeDataHash32, + encodeDataHash32, + encodeAddress28, + decodeAddress28, + viewCompactTxOut, + viewTxOut, + EraIndependentScriptIntegrity, + ScriptIntegrityHash, + getAlonzoTxOutEitherAddr, + utxoEntrySize, + alonzoRedeemerPointer, + alonzoRedeemerPointerInverse, +) +where + +import Cardano.Ledger.Alonzo.Era +import Cardano.Ledger.Alonzo.PParams () +import Cardano.Ledger.Alonzo.Scripts ( + AlonzoPlutusPurpose (..), + AsItem (..), + AsIx (..), + AsIxItem (..), + PlutusPurpose, + ) +import Cardano.Ledger.Alonzo.TxAuxData (AuxiliaryDataHash (..)) +import Cardano.Ledger.Alonzo.TxCert () +import Cardano.Ledger.Alonzo.TxOut +import Cardano.Ledger.BaseTypes ( + Network (..), + StrictMaybe (..), + ) +import Cardano.Ledger.Binary ( + Annotator, + DecCBOR (..), + EncCBOR (..), + ToCBOR (..), + ) +import Cardano.Ledger.Binary.Coders +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Crypto +import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Mary.Core +import Cardano.Ledger.Mary.TxBody (MaryTxBody (..)) +import Cardano.Ledger.Mary.Value ( + MaryValue (MaryValue), + MultiAsset (..), + PolicyID (..), + policies, + ) +import Cardano.Ledger.MemoBytes ( + EqRaw, + Mem, + MemoBytes, + MemoHashIndex, + Memoized (..), + getMemoRawType, + getMemoSafeHash, + lensMemoRawType, + mkMemoized, + ) +import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeHash, SafeToHash) +import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (..), Update (..)) +import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) +import Cardano.Ledger.TxIn (TxIn (..)) +import Control.Arrow (left) +import Control.DeepSeq (NFData (..)) +import Control.Monad (when) +import Data.Default.Class (def) +import qualified Data.Map.Strict as Map +import Data.Maybe.Strict (isSJust) +import Data.OSet.Strict (OSet) +import qualified Data.OSet.Strict as OSet +import Data.Sequence.Strict (StrictSeq) +import qualified Data.Sequence.Strict as StrictSeq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (Typeable) +import Data.Void (absurd) +import Data.Word (Word32) +import GHC.Generics (Generic) +import Lens.Micro +import NoThunks.Class (NoThunks) + +type ScriptIntegrityHash c = SafeHash c EraIndependentScriptIntegrity + +class (MaryEraTxBody era, AlonzoEraTxOut era) => AlonzoEraTxBody era where + collateralInputsTxBodyL :: Lens' (TxBody era) (Set (TxIn (EraCrypto era))) + + reqSignerHashesTxBodyL :: Lens' (TxBody era) (Set (KeyHash 'Witness (EraCrypto era))) + + scriptIntegrityHashTxBodyL :: + Lens' (TxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era))) + + networkIdTxBodyL :: Lens' (TxBody era) (StrictMaybe Network) + + -- | This function is called @rdptr@ in the spec. Given a `TxBody` and a plutus + -- purpose with an item, we should be able to find the plutus purpose as in index + redeemerPointer :: + TxBody era -> + PlutusPurpose AsItem era -> + StrictMaybe (PlutusPurpose AsIx era) + + -- | This is an inverse of `redeemerPointer`. Given purpose as an index return it as an item. + redeemerPointerInverse :: + TxBody era -> + PlutusPurpose AsIx era -> + StrictMaybe (PlutusPurpose AsIxItem era) + +-- ====================================== + +data AlonzoTxBodyRaw era = AlonzoTxBodyRaw + { atbrInputs :: !(Set (TxIn (EraCrypto era))) + , atbrCollateral :: !(Set (TxIn (EraCrypto era))) + , atbrOutputs :: !(StrictSeq (TxOut era)) + , atbrCerts :: !(StrictSeq (TxCert era)) + , atbrWithdrawals :: !(Withdrawals (EraCrypto era)) + , atbrTxFee :: !Coin + , atbrValidityInterval :: !ValidityInterval + , atbrUpdate :: !(StrictMaybe (Update era)) + , atbrReqSignerHashes :: Set (KeyHash 'Witness (EraCrypto era)) + , atbrMint :: !(MultiAsset (EraCrypto era)) + , atbrScriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) + , atbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) + , atbrTxNetworkId :: !(StrictMaybe Network) + } + deriving (Generic, Typeable) + +deriving instance + (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => + Eq (AlonzoTxBodyRaw era) + +instance + (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => + NoThunks (AlonzoTxBodyRaw era) + +instance + (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => + NFData (AlonzoTxBodyRaw era) + +deriving instance + (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => + Show (AlonzoTxBodyRaw era) + +newtype AlonzoTxBody era = TxBodyConstr (MemoBytes AlonzoTxBodyRaw era) + deriving (ToCBOR, Generic) + deriving newtype (SafeToHash) + +instance Memoized AlonzoTxBody where + type RawType AlonzoTxBody = AlonzoTxBodyRaw + +data AlonzoTxBodyUpgradeError + = -- | The TxBody contains a protocol parameter update that attempts to update + -- the min UTxO. Since this doesn't exist in Alonzo, we fail if an attempt is + -- made to update it. + ATBUEMinUTxOUpdated + deriving (Show) + +instance Crypto c => EraTxBody (AlonzoEra c) where + {-# SPECIALIZE instance EraTxBody (AlonzoEra StandardCrypto) #-} + + type TxBody (AlonzoEra c) = AlonzoTxBody (AlonzoEra c) + type TxBodyUpgradeError (AlonzoEra c) = AlonzoTxBodyUpgradeError + + mkBasicTxBody = mkMemoized emptyAlonzoTxBodyRaw + + inputsTxBodyL = + lensMemoRawType atbrInputs (\txBodyRaw inputs_ -> txBodyRaw {atbrInputs = inputs_}) + {-# INLINEABLE inputsTxBodyL #-} + + outputsTxBodyL = + lensMemoRawType atbrOutputs (\txBodyRaw outputs_ -> txBodyRaw {atbrOutputs = outputs_}) + {-# INLINEABLE outputsTxBodyL #-} + + feeTxBodyL = + lensMemoRawType atbrTxFee (\txBodyRaw fee_ -> txBodyRaw {atbrTxFee = fee_}) + {-# INLINEABLE feeTxBodyL #-} + + auxDataHashTxBodyL = + lensMemoRawType + atbrAuxDataHash + (\txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash}) + {-# INLINEABLE auxDataHashTxBodyL #-} + + spendableInputsTxBodyF = allInputsTxBodyF + {-# INLINE spendableInputsTxBodyF #-} + + allInputsTxBodyF = + to $ \txBody -> (txBody ^. inputsTxBodyL) `Set.union` (txBody ^. collateralInputsTxBodyL) + {-# INLINEABLE allInputsTxBodyF #-} + + withdrawalsTxBodyL = + lensMemoRawType + atbrWithdrawals + (\txBodyRaw withdrawals_ -> txBodyRaw {atbrWithdrawals = withdrawals_}) + {-# INLINEABLE withdrawalsTxBodyL #-} + + certsTxBodyL = + lensMemoRawType atbrCerts (\txBodyRaw certs_ -> txBodyRaw {atbrCerts = certs_}) + {-# INLINEABLE certsTxBodyL #-} + + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody + + upgradeTxBody + MaryTxBody + { mtbInputs + , mtbOutputs + , mtbCerts + , mtbWithdrawals + , mtbTxFee + , mtbValidityInterval + , mtbUpdate + , mtbAuxDataHash + , mtbMint + } = do + certs <- + traverse + (left absurd . upgradeTxCert) + mtbCerts + + updates <- traverse upgradeUpdate mtbUpdate + pure $ + AlonzoTxBody + { atbInputs = mtbInputs + , atbOutputs = upgradeTxOut <$> mtbOutputs + , atbCerts = certs + , atbWithdrawals = mtbWithdrawals + , atbTxFee = mtbTxFee + , atbValidityInterval = mtbValidityInterval + , atbUpdate = updates + , atbAuxDataHash = mtbAuxDataHash + , atbMint = mtbMint + , atbCollateral = mempty + , atbReqSignerHashes = mempty + , atbScriptIntegrityHash = SNothing + , atbTxNetworkId = SNothing + } + where + upgradeUpdate :: + Update (MaryEra c) -> + Either AlonzoTxBodyUpgradeError (Update (AlonzoEra c)) + upgradeUpdate (Update pp epoch) = + Update <$> upgradeProposedPPUpdates pp <*> pure epoch + + upgradeProposedPPUpdates :: + ProposedPPUpdates (MaryEra c) -> + Either AlonzoTxBodyUpgradeError (ProposedPPUpdates (AlonzoEra c)) + upgradeProposedPPUpdates (ProposedPPUpdates m) = + ProposedPPUpdates + <$> traverse + ( \ppu -> do + when (isSJust $ ppu ^. ppuMinUTxOValueL) $ + Left ATBUEMinUTxOUpdated + pure $ upgradePParamsUpdate def ppu + ) + m + +instance Crypto c => ShelleyEraTxBody (AlonzoEra c) where + {-# SPECIALIZE instance ShelleyEraTxBody (AlonzoEra StandardCrypto) #-} + + ttlTxBodyL = notSupportedInThisEraL + + updateTxBodyL = + lensMemoRawType atbrUpdate (\txBodyRaw update_ -> txBodyRaw {atbrUpdate = update_}) + {-# INLINEABLE updateTxBodyL #-} + +instance Crypto c => AllegraEraTxBody (AlonzoEra c) where + {-# SPECIALIZE instance AllegraEraTxBody (AlonzoEra StandardCrypto) #-} + + vldtTxBodyL = + lensMemoRawType atbrValidityInterval (\txBodyRaw vldt_ -> txBodyRaw {atbrValidityInterval = vldt_}) + {-# INLINEABLE vldtTxBodyL #-} + +instance Crypto c => MaryEraTxBody (AlonzoEra c) where + {-# SPECIALIZE instance MaryEraTxBody (AlonzoEra StandardCrypto) #-} + + mintTxBodyL = + lensMemoRawType atbrMint (\txBodyRaw mint_ -> txBodyRaw {atbrMint = mint_}) + {-# INLINEABLE mintTxBodyL #-} + + mintValueTxBodyF = mintTxBodyL . to (MaryValue mempty) + {-# INLINEABLE mintValueTxBodyF #-} + + mintedTxBodyF = to (policies . atbrMint . getMemoRawType) + {-# INLINEABLE mintedTxBodyF #-} + +instance Crypto c => AlonzoEraTxBody (AlonzoEra c) where + {-# SPECIALIZE instance AlonzoEraTxBody (AlonzoEra StandardCrypto) #-} + + collateralInputsTxBodyL = + lensMemoRawType atbrCollateral (\txBodyRaw collateral_ -> txBodyRaw {atbrCollateral = collateral_}) + {-# INLINEABLE collateralInputsTxBodyL #-} + + reqSignerHashesTxBodyL = + lensMemoRawType + atbrReqSignerHashes + (\txBodyRaw reqSignerHashes_ -> txBodyRaw {atbrReqSignerHashes = reqSignerHashes_}) + {-# INLINEABLE reqSignerHashesTxBodyL #-} + + scriptIntegrityHashTxBodyL = + lensMemoRawType + atbrScriptIntegrityHash + (\txBodyRaw scriptIntegrityHash_ -> txBodyRaw {atbrScriptIntegrityHash = scriptIntegrityHash_}) + {-# INLINEABLE scriptIntegrityHashTxBodyL #-} + + networkIdTxBodyL = + lensMemoRawType atbrTxNetworkId (\txBodyRaw networkId -> txBodyRaw {atbrTxNetworkId = networkId}) + {-# INLINEABLE networkIdTxBodyL #-} + + redeemerPointer = alonzoRedeemerPointer + + redeemerPointerInverse = alonzoRedeemerPointerInverse + +deriving newtype instance + (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => + Eq (AlonzoTxBody era) + +deriving instance + (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => + NoThunks (AlonzoTxBody era) + +deriving instance + (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => + NFData (AlonzoTxBody era) + +deriving instance + (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => + Show (AlonzoTxBody era) + +deriving via + (Mem AlonzoTxBodyRaw era) + instance + (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => + DecCBOR (Annotator (AlonzoTxBody era)) + +pattern AlonzoTxBody :: + (EraTxOut era, EraTxCert era) => + Set (TxIn (EraCrypto era)) -> + Set (TxIn (EraCrypto era)) -> + StrictSeq (TxOut era) -> + StrictSeq (TxCert era) -> + Withdrawals (EraCrypto era) -> + Coin -> + ValidityInterval -> + StrictMaybe (Update era) -> + Set (KeyHash 'Witness (EraCrypto era)) -> + MultiAsset (EraCrypto era) -> + StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -> + StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> + StrictMaybe Network -> + AlonzoTxBody era +pattern AlonzoTxBody + { atbInputs + , atbCollateral + , atbOutputs + , atbCerts + , atbWithdrawals + , atbTxFee + , atbValidityInterval + , atbUpdate + , atbReqSignerHashes + , atbMint + , atbScriptIntegrityHash + , atbAuxDataHash + , atbTxNetworkId + } <- + ( getMemoRawType -> + AlonzoTxBodyRaw + { atbrInputs = atbInputs + , atbrCollateral = atbCollateral + , atbrOutputs = atbOutputs + , atbrCerts = atbCerts + , atbrWithdrawals = atbWithdrawals + , atbrTxFee = atbTxFee + , atbrValidityInterval = atbValidityInterval + , atbrUpdate = atbUpdate + , atbrReqSignerHashes = atbReqSignerHashes + , atbrMint = atbMint + , atbrScriptIntegrityHash = atbScriptIntegrityHash + , atbrAuxDataHash = atbAuxDataHash + , atbrTxNetworkId = atbTxNetworkId + } + ) + where + AlonzoTxBody + inputs + collateral + outputs + certs + withdrawals + txFee + validityInterval + update + reqSignerHashes + mint + scriptIntegrityHash + auxDataHash + txNetworkId = + mkMemoized $ + AlonzoTxBodyRaw + { atbrInputs = inputs + , atbrCollateral = collateral + , atbrOutputs = outputs + , atbrCerts = certs + , atbrWithdrawals = withdrawals + , atbrTxFee = txFee + , atbrValidityInterval = validityInterval + , atbrUpdate = update + , atbrReqSignerHashes = reqSignerHashes + , atbrMint = mint + , atbrScriptIntegrityHash = scriptIntegrityHash + , atbrAuxDataHash = auxDataHash + , atbrTxNetworkId = txNetworkId + } + +{-# COMPLETE AlonzoTxBody #-} + +type instance MemoHashIndex AlonzoTxBodyRaw = EraIndependentTxBody + +instance c ~ EraCrypto era => HashAnnotated (AlonzoTxBody era) EraIndependentTxBody c where + hashAnnotated = getMemoSafeHash + +-- ============================================================================== +-- We define these accessor functions manually, because if we define them using +-- the record syntax in the TxBody pattern, they inherit the (AlonzoBody era) +-- constraint as a precondition. This is unnecessary, as one can see below +-- they need not be constrained at all. This should be fixed in the GHC compiler. + +inputs' :: AlonzoTxBody era -> Set (TxIn (EraCrypto era)) +collateral' :: AlonzoTxBody era -> Set (TxIn (EraCrypto era)) +outputs' :: AlonzoTxBody era -> StrictSeq (TxOut era) +certs' :: AlonzoTxBody era -> StrictSeq (TxCert era) +txfee' :: AlonzoTxBody era -> Coin +withdrawals' :: AlonzoTxBody era -> Withdrawals (EraCrypto era) +vldt' :: AlonzoTxBody era -> ValidityInterval +update' :: AlonzoTxBody era -> StrictMaybe (Update era) +reqSignerHashes' :: AlonzoTxBody era -> Set (KeyHash 'Witness (EraCrypto era)) +adHash' :: AlonzoTxBody era -> StrictMaybe (AuxiliaryDataHash (EraCrypto era)) +mint' :: AlonzoTxBody era -> MultiAsset (EraCrypto era) +scriptIntegrityHash' :: AlonzoTxBody era -> StrictMaybe (ScriptIntegrityHash (EraCrypto era)) +txnetworkid' :: AlonzoTxBody era -> StrictMaybe Network +inputs' = atbrInputs . getMemoRawType + +collateral' = atbrCollateral . getMemoRawType + +outputs' = atbrOutputs . getMemoRawType + +certs' = atbrCerts . getMemoRawType + +withdrawals' = atbrWithdrawals . getMemoRawType + +txfee' = atbrTxFee . getMemoRawType + +vldt' = atbrValidityInterval . getMemoRawType + +update' = atbrUpdate . getMemoRawType + +reqSignerHashes' = atbrReqSignerHashes . getMemoRawType + +adHash' = atbrAuxDataHash . getMemoRawType + +mint' = atbrMint . getMemoRawType + +scriptIntegrityHash' = atbrScriptIntegrityHash . getMemoRawType + +txnetworkid' = atbrTxNetworkId . getMemoRawType + +instance + (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => + EqRaw (AlonzoTxBody era) + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +-- | Encodes memoized bytes created upon construction. +instance Era era => EncCBOR (AlonzoTxBody era) + +instance + (Era era, EncCBOR (TxOut era), EncCBOR (TxCert era), EncCBOR (PParamsUpdate era)) => + EncCBOR (AlonzoTxBodyRaw era) + where + encCBOR + AlonzoTxBodyRaw + { atbrInputs + , atbrCollateral + , atbrOutputs + , atbrCerts + , atbrWithdrawals + , atbrTxFee + , atbrValidityInterval = ValidityInterval bot top + , atbrUpdate + , atbrReqSignerHashes + , atbrMint + , atbrScriptIntegrityHash + , atbrAuxDataHash + , atbrTxNetworkId + } = + encode $ + Keyed + ( \i ifee o f t c w u b rsh mi sh ah ni -> + AlonzoTxBodyRaw i ifee o c w f (ValidityInterval b t) u rsh mi sh ah ni + ) + !> Key 0 (To atbrInputs) + !> Omit null (Key 13 (To atbrCollateral)) + !> Key 1 (To atbrOutputs) + !> Key 2 (To atbrTxFee) + !> encodeKeyedStrictMaybe 3 top + !> Omit null (Key 4 (To atbrCerts)) + !> Omit (null . unWithdrawals) (Key 5 (To atbrWithdrawals)) + !> encodeKeyedStrictMaybe 6 atbrUpdate + !> encodeKeyedStrictMaybe 8 bot + !> Omit null (Key 14 (To atbrReqSignerHashes)) + !> Omit (== mempty) (Key 9 (To atbrMint)) + !> encodeKeyedStrictMaybe 11 atbrScriptIntegrityHash + !> encodeKeyedStrictMaybe 7 atbrAuxDataHash + !> encodeKeyedStrictMaybe 15 atbrTxNetworkId + +instance + (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => + DecCBOR (AlonzoTxBodyRaw era) + where + decCBOR = + decode $ + SparseKeyed + "AlonzoTxBodyRaw" + emptyAlonzoTxBodyRaw + bodyFields + requiredFields + where + bodyFields :: Word -> Field (AlonzoTxBodyRaw era) + bodyFields 0 = field (\x tx -> tx {atbrInputs = x}) From + bodyFields 13 = field (\x tx -> tx {atbrCollateral = x}) From + bodyFields 1 = field (\x tx -> tx {atbrOutputs = x}) From + bodyFields 2 = field (\x tx -> tx {atbrTxFee = x}) From + bodyFields 3 = + ofield + (\x tx -> tx {atbrValidityInterval = (atbrValidityInterval tx) {invalidHereafter = x}}) + From + bodyFields 4 = field (\x tx -> tx {atbrCerts = x}) From + bodyFields 5 = field (\x tx -> tx {atbrWithdrawals = x}) From + bodyFields 6 = ofield (\x tx -> tx {atbrUpdate = x}) From + bodyFields 7 = ofield (\x tx -> tx {atbrAuxDataHash = x}) From + bodyFields 8 = + ofield + (\x tx -> tx {atbrValidityInterval = (atbrValidityInterval tx) {invalidBefore = x}}) + From + bodyFields 9 = field (\x tx -> tx {atbrMint = x}) From + bodyFields 11 = ofield (\x tx -> tx {atbrScriptIntegrityHash = x}) From + bodyFields 14 = field (\x tx -> tx {atbrReqSignerHashes = x}) From + bodyFields 15 = ofield (\x tx -> tx {atbrTxNetworkId = x}) From + bodyFields n = field (\_ t -> t) (Invalid n) + requiredFields = + [ (0, "inputs") + , (1, "outputs") + , (2, "fee") + ] + +emptyAlonzoTxBodyRaw :: AlonzoTxBodyRaw era +emptyAlonzoTxBodyRaw = + AlonzoTxBodyRaw + mempty + mempty + StrictSeq.empty + StrictSeq.empty + (Withdrawals mempty) + mempty + (ValidityInterval SNothing SNothing) + SNothing + mempty + mempty + SNothing + SNothing + SNothing + +instance + (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => + DecCBOR (Annotator (AlonzoTxBodyRaw era)) + where + decCBOR = pure <$> decCBOR + +alonzoRedeemerPointer :: + forall era. + MaryEraTxBody era => + TxBody era -> + AlonzoPlutusPurpose AsItem era -> + StrictMaybe (AlonzoPlutusPurpose AsIx era) +alonzoRedeemerPointer txBody = \case + AlonzoSpending txIn -> + AlonzoSpending <$> indexOf txIn (txBody ^. inputsTxBodyL) + AlonzoMinting policyID -> + AlonzoMinting <$> indexOf policyID (txBody ^. mintedTxBodyF :: Set (PolicyID (EraCrypto era))) + AlonzoCertifying txCert -> + AlonzoCertifying <$> indexOf txCert (txBody ^. certsTxBodyL) + AlonzoRewarding rewardAccount -> + AlonzoRewarding <$> indexOf rewardAccount (unWithdrawals (txBody ^. withdrawalsTxBodyL)) + +alonzoRedeemerPointerInverse :: + MaryEraTxBody era => + TxBody era -> + AlonzoPlutusPurpose AsIx era -> + StrictMaybe (AlonzoPlutusPurpose AsIxItem era) +alonzoRedeemerPointerInverse txBody = \case + AlonzoSpending idx -> + AlonzoSpending <$> fromIndex idx (txBody ^. inputsTxBodyL) + AlonzoMinting idx -> + AlonzoMinting <$> fromIndex idx (txBody ^. mintedTxBodyF) + AlonzoCertifying idx -> + AlonzoCertifying <$> fromIndex idx (txBody ^. certsTxBodyL) + AlonzoRewarding idx -> + AlonzoRewarding <$> fromIndex idx (unWithdrawals (txBody ^. withdrawalsTxBodyL)) + +class Indexable elem container where + indexOf :: AsItem Word32 elem -> container -> StrictMaybe (AsIx Word32 elem) + fromIndex :: AsIx Word32 elem -> container -> StrictMaybe (AsIxItem Word32 elem) + +instance Ord k => Indexable k (Set k) where + indexOf (AsItem n) s = case Set.lookupIndex n s of + Just x -> SJust (AsIx (fromIntegral @Int @Word32 x)) + Nothing -> SNothing + fromIndex (AsIx w32) s = + let i = fromIntegral @Word32 @Int w32 + in if i < Set.size s + then SJust $ AsIxItem w32 (Set.elemAt i s) + else SNothing + +instance Eq k => Indexable k (StrictSeq k) where + indexOf (AsItem n) seqx = case StrictSeq.findIndexL (== n) seqx of + Just m -> SJust (AsIx (fromIntegral @Int @Word32 m)) + Nothing -> SNothing + fromIndex (AsIx w32) seqx = + case StrictSeq.lookup (fromIntegral @Word32 @Int w32) seqx of + Nothing -> SNothing + Just x -> SJust $ AsIxItem w32 x + +instance Ord k => Indexable k (Map.Map k v) where + indexOf (AsItem n) mp = case Map.lookupIndex n mp of + Just x -> SJust (AsIx (fromIntegral @Int @Word32 x)) + Nothing -> SNothing + fromIndex (AsIx w32) mp = + let i = fromIntegral @Word32 @Int w32 + in if i < fromIntegral (Map.size mp) + then SJust . AsIxItem w32 . fst $ Map.elemAt i mp + else SNothing + +instance Ord k => Indexable k (OSet k) where + indexOf asItem = indexOf asItem . OSet.toStrictSeq + fromIndex asIndex = fromIndex asIndex . OSet.toStrictSeq diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs index d0ab86e57df..a5e21a708e8 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs @@ -1,18 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -- | TxSeq. This is effectively the block body, which consists of a sequence of -- transactions with segregated witness and metadata information. module Cardano.Ledger.Alonzo.TxSeq ( @@ -23,253 +8,4 @@ module Cardano.Ledger.Alonzo.TxSeq ( ) where -import qualified Cardano.Crypto.Hash as Hash -import Cardano.Ledger.Alonzo.Era -import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..), alonzoSegwitTx) -import Cardano.Ledger.Binary ( - Annotator, - DecCBOR (..), - EncCBORGroup (..), - encCBOR, - encodeFoldableEncoder, - encodeFoldableMapEncoder, - encodePreEncoded, - encodedSizeExpr, - serialize, - withSlice, - ) -import Cardano.Ledger.Core hiding (TxSeq, hashTxSeq) -import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Crypto -import Cardano.Ledger.Keys (Hash) -import Cardano.Ledger.SafeHash (SafeToHash, originalBytes) -import Cardano.Ledger.Shelley.BlockChain (constructMetadata) -import Control.Monad (unless) -import Data.ByteString (ByteString) -import Data.ByteString.Builder (shortByteString, toLazyByteString) -import qualified Data.ByteString.Lazy as BSL -import Data.Coerce (coerce) -import qualified Data.Map.Strict as Map -import Data.Maybe.Strict (strictMaybeToMaybe) -import Data.Proxy (Proxy (..)) -import qualified Data.Sequence as Seq -import Data.Sequence.Strict (StrictSeq) -import qualified Data.Sequence.Strict as StrictSeq -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Lens.Micro -import Lens.Micro.Extras (view) -import NoThunks.Class (AllowThunksIn (..), NoThunks) - --- ================================================= - --- $TxSeq --- --- * TxSeq --- --- TxSeq provides an alternate way of formatting transactions in a block, in --- order to support segregated witnessing. - -data AlonzoTxSeq era = AlonzoTxSeqRaw - { txSeqTxns :: !(StrictSeq (Tx era)) - , txSeqBodyBytes :: BSL.ByteString - -- ^ Bytes encoding @Seq ('AlonzoTxBody' era)@ - , txSeqWitsBytes :: BSL.ByteString - -- ^ Bytes encoding @Seq ('TxWitness' era)@ - , txSeqMetadataBytes :: BSL.ByteString - -- ^ Bytes encoding a @Map Int ('AuxiliaryData')@. Missing indices have - -- 'SNothing' for metadata - , txSeqIsValidBytes :: BSL.ByteString - -- ^ Bytes representing a set of integers. These are the indices of - -- transactions with 'isValid' == False. - } - deriving (Generic) - -instance Crypto c => EraSegWits (AlonzoEra c) where - type TxSeq (AlonzoEra c) = AlonzoTxSeq (AlonzoEra c) - fromTxSeq = txSeqTxns - toTxSeq = AlonzoTxSeq - hashTxSeq = hashAlonzoTxSeq - numSegComponents = 4 - -pattern AlonzoTxSeq :: - forall era. - ( AlonzoEraTx era - , SafeToHash (TxWits era) - ) => - StrictSeq (Tx era) -> - AlonzoTxSeq era -pattern AlonzoTxSeq xs <- - AlonzoTxSeqRaw xs _ _ _ _ - where - AlonzoTxSeq txns = - let version = eraProtVerLow @era - serializeFoldablePreEncoded x = - serialize version $ - encodeFoldableEncoder encodePreEncoded x - metaChunk index m = encodeIndexed <$> strictMaybeToMaybe m - where - encodeIndexed metadata = encCBOR index <> encodePreEncoded metadata - in AlonzoTxSeqRaw - { txSeqTxns = txns - , txSeqBodyBytes = - serializeFoldablePreEncoded $ originalBytes . view bodyTxL <$> txns - , txSeqWitsBytes = - serializeFoldablePreEncoded $ originalBytes . view witsTxL <$> txns - , txSeqMetadataBytes = - serialize version . encodeFoldableMapEncoder metaChunk $ - fmap originalBytes . view auxDataTxL <$> txns - , txSeqIsValidBytes = - serialize version $ encCBOR $ nonValidatingIndices txns - } - -{-# COMPLETE AlonzoTxSeq #-} - -type TxSeq era = AlonzoTxSeq era - -{-# DEPRECATED TxSeq "Use `AlonzoTxSeq` instead" #-} - -deriving via - AllowThunksIn - '[ "txSeqBodyBytes" - , "txSeqWitsBytes" - , "txSeqMetadataBytes" - , "txSeqIsValidBytes" - ] - (TxSeq era) - instance - (Typeable era, NoThunks (Tx era)) => NoThunks (TxSeq era) - -deriving stock instance Show (Tx era) => Show (TxSeq era) - -deriving stock instance Eq (Tx era) => Eq (TxSeq era) - --------------------------------------------------------------------------------- --- Serialisation and hashing --------------------------------------------------------------------------------- - -instance Era era => EncCBORGroup (TxSeq era) where - encCBORGroup (AlonzoTxSeqRaw _ bodyBytes witsBytes metadataBytes invalidBytes) = - encodePreEncoded $ - BSL.toStrict $ - bodyBytes <> witsBytes <> metadataBytes <> invalidBytes - encodedGroupSizeExpr size _proxy = - encodedSizeExpr size (Proxy :: Proxy ByteString) - + encodedSizeExpr size (Proxy :: Proxy ByteString) - + encodedSizeExpr size (Proxy :: Proxy ByteString) - + encodedSizeExpr size (Proxy :: Proxy ByteString) - listLen _ = 4 - listLenBound _ = 4 - -hashTxSeq :: - forall era. - Era era => - AlonzoTxSeq era -> - Hash (EraCrypto era) EraIndependentBlockBody -hashTxSeq = hashAlonzoTxSeq -{-# DEPRECATED hashTxSeq "Use `hashAlonzoTxSeq` instead" #-} - --- | Hash a given block body -hashAlonzoTxSeq :: - forall era. - Era era => - AlonzoTxSeq era -> - Hash (EraCrypto era) EraIndependentBlockBody -hashAlonzoTxSeq (AlonzoTxSeqRaw _ bodies ws md vs) = - coerce $ - hashStrict $ - BSL.toStrict $ - toLazyByteString $ - mconcat - [ hashPart bodies - , hashPart ws - , hashPart md - , hashPart vs - ] - where - hashStrict :: ByteString -> Hash (EraCrypto era) ByteString - hashStrict = Hash.hashWith id - hashPart = shortByteString . Hash.hashToBytesShort . hashStrict . BSL.toStrict - -instance AlonzoEraTx era => DecCBOR (Annotator (TxSeq era)) where - decCBOR = do - (bodies, bodiesAnn) <- withSlice decCBOR - (ws, witsAnn) <- withSlice decCBOR - let b = length bodies - inRange x = (0 <= x) && (x <= (b - 1)) - w = length ws - (auxData, auxDataAnn) <- withSlice $ - do - m <- decCBOR - unless - (all inRange (Map.keysSet m)) - ( fail - ( "Some Auxiliarydata index is not in the range: 0 .. " - ++ show (b - 1) - ) - ) - pure (constructMetadata b m) - (isValIdxs, isValAnn) <- withSlice decCBOR - let vs = alignedValidFlags b isValIdxs - unless - (b == w) - ( fail $ - "different number of transaction bodies (" - <> show b - <> ") and witness sets (" - <> show w - <> ")" - ) - unless - (all inRange isValIdxs) - ( fail - ( "Some IsValid index is not in the range: 0 .. " - ++ show (b - 1) - ++ ", " - ++ show isValIdxs - ) - ) - - let txns = - sequenceA $ - StrictSeq.forceToStrict $ - Seq.zipWith4 alonzoSegwitTx bodies ws vs auxData - pure $ - AlonzoTxSeqRaw - <$> txns - <*> bodiesAnn - <*> witsAnn - <*> auxDataAnn - <*> isValAnn - --------------------------------------------------------------------------------- --- Internal utility functions --------------------------------------------------------------------------------- - --- | Given a sequence of transactions, return the indices of those which do not --- validate. We store the indices of the non-validating transactions because we --- expect this to be a much smaller set than the validating transactions. -nonValidatingIndices :: AlonzoEraTx era => StrictSeq (Tx era) -> [Int] -nonValidatingIndices (StrictSeq.fromStrict -> xs) = - Seq.foldrWithIndex - ( \idx tx acc -> - if tx ^. isValidTxL == IsValid False - then idx : acc - else acc - ) - [] - xs - --- | Given the number of transactions, and the set of indices for which these --- transactions do not validate, create an aligned sequence of `IsValid` --- flags. --- --- This function operates much as the inverse of 'nonValidatingIndices'. -alignedValidFlags :: Int -> [Int] -> Seq.Seq IsValid -alignedValidFlags = alignedValidFlags' (-1) - where - alignedValidFlags' _ n [] = Seq.replicate n $ IsValid True - alignedValidFlags' prev n (x : xs) = - Seq.replicate (x - prev - 1) (IsValid True) - Seq.>< IsValid False - Seq.<| alignedValidFlags' x (n - (x - prev)) xs +import Cardano.Ledger.Alonzo.TxSeq.Internal diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs new file mode 100644 index 00000000000..ec6f1c2a36e --- /dev/null +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Provides TxSeq internals +-- +-- = Warning +-- +-- This module is considered __internal__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +module Cardano.Ledger.Alonzo.TxSeq.Internal ( + AlonzoTxSeq (.., AlonzoTxSeq), + TxSeq, + hashTxSeq, + hashAlonzoTxSeq, +) +where + +import qualified Cardano.Crypto.Hash as Hash +import Cardano.Ledger.Alonzo.Era +import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..), alonzoSegwitTx) +import Cardano.Ledger.Binary ( + Annotator, + DecCBOR (..), + EncCBORGroup (..), + encCBOR, + encodeFoldableEncoder, + encodeFoldableMapEncoder, + encodePreEncoded, + encodedSizeExpr, + serialize, + withSlice, + ) +import Cardano.Ledger.Core hiding (TxSeq, hashTxSeq) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Crypto +import Cardano.Ledger.Keys (Hash) +import Cardano.Ledger.SafeHash (SafeToHash, originalBytes) +import Cardano.Ledger.Shelley.BlockChain (constructMetadata) +import Control.Monad (unless) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (shortByteString, toLazyByteString) +import qualified Data.ByteString.Lazy as BSL +import Data.Coerce (coerce) +import qualified Data.Map.Strict as Map +import Data.Maybe.Strict (strictMaybeToMaybe) +import Data.Proxy (Proxy (..)) +import qualified Data.Sequence as Seq +import Data.Sequence.Strict (StrictSeq) +import qualified Data.Sequence.Strict as StrictSeq +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Lens.Micro +import Lens.Micro.Extras (view) +import NoThunks.Class (AllowThunksIn (..), NoThunks) + +-- ================================================= + +-- $TxSeq +-- +-- * TxSeq +-- +-- TxSeq provides an alternate way of formatting transactions in a block, in +-- order to support segregated witnessing. + +data AlonzoTxSeq era = AlonzoTxSeqRaw + { txSeqTxns :: !(StrictSeq (Tx era)) + , txSeqBodyBytes :: BSL.ByteString + -- ^ Bytes encoding @Seq ('AlonzoTxBody' era)@ + , txSeqWitsBytes :: BSL.ByteString + -- ^ Bytes encoding @Seq ('TxWitness' era)@ + , txSeqMetadataBytes :: BSL.ByteString + -- ^ Bytes encoding a @Map Int ('AuxiliaryData')@. Missing indices have + -- 'SNothing' for metadata + , txSeqIsValidBytes :: BSL.ByteString + -- ^ Bytes representing a set of integers. These are the indices of + -- transactions with 'isValid' == False. + } + deriving (Generic) + +instance Crypto c => EraSegWits (AlonzoEra c) where + type TxSeq (AlonzoEra c) = AlonzoTxSeq (AlonzoEra c) + fromTxSeq = txSeqTxns + toTxSeq = AlonzoTxSeq + hashTxSeq = hashAlonzoTxSeq + numSegComponents = 4 + +pattern AlonzoTxSeq :: + forall era. + ( AlonzoEraTx era + , SafeToHash (TxWits era) + ) => + StrictSeq (Tx era) -> + AlonzoTxSeq era +pattern AlonzoTxSeq xs <- + AlonzoTxSeqRaw xs _ _ _ _ + where + AlonzoTxSeq txns = + let version = eraProtVerLow @era + serializeFoldablePreEncoded x = + serialize version $ + encodeFoldableEncoder encodePreEncoded x + metaChunk index m = encodeIndexed <$> strictMaybeToMaybe m + where + encodeIndexed metadata = encCBOR index <> encodePreEncoded metadata + in AlonzoTxSeqRaw + { txSeqTxns = txns + , txSeqBodyBytes = + serializeFoldablePreEncoded $ originalBytes . view bodyTxL <$> txns + , txSeqWitsBytes = + serializeFoldablePreEncoded $ originalBytes . view witsTxL <$> txns + , txSeqMetadataBytes = + serialize version . encodeFoldableMapEncoder metaChunk $ + fmap originalBytes . view auxDataTxL <$> txns + , txSeqIsValidBytes = + serialize version $ encCBOR $ nonValidatingIndices txns + } + +{-# COMPLETE AlonzoTxSeq #-} + +type TxSeq era = AlonzoTxSeq era + +{-# DEPRECATED TxSeq "Use `AlonzoTxSeq` instead" #-} + +deriving via + AllowThunksIn + '[ "txSeqBodyBytes" + , "txSeqWitsBytes" + , "txSeqMetadataBytes" + , "txSeqIsValidBytes" + ] + (TxSeq era) + instance + (Typeable era, NoThunks (Tx era)) => NoThunks (TxSeq era) + +deriving stock instance Show (Tx era) => Show (TxSeq era) + +deriving stock instance Eq (Tx era) => Eq (TxSeq era) + +-------------------------------------------------------------------------------- +-- Serialisation and hashing +-------------------------------------------------------------------------------- + +instance Era era => EncCBORGroup (TxSeq era) where + encCBORGroup (AlonzoTxSeqRaw _ bodyBytes witsBytes metadataBytes invalidBytes) = + encodePreEncoded $ + BSL.toStrict $ + bodyBytes <> witsBytes <> metadataBytes <> invalidBytes + encodedGroupSizeExpr size _proxy = + encodedSizeExpr size (Proxy :: Proxy ByteString) + + encodedSizeExpr size (Proxy :: Proxy ByteString) + + encodedSizeExpr size (Proxy :: Proxy ByteString) + + encodedSizeExpr size (Proxy :: Proxy ByteString) + listLen _ = 4 + listLenBound _ = 4 + +hashTxSeq :: + forall era. + Era era => + AlonzoTxSeq era -> + Hash (EraCrypto era) EraIndependentBlockBody +hashTxSeq = hashAlonzoTxSeq +{-# DEPRECATED hashTxSeq "Use `hashAlonzoTxSeq` instead" #-} + +-- | Hash a given block body +hashAlonzoTxSeq :: + forall era. + Era era => + AlonzoTxSeq era -> + Hash (EraCrypto era) EraIndependentBlockBody +hashAlonzoTxSeq (AlonzoTxSeqRaw _ bodies ws md vs) = + coerce $ + hashStrict $ + BSL.toStrict $ + toLazyByteString $ + mconcat + [ hashPart bodies + , hashPart ws + , hashPart md + , hashPart vs + ] + where + hashStrict :: ByteString -> Hash (EraCrypto era) ByteString + hashStrict = Hash.hashWith id + hashPart = shortByteString . Hash.hashToBytesShort . hashStrict . BSL.toStrict + +instance AlonzoEraTx era => DecCBOR (Annotator (TxSeq era)) where + decCBOR = do + (bodies, bodiesAnn) <- withSlice decCBOR + (ws, witsAnn) <- withSlice decCBOR + let b = length bodies + inRange x = (0 <= x) && (x <= (b - 1)) + w = length ws + (auxData, auxDataAnn) <- withSlice $ + do + m <- decCBOR + unless + (all inRange (Map.keysSet m)) + ( fail + ( "Some Auxiliarydata index is not in the range: 0 .. " + ++ show (b - 1) + ) + ) + pure (constructMetadata b m) + (isValIdxs, isValAnn) <- withSlice decCBOR + let vs = alignedValidFlags b isValIdxs + unless + (b == w) + ( fail $ + "different number of transaction bodies (" + <> show b + <> ") and witness sets (" + <> show w + <> ")" + ) + unless + (all inRange isValIdxs) + ( fail + ( "Some IsValid index is not in the range: 0 .. " + ++ show (b - 1) + ++ ", " + ++ show isValIdxs + ) + ) + + let txns = + sequenceA $ + StrictSeq.forceToStrict $ + Seq.zipWith4 alonzoSegwitTx bodies ws vs auxData + pure $ + AlonzoTxSeqRaw + <$> txns + <*> bodiesAnn + <*> witsAnn + <*> auxDataAnn + <*> isValAnn + +-------------------------------------------------------------------------------- +-- Internal utility functions +-------------------------------------------------------------------------------- + +-- | Given a sequence of transactions, return the indices of those which do not +-- validate. We store the indices of the non-validating transactions because we +-- expect this to be a much smaller set than the validating transactions. +nonValidatingIndices :: AlonzoEraTx era => StrictSeq (Tx era) -> [Int] +nonValidatingIndices (StrictSeq.fromStrict -> xs) = + Seq.foldrWithIndex + ( \idx tx acc -> + if tx ^. isValidTxL == IsValid False + then idx : acc + else acc + ) + [] + xs + +-- | Given the number of transactions, and the set of indices for which these +-- transactions do not validate, create an aligned sequence of `IsValid` +-- flags. +-- +-- This function operates much as the inverse of 'nonValidatingIndices'. +alignedValidFlags :: Int -> [Int] -> Seq.Seq IsValid +alignedValidFlags = alignedValidFlags' (-1) + where + alignedValidFlags' _ n [] = Seq.replicate n $ IsValid True + alignedValidFlags' prev n (x : xs) = + Seq.replicate (x - prev - 1) (IsValid True) + Seq.>< IsValid False + Seq.<| alignedValidFlags' x (n - (x - prev)) xs diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index b63ac9c63cd..41195f5ef80 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -37,6 +37,7 @@ library Cardano.Ledger.Babbage.Scripts Cardano.Ledger.Babbage.Tx Cardano.Ledger.Babbage.TxBody + Cardano.Ledger.Babbage.TxBody.Internal Cardano.Ledger.Babbage.TxOut Cardano.Ledger.Babbage.TxInfo Cardano.Ledger.Babbage.TxWits diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs index 1bbc1eb24d2..865ccdc2045 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs @@ -1,24 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Cardano.Ledger.Babbage.TxBody ( BabbageTxOut ( BabbageTxOut, @@ -77,789 +56,4 @@ module Cardano.Ledger.Babbage.TxBody ( txOutScript, ) where -import Cardano.Ledger.Alonzo (AlonzoEra) -import Cardano.Ledger.Alonzo.Core -import Cardano.Ledger.Alonzo.PParams (AlonzoPParams (appExtraEntropy), appD) -import Cardano.Ledger.Alonzo.TxAuxData (AuxiliaryDataHash (..)) -import Cardano.Ledger.Alonzo.TxBody (alonzoRedeemerPointer, alonzoRedeemerPointerInverse) -import Cardano.Ledger.Babbage.Era (BabbageEra) -import Cardano.Ledger.Babbage.PParams (upgradeBabbagePParams) -import Cardano.Ledger.Babbage.Scripts () -import Cardano.Ledger.Babbage.TxCert () -import Cardano.Ledger.Babbage.TxOut hiding (TxOut) -import Cardano.Ledger.BaseTypes ( - Network (..), - StrictMaybe (..), - isSJust, - ) -import Cardano.Ledger.Binary ( - Annotator (..), - DecCBOR (..), - EncCBOR (..), - Sized (..), - ToCBOR (..), - mkSized, - ) -import Cardano.Ledger.Binary.Coders -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Crypto -import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) -import Cardano.Ledger.Mary.Value (MaryValue (MaryValue), MultiAsset, PolicyID (..), policies) -import Cardano.Ledger.MemoBytes ( - EqRaw, - Mem, - MemoBytes, - MemoHashIndex, - Memoized (..), - eqRaw, - getMemoRawType, - getMemoSafeHash, - lensMemoRawType, - mkMemoized, - zipMemoRawType, - ) -import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) -import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (ProposedPPUpdates), Update (..)) -import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) -import Cardano.Ledger.TxIn (TxIn (..)) -import Control.Arrow (left) -import Control.DeepSeq (NFData) -import Control.Monad (when) -import Data.Foldable as F (foldl') -import Data.Sequence.Strict (StrictSeq, (|>)) -import qualified Data.Sequence.Strict as StrictSeq -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Typeable (Typeable) -import Data.Void (absurd) -import GHC.Generics (Generic) -import Lens.Micro -import NoThunks.Class (NoThunks) - -class (AlonzoEraTxBody era, BabbageEraTxOut era) => BabbageEraTxBody era where - sizedOutputsTxBodyL :: Lens' (TxBody era) (StrictSeq (Sized (TxOut era))) - - referenceInputsTxBodyL :: Lens' (TxBody era) (Set (TxIn (EraCrypto era))) - - totalCollateralTxBodyL :: Lens' (TxBody era) (StrictMaybe Coin) - - collateralReturnTxBodyL :: Lens' (TxBody era) (StrictMaybe (TxOut era)) - - sizedCollateralReturnTxBodyL :: Lens' (TxBody era) (StrictMaybe (Sized (TxOut era))) - - allSizedOutputsTxBodyF :: SimpleGetter (TxBody era) (StrictSeq (Sized (TxOut era))) - --- ====================================== - -data BabbageTxBodyRaw era = BabbageTxBodyRaw - { btbrSpendInputs :: !(Set (TxIn (EraCrypto era))) - , btbrCollateralInputs :: !(Set (TxIn (EraCrypto era))) - , btbrReferenceInputs :: !(Set (TxIn (EraCrypto era))) - , btbrOutputs :: !(StrictSeq (Sized (TxOut era))) - , btbrCollateralReturn :: !(StrictMaybe (Sized (TxOut era))) - , btbrTotalCollateral :: !(StrictMaybe Coin) - , btbrCerts :: !(StrictSeq (TxCert era)) - , btbrWithdrawals :: !(Withdrawals (EraCrypto era)) - , btbrTxFee :: !Coin - , btbrValidityInterval :: !ValidityInterval - , btbrUpdate :: !(StrictMaybe (Update era)) - , btbrReqSignerHashes :: !(Set (KeyHash 'Witness (EraCrypto era))) - , btbrMint :: !(MultiAsset (EraCrypto era)) - , -- The spec makes it clear that the mint field is a - -- Cardano.Ledger.Mary.Value.MaryValue, not a Value. - -- Operations on the TxBody in the BabbageEra depend upon this. - -- We now store only the MultiAsset part of a Mary.Value. - btbrScriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) - , btbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) - , btbrTxNetworkId :: !(StrictMaybe Network) - } - deriving (Generic, Typeable) - --- We override this instance because the 'Sized' types also reference their --- serialisation and as such cannot be compared directly. An alternative would --- be to derive `EqRaw` for `Sized`. -instance - (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => - EqRaw (BabbageTxBodyRaw era) - where - eqRaw a b = - btbrSpendInputs a == btbrSpendInputs b - && btbrCollateralInputs a == btbrCollateralInputs b - && btbrReferenceInputs a == btbrReferenceInputs b - && btbrOutputs a `eqSeqUnsized` btbrOutputs b - && btbrCollateralReturn a `eqMbUnsized` btbrCollateralReturn b - && btbrTotalCollateral a == btbrTotalCollateral b - && btbrCerts a == btbrCerts b - && btbrWithdrawals a == btbrWithdrawals b - && btbrTxFee a == btbrTxFee b - && btbrValidityInterval a == btbrValidityInterval b - && btbrUpdate a == btbrUpdate b - && btbrReqSignerHashes a == btbrReqSignerHashes b - && btbrMint a == btbrMint b - && btbrScriptIntegrityHash a == btbrScriptIntegrityHash b - && btbrAuxDataHash a == btbrAuxDataHash b - && btbrTxNetworkId a == btbrTxNetworkId b - where - eqMbUnsized x y = case (x, y) of - (SJust a', SJust b') -> a' `eqUnsized` b' - (SNothing, SNothing) -> True - _ -> False - eqSeqUnsized x y = - length x == length y - && F.foldl' (\acc (x', y') -> acc && x' `eqUnsized` y') True (StrictSeq.zip x y) - eqUnsized x y = sizedValue x == sizedValue y - -type instance MemoHashIndex BabbageTxBodyRaw = EraIndependentTxBody - -deriving instance - (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => - Eq (BabbageTxBodyRaw era) - -instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => - NoThunks (BabbageTxBodyRaw era) - -instance - (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => - NFData (BabbageTxBodyRaw era) - -deriving instance - (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => - Show (BabbageTxBodyRaw era) - -newtype BabbageTxBody era = TxBodyConstr (MemoBytes BabbageTxBodyRaw era) - deriving newtype (Generic, SafeToHash, ToCBOR) - -instance Memoized BabbageTxBody where - type RawType BabbageTxBody = BabbageTxBodyRaw - -deriving newtype instance - (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => - NFData (BabbageTxBody era) - -inputsBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set (TxIn (EraCrypto era))) -inputsBabbageTxBodyL = - lensMemoRawType btbrSpendInputs $ \txBodyRaw inputs -> txBodyRaw {btbrSpendInputs = inputs} -{-# INLINEABLE inputsBabbageTxBodyL #-} - -outputsBabbageTxBodyL :: - forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictSeq (TxOut era)) -outputsBabbageTxBodyL = - lensMemoRawType (fmap sizedValue . btbrOutputs) $ - \txBodyRaw outputs -> txBodyRaw {btbrOutputs = mkSized (eraProtVerLow @era) <$> outputs} -{-# INLINEABLE outputsBabbageTxBodyL #-} - -feeBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) Coin -feeBabbageTxBodyL = - lensMemoRawType btbrTxFee $ \txBodyRaw fee -> txBodyRaw {btbrTxFee = fee} -{-# INLINEABLE feeBabbageTxBodyL #-} - -auxDataHashBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era))) -auxDataHashBabbageTxBodyL = - lensMemoRawType btbrAuxDataHash $ - \txBodyRaw auxDataHash -> txBodyRaw {btbrAuxDataHash = auxDataHash} -{-# INLINEABLE auxDataHashBabbageTxBodyL #-} - -babbageSpendableInputsTxBodyF :: - BabbageEraTxBody era => SimpleGetter (TxBody era) (Set (TxIn (EraCrypto era))) -babbageSpendableInputsTxBodyF = - to $ \txBody -> - (txBody ^. inputsTxBodyL) - `Set.union` (txBody ^. collateralInputsTxBodyL) -{-# INLINEABLE babbageSpendableInputsTxBodyF #-} - -babbageAllInputsTxBodyF :: - BabbageEraTxBody era => SimpleGetter (TxBody era) (Set (TxIn (EraCrypto era))) -babbageAllInputsTxBodyF = - to $ \txBody -> - (txBody ^. inputsTxBodyL) - `Set.union` (txBody ^. collateralInputsTxBodyL) - `Set.union` (txBody ^. referenceInputsTxBodyL) -{-# INLINEABLE babbageAllInputsTxBodyF #-} - -mintedBabbageTxBodyF :: SimpleGetter (BabbageTxBody era) (Set (PolicyID (EraCrypto era))) -mintedBabbageTxBodyF = to (policies . btbrMint . getMemoRawType) -{-# INLINEABLE mintedBabbageTxBodyF #-} - -withdrawalsBabbbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (Withdrawals (EraCrypto era)) -withdrawalsBabbbageTxBodyL = - lensMemoRawType btbrWithdrawals $ - \txBodyRaw withdrawals -> txBodyRaw {btbrWithdrawals = withdrawals} -{-# INLINEABLE withdrawalsBabbbageTxBodyL #-} - -updateBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe (Update era)) -updateBabbageTxBodyL = - lensMemoRawType btbrUpdate $ \txBodyRaw update -> txBodyRaw {btbrUpdate = update} -{-# INLINEABLE updateBabbageTxBodyL #-} - -certsBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictSeq (TxCert era)) -certsBabbageTxBodyL = - lensMemoRawType btbrCerts $ \txBodyRaw certs -> txBodyRaw {btbrCerts = certs} -{-# INLINEABLE certsBabbageTxBodyL #-} - -vldtBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) ValidityInterval -vldtBabbageTxBodyL = - lensMemoRawType btbrValidityInterval $ \txBodyRaw vldt -> txBodyRaw {btbrValidityInterval = vldt} -{-# INLINEABLE vldtBabbageTxBodyL #-} - -mintBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (MultiAsset (EraCrypto era)) -mintBabbageTxBodyL = - lensMemoRawType btbrMint $ \txBodyRaw mint -> txBodyRaw {btbrMint = mint} -{-# INLINEABLE mintBabbageTxBodyL #-} - -mintValueBabbageTxBodyF :: - (BabbageEraTxBody era, Value era ~ MaryValue (EraCrypto era)) => - SimpleGetter (BabbageTxBody era) (Value era) -mintValueBabbageTxBodyF = mintBabbageTxBodyL . to (MaryValue mempty) -{-# INLINEABLE mintValueBabbageTxBodyF #-} - -collateralInputsBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set (TxIn (EraCrypto era))) -collateralInputsBabbageTxBodyL = - lensMemoRawType btbrCollateralInputs $ - \txBodyRaw collateral -> txBodyRaw {btbrCollateralInputs = collateral} -{-# INLINEABLE collateralInputsBabbageTxBodyL #-} - -reqSignerHashesBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set (KeyHash 'Witness (EraCrypto era))) -reqSignerHashesBabbageTxBodyL = - lensMemoRawType btbrReqSignerHashes $ - \txBodyRaw reqSignerHashes -> txBodyRaw {btbrReqSignerHashes = reqSignerHashes} -{-# INLINEABLE reqSignerHashesBabbageTxBodyL #-} - -scriptIntegrityHashBabbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era))) -scriptIntegrityHashBabbageTxBodyL = - lensMemoRawType btbrScriptIntegrityHash $ - \txBodyRaw scriptIntegrityHash -> txBodyRaw {btbrScriptIntegrityHash = scriptIntegrityHash} -{-# INLINEABLE scriptIntegrityHashBabbageTxBodyL #-} - -networkIdBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe Network) -networkIdBabbageTxBodyL = - lensMemoRawType btbrTxNetworkId $ \txBodyRaw networkId -> txBodyRaw {btbrTxNetworkId = networkId} -{-# INLINEABLE networkIdBabbageTxBodyL #-} - -sizedOutputsBabbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (StrictSeq (Sized (TxOut era))) -sizedOutputsBabbageTxBodyL = - lensMemoRawType btbrOutputs $ \txBodyRaw outputs -> txBodyRaw {btbrOutputs = outputs} -{-# INLINEABLE sizedOutputsBabbageTxBodyL #-} - -referenceInputsBabbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (Set (TxIn (EraCrypto era))) -referenceInputsBabbageTxBodyL = - lensMemoRawType btbrReferenceInputs $ - \txBodyRaw reference -> txBodyRaw {btbrReferenceInputs = reference} -{-# INLINEABLE referenceInputsBabbageTxBodyL #-} - -totalCollateralBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe Coin) -totalCollateralBabbageTxBodyL = - lensMemoRawType btbrTotalCollateral $ - \txBodyRaw totalCollateral -> txBodyRaw {btbrTotalCollateral = totalCollateral} -{-# INLINEABLE totalCollateralBabbageTxBodyL #-} - -collateralReturnBabbageTxBodyL :: - forall era. - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (StrictMaybe (TxOut era)) -collateralReturnBabbageTxBodyL = - lensMemoRawType (fmap sizedValue . btbrCollateralReturn) $ - \txBodyRaw collateralReturn -> - txBodyRaw {btbrCollateralReturn = mkSized (eraProtVerLow @era) <$> collateralReturn} -{-# INLINEABLE collateralReturnBabbageTxBodyL #-} - -sizedCollateralReturnBabbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (StrictMaybe (Sized (TxOut era))) -sizedCollateralReturnBabbageTxBodyL = - lensMemoRawType btbrCollateralReturn $ - \txBodyRaw collateralReturn -> txBodyRaw {btbrCollateralReturn = collateralReturn} -{-# INLINEABLE sizedCollateralReturnBabbageTxBodyL #-} - -allSizedOutputsBabbageTxBodyF :: - BabbageEraTxBody era => - SimpleGetter (TxBody era) (StrictSeq (Sized (TxOut era))) -allSizedOutputsBabbageTxBodyF = - to $ \txBody -> - let txOuts = txBody ^. sizedOutputsTxBodyL - in case txBody ^. sizedCollateralReturnTxBodyL of - SNothing -> txOuts - SJust collTxOut -> txOuts |> collTxOut -{-# INLINEABLE allSizedOutputsBabbageTxBodyF #-} - -data BabbageTxBodyUpgradeError - = -- | The update attempts to update the decentralistion parameter, which is - -- dropped in Babbage. - BTBUEUpdatesD - | -- | The update attempts to update the extra entropy, which is dropped in - -- Babbage. - BTBUEUpdatesExtraEntropy - deriving (Eq, Show) - -instance Crypto c => EraTxBody (BabbageEra c) where - {-# SPECIALIZE instance EraTxBody (BabbageEra StandardCrypto) #-} - - type TxBody (BabbageEra c) = BabbageTxBody (BabbageEra c) - type TxBodyUpgradeError (BabbageEra c) = BabbageTxBodyUpgradeError - - mkBasicTxBody = mkMemoized basicBabbageTxBodyRaw - - inputsTxBodyL = inputsBabbageTxBodyL - {-# INLINE inputsTxBodyL #-} - - outputsTxBodyL = outputsBabbageTxBodyL - {-# INLINE outputsTxBodyL #-} - - feeTxBodyL = feeBabbageTxBodyL - {-# INLINE feeTxBodyL #-} - - auxDataHashTxBodyL = auxDataHashBabbageTxBodyL - {-# INLINE auxDataHashTxBodyL #-} - - spendableInputsTxBodyF = babbageSpendableInputsTxBodyF - {-# INLINE spendableInputsTxBodyF #-} - - allInputsTxBodyF = babbageAllInputsTxBodyF - {-# INLINE allInputsTxBodyF #-} - - withdrawalsTxBodyL = withdrawalsBabbbageTxBodyL - {-# INLINE withdrawalsTxBodyL #-} - - certsTxBodyL = certsBabbageTxBodyL - {-# INLINE certsTxBodyL #-} - - getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody - - upgradeTxBody txBody = do - certs <- - traverse - (left absurd . upgradeTxCert) - (txBody ^. certsTxBodyL) - updates <- traverse upgradeUpdate (txBody ^. updateTxBodyL) - pure $ - BabbageTxBody - { btbInputs = txBody ^. inputsTxBodyL - , btbOutputs = - mkSized (eraProtVerLow @(BabbageEra c)) . upgradeTxOut <$> (txBody ^. outputsTxBodyL) - , btbCerts = certs - , btbWithdrawals = txBody ^. withdrawalsTxBodyL - , btbTxFee = txBody ^. feeTxBodyL - , btbValidityInterval = txBody ^. vldtTxBodyL - , btbUpdate = updates - , btbAuxDataHash = txBody ^. auxDataHashTxBodyL - , btbMint = txBody ^. mintTxBodyL - , btbCollateral = txBody ^. collateralInputsTxBodyL - , btbReqSignerHashes = txBody ^. reqSignerHashesTxBodyL - , btbScriptIntegrityHash = txBody ^. scriptIntegrityHashTxBodyL - , btbTxNetworkId = txBody ^. networkIdTxBodyL - , btbReferenceInputs = mempty - , btbCollateralReturn = SNothing - , btbTotalCollateral = SNothing - } - where - upgradeUpdate :: - Update (AlonzoEra c) -> - Either BabbageTxBodyUpgradeError (Update (BabbageEra c)) - upgradeUpdate (Update pp epoch) = - Update <$> upgradeProposedPPUpdates pp <*> pure epoch - - -- Note that here we use 'upgradeBabbagePParams False' in order to - -- preserve 'CoinsPerUTxOWord', in spite of the value now being - -- semantically incorrect. Anything else will result in an invalid - -- transaction. - upgradeProposedPPUpdates :: - ProposedPPUpdates (AlonzoEra c) -> - Either BabbageTxBodyUpgradeError (ProposedPPUpdates (BabbageEra c)) - upgradeProposedPPUpdates (ProposedPPUpdates m) = - ProposedPPUpdates - <$> traverse - ( \(PParamsUpdate pphkd) -> do - when (isSJust $ appD pphkd) $ - Left BTBUEUpdatesD - when (isSJust $ appExtraEntropy pphkd) $ - Left BTBUEUpdatesExtraEntropy - pure . PParamsUpdate $ upgradeBabbagePParams False pphkd - ) - m - -instance Crypto c => ShelleyEraTxBody (BabbageEra c) where - {-# SPECIALIZE instance ShelleyEraTxBody (BabbageEra StandardCrypto) #-} - - ttlTxBodyL = notSupportedInThisEraL - {-# INLINE ttlTxBodyL #-} - - updateTxBodyL = updateBabbageTxBodyL - {-# INLINE updateTxBodyL #-} - -instance Crypto c => AllegraEraTxBody (BabbageEra c) where - {-# SPECIALIZE instance AllegraEraTxBody (BabbageEra StandardCrypto) #-} - - vldtTxBodyL = vldtBabbageTxBodyL - {-# INLINE vldtTxBodyL #-} - -instance Crypto c => MaryEraTxBody (BabbageEra c) where - {-# SPECIALIZE instance MaryEraTxBody (BabbageEra StandardCrypto) #-} - - mintTxBodyL = mintBabbageTxBodyL - {-# INLINE mintTxBodyL #-} - - mintValueTxBodyF = mintValueBabbageTxBodyF - {-# INLINE mintValueTxBodyF #-} - - mintedTxBodyF = mintedBabbageTxBodyF - {-# INLINE mintedTxBodyF #-} - -instance Crypto c => AlonzoEraTxBody (BabbageEra c) where - {-# SPECIALIZE instance AlonzoEraTxBody (BabbageEra StandardCrypto) #-} - - collateralInputsTxBodyL = collateralInputsBabbageTxBodyL - {-# INLINE collateralInputsTxBodyL #-} - - reqSignerHashesTxBodyL = reqSignerHashesBabbageTxBodyL - {-# INLINE reqSignerHashesTxBodyL #-} - - scriptIntegrityHashTxBodyL = scriptIntegrityHashBabbageTxBodyL - {-# INLINE scriptIntegrityHashTxBodyL #-} - - networkIdTxBodyL = networkIdBabbageTxBodyL - {-# INLINE networkIdTxBodyL #-} - - redeemerPointer = alonzoRedeemerPointer - - redeemerPointerInverse = alonzoRedeemerPointerInverse - -instance Crypto c => BabbageEraTxBody (BabbageEra c) where - {-# SPECIALIZE instance BabbageEraTxBody (BabbageEra StandardCrypto) #-} - - sizedOutputsTxBodyL = sizedOutputsBabbageTxBodyL - {-# INLINE sizedOutputsTxBodyL #-} - - referenceInputsTxBodyL = referenceInputsBabbageTxBodyL - {-# INLINE referenceInputsTxBodyL #-} - - totalCollateralTxBodyL = totalCollateralBabbageTxBodyL - {-# INLINE totalCollateralTxBodyL #-} - - collateralReturnTxBodyL = collateralReturnBabbageTxBodyL - {-# INLINE collateralReturnTxBodyL #-} - - sizedCollateralReturnTxBodyL = sizedCollateralReturnBabbageTxBodyL - {-# INLINE sizedCollateralReturnTxBodyL #-} - - allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF - {-# INLINE allSizedOutputsTxBodyF #-} - -instance - (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => - EqRaw (BabbageTxBody era) - where - eqRaw = zipMemoRawType eqRaw - -deriving newtype instance - (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => - Eq (BabbageTxBody era) - -deriving instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => - NoThunks (BabbageTxBody era) - -deriving instance - (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => - Show (BabbageTxBody era) - -deriving via - (Mem BabbageTxBodyRaw era) - instance - (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => - DecCBOR (Annotator (BabbageTxBody era)) - -instance - (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => - DecCBOR (Annotator (BabbageTxBodyRaw era)) - where - decCBOR = pure <$> decCBOR - -pattern BabbageTxBody :: - BabbageEraTxBody era => - Set (TxIn (EraCrypto era)) -> - Set (TxIn (EraCrypto era)) -> - Set (TxIn (EraCrypto era)) -> - StrictSeq (Sized (TxOut era)) -> - StrictMaybe (Sized (TxOut era)) -> - StrictMaybe Coin -> - StrictSeq (TxCert era) -> - Withdrawals (EraCrypto era) -> - Coin -> - ValidityInterval -> - StrictMaybe (Update era) -> - Set (KeyHash 'Witness (EraCrypto era)) -> - MultiAsset (EraCrypto era) -> - StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -> - StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> - StrictMaybe Network -> - BabbageTxBody era -pattern BabbageTxBody - { btbInputs - , btbCollateral - , btbReferenceInputs - , btbOutputs - , btbCollateralReturn - , btbTotalCollateral - , btbCerts - , btbWithdrawals - , btbTxFee - , btbValidityInterval - , btbUpdate - , btbReqSignerHashes - , btbMint - , btbScriptIntegrityHash - , btbAuxDataHash - , btbTxNetworkId - } <- - ( getMemoRawType -> - BabbageTxBodyRaw - { btbrSpendInputs = btbInputs - , btbrCollateralInputs = btbCollateral - , btbrReferenceInputs = btbReferenceInputs - , btbrOutputs = btbOutputs - , btbrCollateralReturn = btbCollateralReturn - , btbrTotalCollateral = btbTotalCollateral - , btbrCerts = btbCerts - , btbrWithdrawals = btbWithdrawals - , btbrTxFee = btbTxFee - , btbrValidityInterval = btbValidityInterval - , btbrUpdate = btbUpdate - , btbrReqSignerHashes = btbReqSignerHashes - , btbrMint = btbMint - , btbrScriptIntegrityHash = btbScriptIntegrityHash - , btbrAuxDataHash = btbAuxDataHash - , btbrTxNetworkId = btbTxNetworkId - } - ) - where - BabbageTxBody - inputs - collateral - referenceInputs - outputs - collateralReturn - totalCollateral - certs - withdrawals - txFee - validityInterval - update - reqSignerHashes - mint - scriptIntegrityHash - auxDataHash - txNetworkId = - mkMemoized $ - BabbageTxBodyRaw - { btbrSpendInputs = inputs - , btbrCollateralInputs = collateral - , btbrReferenceInputs = referenceInputs - , btbrOutputs = outputs - , btbrCollateralReturn = collateralReturn - , btbrTotalCollateral = totalCollateral - , btbrCerts = certs - , btbrWithdrawals = withdrawals - , btbrTxFee = txFee - , btbrValidityInterval = validityInterval - , btbrUpdate = update - , btbrReqSignerHashes = reqSignerHashes - , btbrMint = mint - , btbrScriptIntegrityHash = scriptIntegrityHash - , btbrAuxDataHash = auxDataHash - , btbrTxNetworkId = txNetworkId - } - -{-# COMPLETE BabbageTxBody #-} - -instance c ~ EraCrypto era => HashAnnotated (BabbageTxBody era) EraIndependentTxBody c where - hashAnnotated = getMemoSafeHash - --- ============================================================================== --- We define these accessor functions manually, because if we define them using --- the record syntax in the TxBody pattern, they inherit the (BabbageBody era) --- constraint as a precondition. This is unnecessary, as one can see below --- they need not be constrained at all. This should be fixed in the GHC compiler. - -spendInputs' :: BabbageTxBody era -> Set (TxIn (EraCrypto era)) -collateralInputs' :: BabbageTxBody era -> Set (TxIn (EraCrypto era)) -referenceInputs' :: BabbageTxBody era -> Set (TxIn (EraCrypto era)) -outputs' :: BabbageTxBody era -> StrictSeq (TxOut era) -collateralReturn' :: BabbageTxBody era -> StrictMaybe (TxOut era) -totalCollateral' :: BabbageTxBody era -> StrictMaybe Coin -certs' :: BabbageTxBody era -> StrictSeq (TxCert era) -txfee' :: BabbageTxBody era -> Coin -withdrawals' :: BabbageTxBody era -> Withdrawals (EraCrypto era) -vldt' :: BabbageTxBody era -> ValidityInterval -update' :: BabbageTxBody era -> StrictMaybe (Update era) -reqSignerHashes' :: BabbageTxBody era -> Set (KeyHash 'Witness (EraCrypto era)) -adHash' :: BabbageTxBody era -> StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -mint' :: BabbageTxBody era -> MultiAsset (EraCrypto era) -scriptIntegrityHash' :: BabbageTxBody era -> StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -spendInputs' = btbrSpendInputs . getMemoRawType - -txnetworkid' :: BabbageTxBody era -> StrictMaybe Network - -collateralInputs' = btbrCollateralInputs . getMemoRawType - -referenceInputs' = btbrReferenceInputs . getMemoRawType - -outputs' = fmap sizedValue . btbrOutputs . getMemoRawType - -collateralReturn' = fmap sizedValue . btbrCollateralReturn . getMemoRawType - -totalCollateral' = btbrTotalCollateral . getMemoRawType - -certs' = btbrCerts . getMemoRawType - -withdrawals' = btbrWithdrawals . getMemoRawType - -txfee' = btbrTxFee . getMemoRawType - -vldt' = btbrValidityInterval . getMemoRawType - -update' = btbrUpdate . getMemoRawType - -reqSignerHashes' = btbrReqSignerHashes . getMemoRawType - -adHash' = btbrAuxDataHash . getMemoRawType - -mint' = btbrMint . getMemoRawType - -scriptIntegrityHash' = btbrScriptIntegrityHash . getMemoRawType - -txnetworkid' = btbrTxNetworkId . getMemoRawType - --------------------------------------------------------------------------------- --- Serialisation --------------------------------------------------------------------------------- - --- | Encodes memoized bytes created upon construction. -instance Era era => EncCBOR (BabbageTxBody era) - -instance - (Era era, EncCBOR (TxOut era), EncCBOR (TxCert era), EncCBOR (PParamsUpdate era)) => - EncCBOR (BabbageTxBodyRaw era) - where - encCBOR - BabbageTxBodyRaw - { btbrSpendInputs - , btbrCollateralInputs - , btbrReferenceInputs - , btbrOutputs - , btbrCollateralReturn - , btbrTotalCollateral - , btbrCerts - , btbrWithdrawals - , btbrTxFee - , btbrValidityInterval = ValidityInterval bot top - , btbrUpdate - , btbrReqSignerHashes - , btbrMint - , btbrScriptIntegrityHash - , btbrAuxDataHash - , btbrTxNetworkId - } = - encode $ - Keyed - ( \i ifee ri o cr tc f t c w u b rsh mi sh ah ni -> - BabbageTxBodyRaw i ifee ri o cr tc c w f (ValidityInterval b t) u rsh mi sh ah ni - ) - !> Key 0 (To btbrSpendInputs) - !> Omit null (Key 13 (To btbrCollateralInputs)) - !> Omit null (Key 18 (To btbrReferenceInputs)) - !> Key 1 (To btbrOutputs) - !> encodeKeyedStrictMaybe 16 btbrCollateralReturn - !> encodeKeyedStrictMaybe 17 btbrTotalCollateral - !> Key 2 (To btbrTxFee) - !> encodeKeyedStrictMaybe 3 top - !> Omit null (Key 4 (To btbrCerts)) - !> Omit (null . unWithdrawals) (Key 5 (To btbrWithdrawals)) - !> encodeKeyedStrictMaybe 6 btbrUpdate - !> encodeKeyedStrictMaybe 8 bot - !> Omit null (Key 14 (To btbrReqSignerHashes)) - !> Omit (== mempty) (Key 9 (To btbrMint)) - !> encodeKeyedStrictMaybe 11 btbrScriptIntegrityHash - !> encodeKeyedStrictMaybe 7 btbrAuxDataHash - !> encodeKeyedStrictMaybe 15 btbrTxNetworkId - -instance - (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => - DecCBOR (BabbageTxBodyRaw era) - where - decCBOR = - decode $ - SparseKeyed - "BabbageTxBodyRaw" - basicBabbageTxBodyRaw - bodyFields - requiredFields - where - bodyFields :: Word -> Field (BabbageTxBodyRaw era) - bodyFields 0 = field (\x tx -> tx {btbrSpendInputs = x}) From - bodyFields 13 = field (\x tx -> tx {btbrCollateralInputs = x}) From - bodyFields 18 = field (\x tx -> tx {btbrReferenceInputs = x}) From - bodyFields 1 = field (\x tx -> tx {btbrOutputs = x}) From - bodyFields 16 = ofield (\x tx -> tx {btbrCollateralReturn = x}) From - bodyFields 17 = ofield (\x tx -> tx {btbrTotalCollateral = x}) From - bodyFields 2 = field (\x tx -> tx {btbrTxFee = x}) From - bodyFields 3 = - ofield - (\x tx -> tx {btbrValidityInterval = (btbrValidityInterval tx) {invalidHereafter = x}}) - From - bodyFields 4 = field (\x tx -> tx {btbrCerts = x}) From - bodyFields 5 = field (\x tx -> tx {btbrWithdrawals = x}) From - bodyFields 6 = ofield (\x tx -> tx {btbrUpdate = x}) From - bodyFields 7 = ofield (\x tx -> tx {btbrAuxDataHash = x}) From - bodyFields 8 = - ofield - (\x tx -> tx {btbrValidityInterval = (btbrValidityInterval tx) {invalidBefore = x}}) - From - bodyFields 9 = field (\x tx -> tx {btbrMint = x}) From - bodyFields 11 = ofield (\x tx -> tx {btbrScriptIntegrityHash = x}) From - bodyFields 14 = field (\x tx -> tx {btbrReqSignerHashes = x}) From - bodyFields 15 = ofield (\x tx -> tx {btbrTxNetworkId = x}) From - bodyFields n = field (\_ t -> t) (Invalid n) - {-# INLINE bodyFields #-} - requiredFields :: [(Word, String)] - requiredFields = - [ (0, "inputs") - , (1, "outputs") - , (2, "fee") - ] - {-# INLINE decCBOR #-} - -basicBabbageTxBodyRaw :: BabbageTxBodyRaw era -basicBabbageTxBodyRaw = - BabbageTxBodyRaw - mempty - mempty - mempty - StrictSeq.empty - SNothing - SNothing - StrictSeq.empty - (Withdrawals mempty) - mempty - (ValidityInterval SNothing SNothing) - SNothing - mempty - mempty - SNothing - SNothing - SNothing +import Cardano.Ledger.Babbage.TxBody.Internal diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs new file mode 100644 index 00000000000..ac0bc5a9cea --- /dev/null +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs @@ -0,0 +1,875 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Provides Babbage TxBody internals +-- +-- = Warning +-- +-- This module is considered __internal__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +module Cardano.Ledger.Babbage.TxBody.Internal ( + BabbageTxOut ( + BabbageTxOut, + TxOutCompact, + TxOutCompactDH, + TxOutCompactDatum, + TxOutCompactRefScript + ), + allSizedOutputsBabbageTxBodyF, + babbageMinUTxOValue, + BabbageTxBody ( + .., + BabbageTxBody, + btbInputs, + btbCollateral, + btbReferenceInputs, + btbOutputs, + btbCollateralReturn, + btbTotalCollateral, + btbCerts, + btbWithdrawals, + btbTxFee, + btbValidityInterval, + btbUpdate, + btbReqSignerHashes, + btbMint, + btbScriptIntegrityHash, + btbAuxDataHash, + btbTxNetworkId + ), + BabbageTxBodyRaw (..), + BabbageTxBodyUpgradeError (..), + babbageAllInputsTxBodyF, + babbageSpendableInputsTxBodyF, + BabbageEraTxBody (..), + spendInputs', + collateralInputs', + referenceInputs', + outputs', + collateralReturn', + totalCollateral', + certs', + withdrawals', + txfee', + vldt', + update', + reqSignerHashes', + mint', + scriptIntegrityHash', + adHash', + txnetworkid', + getEitherAddrBabbageTxOut, + EraIndependentScriptIntegrity, + ScriptIntegrityHash, + txOutData, + txOutDataHash, + txOutScript, +) where + +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Core +import Cardano.Ledger.Alonzo.PParams (AlonzoPParams (appExtraEntropy), appD) +import Cardano.Ledger.Alonzo.TxAuxData (AuxiliaryDataHash (..)) +import Cardano.Ledger.Alonzo.TxBody (alonzoRedeemerPointer, alonzoRedeemerPointerInverse) +import Cardano.Ledger.Babbage.Era (BabbageEra) +import Cardano.Ledger.Babbage.PParams (upgradeBabbagePParams) +import Cardano.Ledger.Babbage.Scripts () +import Cardano.Ledger.Babbage.TxCert () +import Cardano.Ledger.Babbage.TxOut hiding (TxOut) +import Cardano.Ledger.BaseTypes ( + Network (..), + StrictMaybe (..), + isSJust, + ) +import Cardano.Ledger.Binary ( + Annotator (..), + DecCBOR (..), + EncCBOR (..), + Sized (..), + ToCBOR (..), + mkSized, + ) +import Cardano.Ledger.Binary.Coders +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Crypto +import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) +import Cardano.Ledger.Mary.Value (MaryValue (MaryValue), MultiAsset, PolicyID (..), policies) +import Cardano.Ledger.MemoBytes ( + EqRaw, + Mem, + MemoBytes, + MemoHashIndex, + Memoized (..), + eqRaw, + getMemoRawType, + getMemoSafeHash, + lensMemoRawType, + mkMemoized, + zipMemoRawType, + ) +import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) +import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (ProposedPPUpdates), Update (..)) +import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) +import Cardano.Ledger.TxIn (TxIn (..)) +import Control.Arrow (left) +import Control.DeepSeq (NFData) +import Control.Monad (when) +import Data.Foldable as F (foldl') +import Data.Sequence.Strict (StrictSeq, (|>)) +import qualified Data.Sequence.Strict as StrictSeq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (Typeable) +import Data.Void (absurd) +import GHC.Generics (Generic) +import Lens.Micro +import NoThunks.Class (NoThunks) + +class (AlonzoEraTxBody era, BabbageEraTxOut era) => BabbageEraTxBody era where + sizedOutputsTxBodyL :: Lens' (TxBody era) (StrictSeq (Sized (TxOut era))) + + referenceInputsTxBodyL :: Lens' (TxBody era) (Set (TxIn (EraCrypto era))) + + totalCollateralTxBodyL :: Lens' (TxBody era) (StrictMaybe Coin) + + collateralReturnTxBodyL :: Lens' (TxBody era) (StrictMaybe (TxOut era)) + + sizedCollateralReturnTxBodyL :: Lens' (TxBody era) (StrictMaybe (Sized (TxOut era))) + + allSizedOutputsTxBodyF :: SimpleGetter (TxBody era) (StrictSeq (Sized (TxOut era))) + +-- ====================================== + +data BabbageTxBodyRaw era = BabbageTxBodyRaw + { btbrSpendInputs :: !(Set (TxIn (EraCrypto era))) + , btbrCollateralInputs :: !(Set (TxIn (EraCrypto era))) + , btbrReferenceInputs :: !(Set (TxIn (EraCrypto era))) + , btbrOutputs :: !(StrictSeq (Sized (TxOut era))) + , btbrCollateralReturn :: !(StrictMaybe (Sized (TxOut era))) + , btbrTotalCollateral :: !(StrictMaybe Coin) + , btbrCerts :: !(StrictSeq (TxCert era)) + , btbrWithdrawals :: !(Withdrawals (EraCrypto era)) + , btbrTxFee :: !Coin + , btbrValidityInterval :: !ValidityInterval + , btbrUpdate :: !(StrictMaybe (Update era)) + , btbrReqSignerHashes :: !(Set (KeyHash 'Witness (EraCrypto era))) + , btbrMint :: !(MultiAsset (EraCrypto era)) + , -- The spec makes it clear that the mint field is a + -- Cardano.Ledger.Mary.Value.MaryValue, not a Value. + -- Operations on the TxBody in the BabbageEra depend upon this. + -- We now store only the MultiAsset part of a Mary.Value. + btbrScriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) + , btbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) + , btbrTxNetworkId :: !(StrictMaybe Network) + } + deriving (Generic, Typeable) + +-- We override this instance because the 'Sized' types also reference their +-- serialisation and as such cannot be compared directly. An alternative would +-- be to derive `EqRaw` for `Sized`. +instance + (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => + EqRaw (BabbageTxBodyRaw era) + where + eqRaw a b = + btbrSpendInputs a == btbrSpendInputs b + && btbrCollateralInputs a == btbrCollateralInputs b + && btbrReferenceInputs a == btbrReferenceInputs b + && btbrOutputs a `eqSeqUnsized` btbrOutputs b + && btbrCollateralReturn a `eqMbUnsized` btbrCollateralReturn b + && btbrTotalCollateral a == btbrTotalCollateral b + && btbrCerts a == btbrCerts b + && btbrWithdrawals a == btbrWithdrawals b + && btbrTxFee a == btbrTxFee b + && btbrValidityInterval a == btbrValidityInterval b + && btbrUpdate a == btbrUpdate b + && btbrReqSignerHashes a == btbrReqSignerHashes b + && btbrMint a == btbrMint b + && btbrScriptIntegrityHash a == btbrScriptIntegrityHash b + && btbrAuxDataHash a == btbrAuxDataHash b + && btbrTxNetworkId a == btbrTxNetworkId b + where + eqMbUnsized x y = case (x, y) of + (SJust a', SJust b') -> a' `eqUnsized` b' + (SNothing, SNothing) -> True + _ -> False + eqSeqUnsized x y = + length x == length y + && F.foldl' (\acc (x', y') -> acc && x' `eqUnsized` y') True (StrictSeq.zip x y) + eqUnsized x y = sizedValue x == sizedValue y + +type instance MemoHashIndex BabbageTxBodyRaw = EraIndependentTxBody + +deriving instance + (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => + Eq (BabbageTxBodyRaw era) + +instance + (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => + NoThunks (BabbageTxBodyRaw era) + +instance + (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => + NFData (BabbageTxBodyRaw era) + +deriving instance + (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => + Show (BabbageTxBodyRaw era) + +newtype BabbageTxBody era = TxBodyConstr (MemoBytes BabbageTxBodyRaw era) + deriving newtype (Generic, SafeToHash, ToCBOR) + +instance Memoized BabbageTxBody where + type RawType BabbageTxBody = BabbageTxBodyRaw + +deriving newtype instance + (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => + NFData (BabbageTxBody era) + +inputsBabbageTxBodyL :: + BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set (TxIn (EraCrypto era))) +inputsBabbageTxBodyL = + lensMemoRawType btbrSpendInputs $ \txBodyRaw inputs -> txBodyRaw {btbrSpendInputs = inputs} +{-# INLINEABLE inputsBabbageTxBodyL #-} + +outputsBabbageTxBodyL :: + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictSeq (TxOut era)) +outputsBabbageTxBodyL = + lensMemoRawType (fmap sizedValue . btbrOutputs) $ + \txBodyRaw outputs -> txBodyRaw {btbrOutputs = mkSized (eraProtVerLow @era) <$> outputs} +{-# INLINEABLE outputsBabbageTxBodyL #-} + +feeBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) Coin +feeBabbageTxBodyL = + lensMemoRawType btbrTxFee $ \txBodyRaw fee -> txBodyRaw {btbrTxFee = fee} +{-# INLINEABLE feeBabbageTxBodyL #-} + +auxDataHashBabbageTxBodyL :: + BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era))) +auxDataHashBabbageTxBodyL = + lensMemoRawType btbrAuxDataHash $ + \txBodyRaw auxDataHash -> txBodyRaw {btbrAuxDataHash = auxDataHash} +{-# INLINEABLE auxDataHashBabbageTxBodyL #-} + +babbageSpendableInputsTxBodyF :: + BabbageEraTxBody era => SimpleGetter (TxBody era) (Set (TxIn (EraCrypto era))) +babbageSpendableInputsTxBodyF = + to $ \txBody -> + (txBody ^. inputsTxBodyL) + `Set.union` (txBody ^. collateralInputsTxBodyL) +{-# INLINEABLE babbageSpendableInputsTxBodyF #-} + +babbageAllInputsTxBodyF :: + BabbageEraTxBody era => SimpleGetter (TxBody era) (Set (TxIn (EraCrypto era))) +babbageAllInputsTxBodyF = + to $ \txBody -> + (txBody ^. inputsTxBodyL) + `Set.union` (txBody ^. collateralInputsTxBodyL) + `Set.union` (txBody ^. referenceInputsTxBodyL) +{-# INLINEABLE babbageAllInputsTxBodyF #-} + +mintedBabbageTxBodyF :: SimpleGetter (BabbageTxBody era) (Set (PolicyID (EraCrypto era))) +mintedBabbageTxBodyF = to (policies . btbrMint . getMemoRawType) +{-# INLINEABLE mintedBabbageTxBodyF #-} + +withdrawalsBabbbageTxBodyL :: + BabbageEraTxBody era => + Lens' (BabbageTxBody era) (Withdrawals (EraCrypto era)) +withdrawalsBabbbageTxBodyL = + lensMemoRawType btbrWithdrawals $ + \txBodyRaw withdrawals -> txBodyRaw {btbrWithdrawals = withdrawals} +{-# INLINEABLE withdrawalsBabbbageTxBodyL #-} + +updateBabbageTxBodyL :: + BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe (Update era)) +updateBabbageTxBodyL = + lensMemoRawType btbrUpdate $ \txBodyRaw update -> txBodyRaw {btbrUpdate = update} +{-# INLINEABLE updateBabbageTxBodyL #-} + +certsBabbageTxBodyL :: + BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictSeq (TxCert era)) +certsBabbageTxBodyL = + lensMemoRawType btbrCerts $ \txBodyRaw certs -> txBodyRaw {btbrCerts = certs} +{-# INLINEABLE certsBabbageTxBodyL #-} + +vldtBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) ValidityInterval +vldtBabbageTxBodyL = + lensMemoRawType btbrValidityInterval $ \txBodyRaw vldt -> txBodyRaw {btbrValidityInterval = vldt} +{-# INLINEABLE vldtBabbageTxBodyL #-} + +mintBabbageTxBodyL :: + BabbageEraTxBody era => Lens' (BabbageTxBody era) (MultiAsset (EraCrypto era)) +mintBabbageTxBodyL = + lensMemoRawType btbrMint $ \txBodyRaw mint -> txBodyRaw {btbrMint = mint} +{-# INLINEABLE mintBabbageTxBodyL #-} + +mintValueBabbageTxBodyF :: + (BabbageEraTxBody era, Value era ~ MaryValue (EraCrypto era)) => + SimpleGetter (BabbageTxBody era) (Value era) +mintValueBabbageTxBodyF = mintBabbageTxBodyL . to (MaryValue mempty) +{-# INLINEABLE mintValueBabbageTxBodyF #-} + +collateralInputsBabbageTxBodyL :: + BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set (TxIn (EraCrypto era))) +collateralInputsBabbageTxBodyL = + lensMemoRawType btbrCollateralInputs $ + \txBodyRaw collateral -> txBodyRaw {btbrCollateralInputs = collateral} +{-# INLINEABLE collateralInputsBabbageTxBodyL #-} + +reqSignerHashesBabbageTxBodyL :: + BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set (KeyHash 'Witness (EraCrypto era))) +reqSignerHashesBabbageTxBodyL = + lensMemoRawType btbrReqSignerHashes $ + \txBodyRaw reqSignerHashes -> txBodyRaw {btbrReqSignerHashes = reqSignerHashes} +{-# INLINEABLE reqSignerHashesBabbageTxBodyL #-} + +scriptIntegrityHashBabbageTxBodyL :: + BabbageEraTxBody era => + Lens' (BabbageTxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era))) +scriptIntegrityHashBabbageTxBodyL = + lensMemoRawType btbrScriptIntegrityHash $ + \txBodyRaw scriptIntegrityHash -> txBodyRaw {btbrScriptIntegrityHash = scriptIntegrityHash} +{-# INLINEABLE scriptIntegrityHashBabbageTxBodyL #-} + +networkIdBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe Network) +networkIdBabbageTxBodyL = + lensMemoRawType btbrTxNetworkId $ \txBodyRaw networkId -> txBodyRaw {btbrTxNetworkId = networkId} +{-# INLINEABLE networkIdBabbageTxBodyL #-} + +sizedOutputsBabbageTxBodyL :: + BabbageEraTxBody era => + Lens' (BabbageTxBody era) (StrictSeq (Sized (TxOut era))) +sizedOutputsBabbageTxBodyL = + lensMemoRawType btbrOutputs $ \txBodyRaw outputs -> txBodyRaw {btbrOutputs = outputs} +{-# INLINEABLE sizedOutputsBabbageTxBodyL #-} + +referenceInputsBabbageTxBodyL :: + BabbageEraTxBody era => + Lens' (BabbageTxBody era) (Set (TxIn (EraCrypto era))) +referenceInputsBabbageTxBodyL = + lensMemoRawType btbrReferenceInputs $ + \txBodyRaw reference -> txBodyRaw {btbrReferenceInputs = reference} +{-# INLINEABLE referenceInputsBabbageTxBodyL #-} + +totalCollateralBabbageTxBodyL :: + BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe Coin) +totalCollateralBabbageTxBodyL = + lensMemoRawType btbrTotalCollateral $ + \txBodyRaw totalCollateral -> txBodyRaw {btbrTotalCollateral = totalCollateral} +{-# INLINEABLE totalCollateralBabbageTxBodyL #-} + +collateralReturnBabbageTxBodyL :: + forall era. + BabbageEraTxBody era => + Lens' (BabbageTxBody era) (StrictMaybe (TxOut era)) +collateralReturnBabbageTxBodyL = + lensMemoRawType (fmap sizedValue . btbrCollateralReturn) $ + \txBodyRaw collateralReturn -> + txBodyRaw {btbrCollateralReturn = mkSized (eraProtVerLow @era) <$> collateralReturn} +{-# INLINEABLE collateralReturnBabbageTxBodyL #-} + +sizedCollateralReturnBabbageTxBodyL :: + BabbageEraTxBody era => + Lens' (BabbageTxBody era) (StrictMaybe (Sized (TxOut era))) +sizedCollateralReturnBabbageTxBodyL = + lensMemoRawType btbrCollateralReturn $ + \txBodyRaw collateralReturn -> txBodyRaw {btbrCollateralReturn = collateralReturn} +{-# INLINEABLE sizedCollateralReturnBabbageTxBodyL #-} + +allSizedOutputsBabbageTxBodyF :: + BabbageEraTxBody era => + SimpleGetter (TxBody era) (StrictSeq (Sized (TxOut era))) +allSizedOutputsBabbageTxBodyF = + to $ \txBody -> + let txOuts = txBody ^. sizedOutputsTxBodyL + in case txBody ^. sizedCollateralReturnTxBodyL of + SNothing -> txOuts + SJust collTxOut -> txOuts |> collTxOut +{-# INLINEABLE allSizedOutputsBabbageTxBodyF #-} + +data BabbageTxBodyUpgradeError + = -- | The update attempts to update the decentralistion parameter, which is + -- dropped in Babbage. + BTBUEUpdatesD + | -- | The update attempts to update the extra entropy, which is dropped in + -- Babbage. + BTBUEUpdatesExtraEntropy + deriving (Eq, Show) + +instance Crypto c => EraTxBody (BabbageEra c) where + {-# SPECIALIZE instance EraTxBody (BabbageEra StandardCrypto) #-} + + type TxBody (BabbageEra c) = BabbageTxBody (BabbageEra c) + type TxBodyUpgradeError (BabbageEra c) = BabbageTxBodyUpgradeError + + mkBasicTxBody = mkMemoized basicBabbageTxBodyRaw + + inputsTxBodyL = inputsBabbageTxBodyL + {-# INLINE inputsTxBodyL #-} + + outputsTxBodyL = outputsBabbageTxBodyL + {-# INLINE outputsTxBodyL #-} + + feeTxBodyL = feeBabbageTxBodyL + {-# INLINE feeTxBodyL #-} + + auxDataHashTxBodyL = auxDataHashBabbageTxBodyL + {-# INLINE auxDataHashTxBodyL #-} + + spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + {-# INLINE spendableInputsTxBodyF #-} + + allInputsTxBodyF = babbageAllInputsTxBodyF + {-# INLINE allInputsTxBodyF #-} + + withdrawalsTxBodyL = withdrawalsBabbbageTxBodyL + {-# INLINE withdrawalsTxBodyL #-} + + certsTxBodyL = certsBabbageTxBodyL + {-# INLINE certsTxBodyL #-} + + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody + + upgradeTxBody txBody = do + certs <- + traverse + (left absurd . upgradeTxCert) + (txBody ^. certsTxBodyL) + updates <- traverse upgradeUpdate (txBody ^. updateTxBodyL) + pure $ + BabbageTxBody + { btbInputs = txBody ^. inputsTxBodyL + , btbOutputs = + mkSized (eraProtVerLow @(BabbageEra c)) . upgradeTxOut <$> (txBody ^. outputsTxBodyL) + , btbCerts = certs + , btbWithdrawals = txBody ^. withdrawalsTxBodyL + , btbTxFee = txBody ^. feeTxBodyL + , btbValidityInterval = txBody ^. vldtTxBodyL + , btbUpdate = updates + , btbAuxDataHash = txBody ^. auxDataHashTxBodyL + , btbMint = txBody ^. mintTxBodyL + , btbCollateral = txBody ^. collateralInputsTxBodyL + , btbReqSignerHashes = txBody ^. reqSignerHashesTxBodyL + , btbScriptIntegrityHash = txBody ^. scriptIntegrityHashTxBodyL + , btbTxNetworkId = txBody ^. networkIdTxBodyL + , btbReferenceInputs = mempty + , btbCollateralReturn = SNothing + , btbTotalCollateral = SNothing + } + where + upgradeUpdate :: + Update (AlonzoEra c) -> + Either BabbageTxBodyUpgradeError (Update (BabbageEra c)) + upgradeUpdate (Update pp epoch) = + Update <$> upgradeProposedPPUpdates pp <*> pure epoch + + -- Note that here we use 'upgradeBabbagePParams False' in order to + -- preserve 'CoinsPerUTxOWord', in spite of the value now being + -- semantically incorrect. Anything else will result in an invalid + -- transaction. + upgradeProposedPPUpdates :: + ProposedPPUpdates (AlonzoEra c) -> + Either BabbageTxBodyUpgradeError (ProposedPPUpdates (BabbageEra c)) + upgradeProposedPPUpdates (ProposedPPUpdates m) = + ProposedPPUpdates + <$> traverse + ( \(PParamsUpdate pphkd) -> do + when (isSJust $ appD pphkd) $ + Left BTBUEUpdatesD + when (isSJust $ appExtraEntropy pphkd) $ + Left BTBUEUpdatesExtraEntropy + pure . PParamsUpdate $ upgradeBabbagePParams False pphkd + ) + m + +instance Crypto c => ShelleyEraTxBody (BabbageEra c) where + {-# SPECIALIZE instance ShelleyEraTxBody (BabbageEra StandardCrypto) #-} + + ttlTxBodyL = notSupportedInThisEraL + {-# INLINE ttlTxBodyL #-} + + updateTxBodyL = updateBabbageTxBodyL + {-# INLINE updateTxBodyL #-} + +instance Crypto c => AllegraEraTxBody (BabbageEra c) where + {-# SPECIALIZE instance AllegraEraTxBody (BabbageEra StandardCrypto) #-} + + vldtTxBodyL = vldtBabbageTxBodyL + {-# INLINE vldtTxBodyL #-} + +instance Crypto c => MaryEraTxBody (BabbageEra c) where + {-# SPECIALIZE instance MaryEraTxBody (BabbageEra StandardCrypto) #-} + + mintTxBodyL = mintBabbageTxBodyL + {-# INLINE mintTxBodyL #-} + + mintValueTxBodyF = mintValueBabbageTxBodyF + {-# INLINE mintValueTxBodyF #-} + + mintedTxBodyF = mintedBabbageTxBodyF + {-# INLINE mintedTxBodyF #-} + +instance Crypto c => AlonzoEraTxBody (BabbageEra c) where + {-# SPECIALIZE instance AlonzoEraTxBody (BabbageEra StandardCrypto) #-} + + collateralInputsTxBodyL = collateralInputsBabbageTxBodyL + {-# INLINE collateralInputsTxBodyL #-} + + reqSignerHashesTxBodyL = reqSignerHashesBabbageTxBodyL + {-# INLINE reqSignerHashesTxBodyL #-} + + scriptIntegrityHashTxBodyL = scriptIntegrityHashBabbageTxBodyL + {-# INLINE scriptIntegrityHashTxBodyL #-} + + networkIdTxBodyL = networkIdBabbageTxBodyL + {-# INLINE networkIdTxBodyL #-} + + redeemerPointer = alonzoRedeemerPointer + + redeemerPointerInverse = alonzoRedeemerPointerInverse + +instance Crypto c => BabbageEraTxBody (BabbageEra c) where + {-# SPECIALIZE instance BabbageEraTxBody (BabbageEra StandardCrypto) #-} + + sizedOutputsTxBodyL = sizedOutputsBabbageTxBodyL + {-# INLINE sizedOutputsTxBodyL #-} + + referenceInputsTxBodyL = referenceInputsBabbageTxBodyL + {-# INLINE referenceInputsTxBodyL #-} + + totalCollateralTxBodyL = totalCollateralBabbageTxBodyL + {-# INLINE totalCollateralTxBodyL #-} + + collateralReturnTxBodyL = collateralReturnBabbageTxBodyL + {-# INLINE collateralReturnTxBodyL #-} + + sizedCollateralReturnTxBodyL = sizedCollateralReturnBabbageTxBodyL + {-# INLINE sizedCollateralReturnTxBodyL #-} + + allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF + {-# INLINE allSizedOutputsTxBodyF #-} + +instance + (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => + EqRaw (BabbageTxBody era) + where + eqRaw = zipMemoRawType eqRaw + +deriving newtype instance + (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => + Eq (BabbageTxBody era) + +deriving instance + (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => + NoThunks (BabbageTxBody era) + +deriving instance + (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => + Show (BabbageTxBody era) + +deriving via + (Mem BabbageTxBodyRaw era) + instance + (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => + DecCBOR (Annotator (BabbageTxBody era)) + +instance + (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => + DecCBOR (Annotator (BabbageTxBodyRaw era)) + where + decCBOR = pure <$> decCBOR + +pattern BabbageTxBody :: + BabbageEraTxBody era => + Set (TxIn (EraCrypto era)) -> + Set (TxIn (EraCrypto era)) -> + Set (TxIn (EraCrypto era)) -> + StrictSeq (Sized (TxOut era)) -> + StrictMaybe (Sized (TxOut era)) -> + StrictMaybe Coin -> + StrictSeq (TxCert era) -> + Withdrawals (EraCrypto era) -> + Coin -> + ValidityInterval -> + StrictMaybe (Update era) -> + Set (KeyHash 'Witness (EraCrypto era)) -> + MultiAsset (EraCrypto era) -> + StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -> + StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> + StrictMaybe Network -> + BabbageTxBody era +pattern BabbageTxBody + { btbInputs + , btbCollateral + , btbReferenceInputs + , btbOutputs + , btbCollateralReturn + , btbTotalCollateral + , btbCerts + , btbWithdrawals + , btbTxFee + , btbValidityInterval + , btbUpdate + , btbReqSignerHashes + , btbMint + , btbScriptIntegrityHash + , btbAuxDataHash + , btbTxNetworkId + } <- + ( getMemoRawType -> + BabbageTxBodyRaw + { btbrSpendInputs = btbInputs + , btbrCollateralInputs = btbCollateral + , btbrReferenceInputs = btbReferenceInputs + , btbrOutputs = btbOutputs + , btbrCollateralReturn = btbCollateralReturn + , btbrTotalCollateral = btbTotalCollateral + , btbrCerts = btbCerts + , btbrWithdrawals = btbWithdrawals + , btbrTxFee = btbTxFee + , btbrValidityInterval = btbValidityInterval + , btbrUpdate = btbUpdate + , btbrReqSignerHashes = btbReqSignerHashes + , btbrMint = btbMint + , btbrScriptIntegrityHash = btbScriptIntegrityHash + , btbrAuxDataHash = btbAuxDataHash + , btbrTxNetworkId = btbTxNetworkId + } + ) + where + BabbageTxBody + inputs + collateral + referenceInputs + outputs + collateralReturn + totalCollateral + certs + withdrawals + txFee + validityInterval + update + reqSignerHashes + mint + scriptIntegrityHash + auxDataHash + txNetworkId = + mkMemoized $ + BabbageTxBodyRaw + { btbrSpendInputs = inputs + , btbrCollateralInputs = collateral + , btbrReferenceInputs = referenceInputs + , btbrOutputs = outputs + , btbrCollateralReturn = collateralReturn + , btbrTotalCollateral = totalCollateral + , btbrCerts = certs + , btbrWithdrawals = withdrawals + , btbrTxFee = txFee + , btbrValidityInterval = validityInterval + , btbrUpdate = update + , btbrReqSignerHashes = reqSignerHashes + , btbrMint = mint + , btbrScriptIntegrityHash = scriptIntegrityHash + , btbrAuxDataHash = auxDataHash + , btbrTxNetworkId = txNetworkId + } + +{-# COMPLETE BabbageTxBody #-} + +instance c ~ EraCrypto era => HashAnnotated (BabbageTxBody era) EraIndependentTxBody c where + hashAnnotated = getMemoSafeHash + +-- ============================================================================== +-- We define these accessor functions manually, because if we define them using +-- the record syntax in the TxBody pattern, they inherit the (BabbageBody era) +-- constraint as a precondition. This is unnecessary, as one can see below +-- they need not be constrained at all. This should be fixed in the GHC compiler. + +spendInputs' :: BabbageTxBody era -> Set (TxIn (EraCrypto era)) +collateralInputs' :: BabbageTxBody era -> Set (TxIn (EraCrypto era)) +referenceInputs' :: BabbageTxBody era -> Set (TxIn (EraCrypto era)) +outputs' :: BabbageTxBody era -> StrictSeq (TxOut era) +collateralReturn' :: BabbageTxBody era -> StrictMaybe (TxOut era) +totalCollateral' :: BabbageTxBody era -> StrictMaybe Coin +certs' :: BabbageTxBody era -> StrictSeq (TxCert era) +txfee' :: BabbageTxBody era -> Coin +withdrawals' :: BabbageTxBody era -> Withdrawals (EraCrypto era) +vldt' :: BabbageTxBody era -> ValidityInterval +update' :: BabbageTxBody era -> StrictMaybe (Update era) +reqSignerHashes' :: BabbageTxBody era -> Set (KeyHash 'Witness (EraCrypto era)) +adHash' :: BabbageTxBody era -> StrictMaybe (AuxiliaryDataHash (EraCrypto era)) +mint' :: BabbageTxBody era -> MultiAsset (EraCrypto era) +scriptIntegrityHash' :: BabbageTxBody era -> StrictMaybe (ScriptIntegrityHash (EraCrypto era)) +spendInputs' = btbrSpendInputs . getMemoRawType + +txnetworkid' :: BabbageTxBody era -> StrictMaybe Network + +collateralInputs' = btbrCollateralInputs . getMemoRawType + +referenceInputs' = btbrReferenceInputs . getMemoRawType + +outputs' = fmap sizedValue . btbrOutputs . getMemoRawType + +collateralReturn' = fmap sizedValue . btbrCollateralReturn . getMemoRawType + +totalCollateral' = btbrTotalCollateral . getMemoRawType + +certs' = btbrCerts . getMemoRawType + +withdrawals' = btbrWithdrawals . getMemoRawType + +txfee' = btbrTxFee . getMemoRawType + +vldt' = btbrValidityInterval . getMemoRawType + +update' = btbrUpdate . getMemoRawType + +reqSignerHashes' = btbrReqSignerHashes . getMemoRawType + +adHash' = btbrAuxDataHash . getMemoRawType + +mint' = btbrMint . getMemoRawType + +scriptIntegrityHash' = btbrScriptIntegrityHash . getMemoRawType + +txnetworkid' = btbrTxNetworkId . getMemoRawType + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +-- | Encodes memoized bytes created upon construction. +instance Era era => EncCBOR (BabbageTxBody era) + +instance + (Era era, EncCBOR (TxOut era), EncCBOR (TxCert era), EncCBOR (PParamsUpdate era)) => + EncCBOR (BabbageTxBodyRaw era) + where + encCBOR + BabbageTxBodyRaw + { btbrSpendInputs + , btbrCollateralInputs + , btbrReferenceInputs + , btbrOutputs + , btbrCollateralReturn + , btbrTotalCollateral + , btbrCerts + , btbrWithdrawals + , btbrTxFee + , btbrValidityInterval = ValidityInterval bot top + , btbrUpdate + , btbrReqSignerHashes + , btbrMint + , btbrScriptIntegrityHash + , btbrAuxDataHash + , btbrTxNetworkId + } = + encode $ + Keyed + ( \i ifee ri o cr tc f t c w u b rsh mi sh ah ni -> + BabbageTxBodyRaw i ifee ri o cr tc c w f (ValidityInterval b t) u rsh mi sh ah ni + ) + !> Key 0 (To btbrSpendInputs) + !> Omit null (Key 13 (To btbrCollateralInputs)) + !> Omit null (Key 18 (To btbrReferenceInputs)) + !> Key 1 (To btbrOutputs) + !> encodeKeyedStrictMaybe 16 btbrCollateralReturn + !> encodeKeyedStrictMaybe 17 btbrTotalCollateral + !> Key 2 (To btbrTxFee) + !> encodeKeyedStrictMaybe 3 top + !> Omit null (Key 4 (To btbrCerts)) + !> Omit (null . unWithdrawals) (Key 5 (To btbrWithdrawals)) + !> encodeKeyedStrictMaybe 6 btbrUpdate + !> encodeKeyedStrictMaybe 8 bot + !> Omit null (Key 14 (To btbrReqSignerHashes)) + !> Omit (== mempty) (Key 9 (To btbrMint)) + !> encodeKeyedStrictMaybe 11 btbrScriptIntegrityHash + !> encodeKeyedStrictMaybe 7 btbrAuxDataHash + !> encodeKeyedStrictMaybe 15 btbrTxNetworkId + +instance + (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => + DecCBOR (BabbageTxBodyRaw era) + where + decCBOR = + decode $ + SparseKeyed + "BabbageTxBodyRaw" + basicBabbageTxBodyRaw + bodyFields + requiredFields + where + bodyFields :: Word -> Field (BabbageTxBodyRaw era) + bodyFields 0 = field (\x tx -> tx {btbrSpendInputs = x}) From + bodyFields 13 = field (\x tx -> tx {btbrCollateralInputs = x}) From + bodyFields 18 = field (\x tx -> tx {btbrReferenceInputs = x}) From + bodyFields 1 = field (\x tx -> tx {btbrOutputs = x}) From + bodyFields 16 = ofield (\x tx -> tx {btbrCollateralReturn = x}) From + bodyFields 17 = ofield (\x tx -> tx {btbrTotalCollateral = x}) From + bodyFields 2 = field (\x tx -> tx {btbrTxFee = x}) From + bodyFields 3 = + ofield + (\x tx -> tx {btbrValidityInterval = (btbrValidityInterval tx) {invalidHereafter = x}}) + From + bodyFields 4 = field (\x tx -> tx {btbrCerts = x}) From + bodyFields 5 = field (\x tx -> tx {btbrWithdrawals = x}) From + bodyFields 6 = ofield (\x tx -> tx {btbrUpdate = x}) From + bodyFields 7 = ofield (\x tx -> tx {btbrAuxDataHash = x}) From + bodyFields 8 = + ofield + (\x tx -> tx {btbrValidityInterval = (btbrValidityInterval tx) {invalidBefore = x}}) + From + bodyFields 9 = field (\x tx -> tx {btbrMint = x}) From + bodyFields 11 = ofield (\x tx -> tx {btbrScriptIntegrityHash = x}) From + bodyFields 14 = field (\x tx -> tx {btbrReqSignerHashes = x}) From + bodyFields 15 = ofield (\x tx -> tx {btbrTxNetworkId = x}) From + bodyFields n = field (\_ t -> t) (Invalid n) + {-# INLINE bodyFields #-} + requiredFields :: [(Word, String)] + requiredFields = + [ (0, "inputs") + , (1, "outputs") + , (2, "fee") + ] + {-# INLINE decCBOR #-} + +basicBabbageTxBodyRaw :: BabbageTxBodyRaw era +basicBabbageTxBodyRaw = + BabbageTxBodyRaw + mempty + mempty + mempty + StrictSeq.empty + SNothing + SNothing + StrictSeq.empty + (Withdrawals mempty) + mempty + (ValidityInterval SNothing SNothing) + SNothing + mempty + mempty + SNothing + SNothing + SNothing diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 37679658939..ff85b0953e7 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -35,6 +35,7 @@ library Cardano.Ledger.Conway.PParams Cardano.Ledger.Conway.Tx Cardano.Ledger.Conway.TxBody + Cardano.Ledger.Conway.TxBody.Internal Cardano.Ledger.Conway.TxInfo Cardano.Ledger.Conway.TxWits Cardano.Ledger.Conway.Transition diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs index c57a43c0468..0d35edb371d 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs @@ -1,26 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Cardano.Ledger.Conway.TxBody ( ConwayEraTxBody (..), ConwayTxBody ( @@ -50,696 +27,4 @@ module Cardano.Ledger.Conway.TxBody ( conwayProposalsDeposits, ) where -import Cardano.Ledger.Alonzo.TxAuxData (AuxiliaryDataHash (..)) -import Cardano.Ledger.Alonzo.TxBody (Indexable (..)) -import Cardano.Ledger.Babbage.Core -import Cardano.Ledger.Babbage.TxBody ( - BabbageTxBody (..), - allSizedOutputsBabbageTxBodyF, - babbageAllInputsTxBodyF, - babbageSpendableInputsTxBodyF, - ) -import Cardano.Ledger.BaseTypes (Network, fromSMaybe, isSJust) -import Cardano.Ledger.Binary ( - Annotator, - DecCBOR (..), - EncCBOR (..), - Sized (..), - ToCBOR (..), - mkSized, - ) -import Cardano.Ledger.Binary.Coders ( - Decode (..), - Density (..), - Encode (..), - Field (..), - Wrapped (..), - decode, - encode, - encodeKeyedStrictMaybe, - field, - fieldGuarded, - ofield, - (!>), - ) -import Cardano.Ledger.Coin (Coin (..), decodePositiveCoin) -import Cardano.Ledger.Conway.Era (ConwayEra) -import Cardano.Ledger.Conway.Governance.Procedures (ProposalProcedure, VotingProcedures (..)) -import Cardano.Ledger.Conway.PParams (ConwayEraPParams, ppGovActionDepositL) -import Cardano.Ledger.Conway.Scripts (ConwayEraScript, ConwayPlutusPurpose (..)) -import Cardano.Ledger.Conway.TxCert ( - ConwayEraTxCert, - ConwayTxCert (..), - ConwayTxCertUpgradeError, - ) -import Cardano.Ledger.Conway.TxOut () -import Cardano.Ledger.Crypto -import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) -import Cardano.Ledger.Mary.Value ( - MaryValue (..), - MultiAsset (..), - PolicyID, - policies, - ) -import Cardano.Ledger.MemoBytes ( - EqRaw, - Mem, - MemoBytes (..), - MemoHashIndex, - Memoized (..), - getMemoRawType, - getMemoSafeHash, - lensMemoRawType, - mkMemoized, - ) -import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) -import Cardano.Ledger.TxIn (TxIn (..)) -import Cardano.Ledger.Val (Val (..)) -import Control.Arrow (left) -import Control.DeepSeq (NFData) -import Control.Monad (unless, when) -import Data.Maybe.Strict (StrictMaybe (..)) -import qualified Data.OSet.Strict as OSet -import Data.Sequence.Strict (StrictSeq) -import Data.Set (Set) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Lens.Micro (Lens', to, (^.)) -import NoThunks.Class (NoThunks) - -instance Memoized ConwayTxBody where - type RawType ConwayTxBody = ConwayTxBodyRaw - -data ConwayTxBodyRaw era = ConwayTxBodyRaw - { ctbrSpendInputs :: !(Set (TxIn (EraCrypto era))) - , ctbrCollateralInputs :: !(Set (TxIn (EraCrypto era))) - , ctbrReferenceInputs :: !(Set (TxIn (EraCrypto era))) - , ctbrOutputs :: !(StrictSeq (Sized (TxOut era))) - , ctbrCollateralReturn :: !(StrictMaybe (Sized (TxOut era))) - , ctbrTotalCollateral :: !(StrictMaybe Coin) - , ctbrCerts :: !(OSet.OSet (ConwayTxCert era)) - , ctbrWithdrawals :: !(Withdrawals (EraCrypto era)) - , ctbrTxfee :: !Coin - , ctbrVldt :: !ValidityInterval - , ctbrReqSignerHashes :: !(Set (KeyHash 'Witness (EraCrypto era))) - , ctbrMint :: !(MultiAsset (EraCrypto era)) - , ctbrScriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) - , ctbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) - , ctbrTxNetworkId :: !(StrictMaybe Network) - , ctbrVotingProcedures :: !(VotingProcedures era) - , ctbrProposalProcedures :: !(OSet.OSet (ProposalProcedure era)) - , ctbrCurrentTreasuryValue :: !(StrictMaybe Coin) - , ctbrTreasuryDonation :: !Coin - } - deriving (Generic, Typeable) - -deriving instance (EraPParams era, Eq (TxOut era)) => Eq (ConwayTxBodyRaw era) - -instance - (EraPParams era, NoThunks (TxOut era)) => - NoThunks (ConwayTxBodyRaw era) - -instance - (EraPParams era, NFData (TxOut era)) => - NFData (ConwayTxBodyRaw era) - -deriving instance - (EraPParams era, Show (TxOut era)) => - Show (ConwayTxBodyRaw era) - -instance - ( EraPParams era - , DecCBOR (TxOut era) - , ShelleyEraTxCert era - , TxCert era ~ ConwayTxCert era - ) => - DecCBOR (ConwayTxBodyRaw era) - where - decCBOR = - decode $ - SparseKeyed - "TxBodyRaw" - basicConwayTxBodyRaw - bodyFields - requiredFields - where - bodyFields :: Word -> Field (ConwayTxBodyRaw era) - bodyFields 0 = field (\x tx -> tx {ctbrSpendInputs = x}) From - bodyFields 1 = field (\x tx -> tx {ctbrOutputs = x}) From - bodyFields 2 = field (\x tx -> tx {ctbrTxfee = x}) From - bodyFields 3 = - ofield - (\x tx -> tx {ctbrVldt = (ctbrVldt tx) {invalidHereafter = x}}) - From - bodyFields 4 = - fieldGuarded - (emptyFailure "Certificates" "non-empty") - OSet.null - (\x tx -> tx {ctbrCerts = x}) - From - bodyFields 5 = - fieldGuarded - (emptyFailure "Withdrawals" "non-empty") - (null . unWithdrawals) - (\x tx -> tx {ctbrWithdrawals = x}) - From - bodyFields 7 = ofield (\x tx -> tx {ctbrAuxDataHash = x}) From - bodyFields 8 = - ofield - (\x tx -> tx {ctbrVldt = (ctbrVldt tx) {invalidBefore = x}}) - From - bodyFields 9 = - fieldGuarded - (emptyFailure "Mint" "non-empty") - (== mempty) - (\x tx -> tx {ctbrMint = x}) - From - bodyFields 11 = ofield (\x tx -> tx {ctbrScriptIntegrityHash = x}) From - bodyFields 13 = - fieldGuarded - (emptyFailure "Collateral Inputs" "non-empty") - null - (\x tx -> tx {ctbrCollateralInputs = x}) - From - bodyFields 14 = - fieldGuarded - (emptyFailure "Required Signer Hashes" "non-empty") - null - (\x tx -> tx {ctbrReqSignerHashes = x}) - From - bodyFields 15 = ofield (\x tx -> tx {ctbrTxNetworkId = x}) From - bodyFields 16 = ofield (\x tx -> tx {ctbrCollateralReturn = x}) From - bodyFields 17 = ofield (\x tx -> tx {ctbrTotalCollateral = x}) From - bodyFields 18 = - fieldGuarded - (emptyFailure "Reference Inputs" "non-empty") - null - (\x tx -> tx {ctbrReferenceInputs = x}) - From - bodyFields 19 = - fieldGuarded - (emptyFailure "VotingProcedures" "non-empty") - (null . unVotingProcedures) - (\x tx -> tx {ctbrVotingProcedures = x}) - From - bodyFields 20 = - fieldGuarded - (emptyFailure "ProposalProcedures" "non-empty") - OSet.null - (\x tx -> tx {ctbrProposalProcedures = x}) - From - bodyFields 21 = ofield (\x tx -> tx {ctbrCurrentTreasuryValue = x}) From - bodyFields 22 = - ofield - (\x tx -> tx {ctbrTreasuryDonation = fromSMaybe zero x}) - (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero")) - bodyFields n = field (\_ t -> t) (Invalid n) - requiredFields :: [(Word, String)] - requiredFields = - [ (0, "inputs") - , (1, "outputs") - , (2, "fee") - ] - emptyFailure fieldName requirement = - "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied" - -newtype ConwayTxBody era = TxBodyConstr (MemoBytes ConwayTxBodyRaw era) - deriving (Generic, SafeToHash, ToCBOR) - -deriving instance - (EraPParams era, NoThunks (TxOut era)) => - NoThunks (ConwayTxBody era) - -deriving instance - (EraPParams era, Eq (TxOut era)) => - Eq (ConwayTxBody era) - -deriving newtype instance - (EraPParams era, NFData (TxOut era)) => - NFData (ConwayTxBody era) - -deriving instance - (EraPParams era, Show (TxOut era)) => - Show (ConwayTxBody era) - -type instance MemoHashIndex ConwayTxBodyRaw = EraIndependentTxBody - -instance c ~ EraCrypto era => HashAnnotated (ConwayTxBody era) EraIndependentTxBody c where - hashAnnotated = getMemoSafeHash - -instance - ( DecCBOR (TxOut era) - , EraPParams era - , ShelleyEraTxCert era - , TxCert era ~ ConwayTxCert era - ) => - DecCBOR (Annotator (ConwayTxBodyRaw era)) - where - decCBOR = pure <$> decCBOR - -deriving via - (Mem ConwayTxBodyRaw era) - instance - ( DecCBOR (TxOut era) - , EraPParams era - , ShelleyEraTxCert era - , TxCert era ~ ConwayTxCert era - ) => - DecCBOR (Annotator (ConwayTxBody era)) - -mkConwayTxBody :: ConwayEraTxBody era => ConwayTxBody era -mkConwayTxBody = mkMemoized basicConwayTxBodyRaw - -basicConwayTxBodyRaw :: ConwayTxBodyRaw era -basicConwayTxBodyRaw = - ConwayTxBodyRaw - mempty - mempty - mempty - mempty - SNothing - SNothing - OSet.empty - (Withdrawals mempty) - mempty - (ValidityInterval SNothing SNothing) - mempty - mempty - SNothing - SNothing - SNothing - (VotingProcedures mempty) - OSet.empty - SNothing - mempty - -data ConwayTxBodyUpgradeError c - = CTBUETxCert ConwayTxCertUpgradeError - | -- | The TxBody contains an update proposal from a pre-Conway era. Since - -- this can only have come from the genesis delegates, we just discard it. - CTBUEContainsUpdate - | -- | In eras prior to Conway duplicate certificates where allowed - CTBUEContainsDuplicateCerts (Set (TxCert (ConwayEra c))) - deriving (Eq, Show) - -instance Crypto c => EraTxBody (ConwayEra c) where - {-# SPECIALIZE instance EraTxBody (ConwayEra StandardCrypto) #-} - - type TxBody (ConwayEra c) = ConwayTxBody (ConwayEra c) - type TxBodyUpgradeError (ConwayEra c) = ConwayTxBodyUpgradeError c - - mkBasicTxBody = mkConwayTxBody - - inputsTxBodyL = lensMemoRawType ctbrSpendInputs (\txb x -> txb {ctbrSpendInputs = x}) - {-# INLINE inputsTxBodyL #-} - - outputsTxBodyL = - lensMemoRawType - (fmap sizedValue . ctbrOutputs) - (\txb x -> txb {ctbrOutputs = mkSized (eraProtVerLow @(ConwayEra c)) <$> x}) - {-# INLINE outputsTxBodyL #-} - - feeTxBodyL = lensMemoRawType ctbrTxfee (\txb x -> txb {ctbrTxfee = x}) - {-# INLINE feeTxBodyL #-} - - auxDataHashTxBodyL = lensMemoRawType ctbrAuxDataHash (\txb x -> txb {ctbrAuxDataHash = x}) - {-# INLINE auxDataHashTxBodyL #-} - - spendableInputsTxBodyF = babbageSpendableInputsTxBodyF - {-# INLINE spendableInputsTxBodyF #-} - - allInputsTxBodyF = babbageAllInputsTxBodyF - {-# INLINE allInputsTxBodyF #-} - - withdrawalsTxBodyL = lensMemoRawType ctbrWithdrawals (\txb x -> txb {ctbrWithdrawals = x}) - {-# INLINE withdrawalsTxBodyL #-} - - certsTxBodyL = - lensMemoRawType (OSet.toStrictSeq . ctbrCerts) (\txb x -> txb {ctbrCerts = OSet.fromStrictSeq x}) - {-# INLINE certsTxBodyL #-} - - getTotalDepositsTxBody = conwayTotalDepositsTxBody - - getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = - getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) - - upgradeTxBody btb = do - when (isSJust (btbUpdate btb)) $ Left CTBUEContainsUpdate - certs <- traverse (left CTBUETxCert . upgradeTxCert) (btbCerts btb) - let (duplicates, certsOSet) = OSet.fromStrictSeqDuplicates certs - unless (null duplicates) $ Left $ CTBUEContainsDuplicateCerts duplicates - pure $ - ConwayTxBody - { ctbSpendInputs = btbInputs btb - , ctbOutputs = - mkSized (eraProtVerLow @(ConwayEra c)) - . upgradeTxOut - . sizedValue - <$> btbOutputs btb - , ctbCerts = certsOSet - , ctbWithdrawals = btbWithdrawals btb - , ctbTxfee = btbTxFee btb - , ctbVldt = btbValidityInterval btb - , ctbAdHash = btbAuxDataHash btb - , ctbMint = btbMint btb - , ctbCollateralInputs = btbCollateral btb - , ctbReqSignerHashes = btbReqSignerHashes btb - , ctbScriptIntegrityHash = btbScriptIntegrityHash btb - , ctbTxNetworkId = btbTxNetworkId btb - , ctbReferenceInputs = btbReferenceInputs btb - , ctbCollateralReturn = - mkSized (eraProtVerLow @(ConwayEra c)) - . upgradeTxOut - . sizedValue - <$> btbCollateralReturn btb - , ctbTotalCollateral = btbTotalCollateral btb - , ctbCurrentTreasuryValue = SNothing - , ctbProposalProcedures = OSet.empty - , ctbVotingProcedures = VotingProcedures mempty - , ctbTreasuryDonation = Coin 0 - } - --- ========================================== --- Deposits and Refunds for Conway TxBody - --- | Compute all the deposits in a TxBody. This includes deposits for: --- --- 1. registering Stake --- 2. registering a StakePool --- 3. registering a DRep --- 4. submitting a Proposal --- --- This is the contribution of a TxBody towards the total --- `Cardano.Ledger.CertState.Obligations` -conwayTotalDepositsTxBody :: - ConwayEraTxBody era => - PParams era -> - (KeyHash 'StakePool (EraCrypto era) -> Bool) -> - TxBody era -> - Coin -conwayTotalDepositsTxBody pp isPoolRegisted txBody = - getTotalDepositsTxCerts pp isPoolRegisted (txBody ^. certsTxBodyL) - <+> conwayProposalsDeposits pp txBody - --- | Total number of deposits in the proposals in TxBody -conwayProposalsDeposits :: - ConwayEraTxBody era => - PParams era -> - TxBody era -> - Coin -conwayProposalsDeposits pp txBody = numProposals <×> depositPerProposal - where - numProposals = length (txBody ^. proposalProceduresTxBodyL) - depositPerProposal = pp ^. ppGovActionDepositL - -instance Crypto c => AllegraEraTxBody (ConwayEra c) where - {-# SPECIALIZE instance AllegraEraTxBody (ConwayEra StandardCrypto) #-} - - vldtTxBodyL = lensMemoRawType ctbrVldt (\txb x -> txb {ctbrVldt = x}) - {-# INLINE vldtTxBodyL #-} - -instance Crypto c => MaryEraTxBody (ConwayEra c) where - {-# SPECIALIZE instance MaryEraTxBody (ConwayEra StandardCrypto) #-} - - mintTxBodyL = lensMemoRawType ctbrMint (\txb x -> txb {ctbrMint = x}) - {-# INLINE mintTxBodyL #-} - - mintValueTxBodyF = mintTxBodyL . to (MaryValue mempty) - - mintedTxBodyF = - to (\(TxBodyConstr (Memo txBodyRaw _)) -> policies (ctbrMint txBodyRaw)) - {-# INLINE mintedTxBodyF #-} - -instance Crypto c => AlonzoEraTxBody (ConwayEra c) where - {-# SPECIALIZE instance AlonzoEraTxBody (ConwayEra StandardCrypto) #-} - - collateralInputsTxBodyL = - lensMemoRawType ctbrCollateralInputs (\txb x -> txb {ctbrCollateralInputs = x}) - {-# INLINE collateralInputsTxBodyL #-} - - reqSignerHashesTxBodyL = - lensMemoRawType ctbrReqSignerHashes (\txb x -> txb {ctbrReqSignerHashes = x}) - {-# INLINE reqSignerHashesTxBodyL #-} - - scriptIntegrityHashTxBodyL = - lensMemoRawType ctbrScriptIntegrityHash (\txb x -> txb {ctbrScriptIntegrityHash = x}) - {-# INLINE scriptIntegrityHashTxBodyL #-} - - networkIdTxBodyL = lensMemoRawType ctbrTxNetworkId (\txb x -> txb {ctbrTxNetworkId = x}) - {-# INLINE networkIdTxBodyL #-} - - redeemerPointer = conwayRedeemerPointer - - redeemerPointerInverse = conwayRedeemerPointerInverse - -instance Crypto c => BabbageEraTxBody (ConwayEra c) where - {-# SPECIALIZE instance BabbageEraTxBody (ConwayEra StandardCrypto) #-} - - sizedOutputsTxBodyL = lensMemoRawType ctbrOutputs (\txb x -> txb {ctbrOutputs = x}) - {-# INLINE sizedOutputsTxBodyL #-} - - referenceInputsTxBodyL = - lensMemoRawType ctbrReferenceInputs (\txb x -> txb {ctbrReferenceInputs = x}) - {-# INLINE referenceInputsTxBodyL #-} - - totalCollateralTxBodyL = - lensMemoRawType ctbrTotalCollateral (\txb x -> txb {ctbrTotalCollateral = x}) - {-# INLINE totalCollateralTxBodyL #-} - - collateralReturnTxBodyL = - lensMemoRawType - (fmap sizedValue . ctbrCollateralReturn) - (\txb x -> txb {ctbrCollateralReturn = mkSized (eraProtVerLow @(ConwayEra c)) <$> x}) - {-# INLINE collateralReturnTxBodyL #-} - - sizedCollateralReturnTxBodyL = - lensMemoRawType ctbrCollateralReturn (\txb x -> txb {ctbrCollateralReturn = x}) - {-# INLINE sizedCollateralReturnTxBodyL #-} - - allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF - {-# INLINE allSizedOutputsTxBodyF #-} - -instance Crypto c => ConwayEraTxBody (ConwayEra c) where - votingProceduresTxBodyL = - lensMemoRawType ctbrVotingProcedures (\txb x -> txb {ctbrVotingProcedures = x}) - {-# INLINE votingProceduresTxBodyL #-} - proposalProceduresTxBodyL = - lensMemoRawType ctbrProposalProcedures (\txb x -> txb {ctbrProposalProcedures = x}) - {-# INLINE proposalProceduresTxBodyL #-} - currentTreasuryValueTxBodyL = - lensMemoRawType ctbrCurrentTreasuryValue (\txb x -> txb {ctbrCurrentTreasuryValue = x}) - {-# INLINE currentTreasuryValueTxBodyL #-} - treasuryDonationTxBodyL = - lensMemoRawType ctbrTreasuryDonation (\txb x -> txb {ctbrTreasuryDonation = x}) - {-# INLINE treasuryDonationTxBodyL #-} - -instance - (EraPParams era, Eq (TxOut era), Eq (TxCert era)) => - EqRaw (ConwayTxBody era) - -pattern ConwayTxBody :: - ConwayEraTxBody era => - Set (TxIn (EraCrypto era)) -> - Set (TxIn (EraCrypto era)) -> - Set (TxIn (EraCrypto era)) -> - StrictSeq (Sized (TxOut era)) -> - StrictMaybe (Sized (TxOut era)) -> - StrictMaybe Coin -> - OSet.OSet (ConwayTxCert era) -> - Withdrawals (EraCrypto era) -> - Coin -> - ValidityInterval -> - Set (KeyHash 'Witness (EraCrypto era)) -> - MultiAsset (EraCrypto era) -> - StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -> - StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> - StrictMaybe Network -> - VotingProcedures era -> - OSet.OSet (ProposalProcedure era) -> - StrictMaybe Coin -> - Coin -> - ConwayTxBody era -pattern ConwayTxBody - { ctbSpendInputs - , ctbCollateralInputs - , ctbReferenceInputs - , ctbOutputs - , ctbCollateralReturn - , ctbTotalCollateral - , ctbCerts - , ctbWithdrawals - , ctbTxfee - , ctbVldt - , ctbReqSignerHashes - , ctbMint - , ctbScriptIntegrityHash - , ctbAdHash - , ctbTxNetworkId - , ctbVotingProcedures - , ctbProposalProcedures - , ctbCurrentTreasuryValue - , ctbTreasuryDonation - } <- - ( getMemoRawType -> - ConwayTxBodyRaw - { ctbrSpendInputs = ctbSpendInputs - , ctbrCollateralInputs = ctbCollateralInputs - , ctbrReferenceInputs = ctbReferenceInputs - , ctbrOutputs = ctbOutputs - , ctbrCollateralReturn = ctbCollateralReturn - , ctbrTotalCollateral = ctbTotalCollateral - , ctbrCerts = ctbCerts - , ctbrWithdrawals = ctbWithdrawals - , ctbrTxfee = ctbTxfee - , ctbrVldt = ctbVldt - , ctbrReqSignerHashes = ctbReqSignerHashes - , ctbrMint = ctbMint - , ctbrScriptIntegrityHash = ctbScriptIntegrityHash - , ctbrAuxDataHash = ctbAdHash - , ctbrTxNetworkId = ctbTxNetworkId - , ctbrVotingProcedures = ctbVotingProcedures - , ctbrProposalProcedures = ctbProposalProcedures - , ctbrCurrentTreasuryValue = ctbCurrentTreasuryValue - , ctbrTreasuryDonation = ctbTreasuryDonation - } - ) - where - ConwayTxBody - inputsX - collateralX - referenceInputsX - outputsX - collateralReturnX - totalCollateralX - certsX - withdrawalsX - txfeeX - vldtX - reqSignerHashesX - mintX - scriptIntegrityHashX - adHashX - txnetworkidX - votingProcedures - proposalProcedures - currentTreasuryValue - treasuryDonation = - mkMemoized $ - ConwayTxBodyRaw - inputsX - collateralX - referenceInputsX - outputsX - collateralReturnX - totalCollateralX - certsX - withdrawalsX - txfeeX - vldtX - reqSignerHashesX - mintX - scriptIntegrityHashX - adHashX - txnetworkidX - votingProcedures - proposalProcedures - currentTreasuryValue - treasuryDonation - -{-# COMPLETE ConwayTxBody #-} - --------------------------------------------------------------------------------- --- Serialisation --------------------------------------------------------------------------------- - -encodeTxBodyRaw :: - ConwayEraTxBody era => - ConwayTxBodyRaw era -> - Encode ('Closed 'Sparse) (ConwayTxBodyRaw era) -encodeTxBodyRaw ConwayTxBodyRaw {..} = - let ValidityInterval bot top = ctbrVldt - in Keyed - ( \i ci ri o cr tc f t c w b -> - ConwayTxBodyRaw i ci ri o cr tc c w f (ValidityInterval b t) - ) - !> Key 0 (To ctbrSpendInputs) - !> Omit null (Key 13 (To ctbrCollateralInputs)) - !> Omit null (Key 18 (To ctbrReferenceInputs)) - !> Key 1 (To ctbrOutputs) - !> encodeKeyedStrictMaybe 16 ctbrCollateralReturn - !> encodeKeyedStrictMaybe 17 ctbrTotalCollateral - !> Key 2 (To ctbrTxfee) - !> encodeKeyedStrictMaybe 3 top - !> Omit OSet.null (Key 4 (To ctbrCerts)) - !> Omit (null . unWithdrawals) (Key 5 (To ctbrWithdrawals)) - !> encodeKeyedStrictMaybe 8 bot - !> Omit null (Key 14 (To ctbrReqSignerHashes)) - !> Omit (== mempty) (Key 9 (To ctbrMint)) - !> encodeKeyedStrictMaybe 11 ctbrScriptIntegrityHash - !> encodeKeyedStrictMaybe 7 ctbrAuxDataHash - !> encodeKeyedStrictMaybe 15 ctbrTxNetworkId - !> Omit (null . unVotingProcedures) (Key 19 (To ctbrVotingProcedures)) - !> Omit OSet.null (Key 20 (To ctbrProposalProcedures)) - !> encodeKeyedStrictMaybe 21 ctbrCurrentTreasuryValue - !> Omit (== mempty) (Key 22 $ To ctbrTreasuryDonation) - -instance ConwayEraTxBody era => EncCBOR (ConwayTxBodyRaw era) where - encCBOR = encode . encodeTxBodyRaw - --- | Encodes memoized bytes created upon construction. -instance Era era => EncCBOR (ConwayTxBody era) - -class - (BabbageEraTxBody era, ConwayEraTxCert era, ConwayEraPParams era, ConwayEraScript era) => - ConwayEraTxBody era - where - -- | Lens for getting and setting number of `Coin` that is expected to be in the - -- Treasury at the current Epoch - currentTreasuryValueTxBodyL :: Lens' (TxBody era) (StrictMaybe Coin) - - -- | Lens for getting and setting `VotingProcedures`. - votingProceduresTxBodyL :: Lens' (TxBody era) (VotingProcedures era) - - -- | Lens for getting and setting `ProposalProcedures`. - proposalProceduresTxBodyL :: Lens' (TxBody era) (OSet.OSet (ProposalProcedure era)) - - treasuryDonationTxBodyL :: Lens' (TxBody era) Coin - -conwayRedeemerPointer :: - forall era. - ConwayEraTxBody era => - TxBody era -> - ConwayPlutusPurpose AsItem era -> - StrictMaybe (ConwayPlutusPurpose AsIx era) -conwayRedeemerPointer txBody = \case - ConwayMinting policyID -> - ConwayMinting <$> indexOf policyID (txBody ^. mintedTxBodyF :: Set (PolicyID (EraCrypto era))) - ConwaySpending txIn -> - ConwaySpending <$> indexOf txIn (txBody ^. inputsTxBodyL) - ConwayRewarding rewardAccount -> - ConwayRewarding <$> indexOf rewardAccount (unWithdrawals (txBody ^. withdrawalsTxBodyL)) - ConwayCertifying txCert -> - ConwayCertifying <$> indexOf txCert (txBody ^. certsTxBodyL) - ConwayVoting votingProcedure -> - ConwayVoting <$> indexOf votingProcedure (txBody ^. votingProceduresTxBodyL) - ConwayProposing proposalProcedure -> - ConwayProposing <$> indexOf proposalProcedure (txBody ^. proposalProceduresTxBodyL) - -conwayRedeemerPointerInverse :: - ConwayEraTxBody era => - TxBody era -> - ConwayPlutusPurpose AsIx era -> - StrictMaybe (ConwayPlutusPurpose AsIxItem era) -conwayRedeemerPointerInverse txBody = \case - ConwayMinting idx -> - ConwayMinting <$> fromIndex idx (txBody ^. mintedTxBodyF) - ConwaySpending idx -> - ConwaySpending <$> fromIndex idx (txBody ^. inputsTxBodyL) - ConwayRewarding idx -> - ConwayRewarding <$> fromIndex idx (unWithdrawals (txBody ^. withdrawalsTxBodyL)) - ConwayCertifying idx -> - ConwayCertifying <$> fromIndex idx (txBody ^. certsTxBodyL) - ConwayVoting idx -> - ConwayVoting <$> fromIndex idx (txBody ^. votingProceduresTxBodyL) - ConwayProposing idx -> - ConwayProposing <$> fromIndex idx (txBody ^. proposalProceduresTxBodyL) +import Cardano.Ledger.Conway.TxBody.Internal diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs new file mode 100644 index 00000000000..1dcf1b6e925 --- /dev/null +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs @@ -0,0 +1,755 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Provides Conway TxBody internals +-- +-- = Warning +-- +-- This module is considered __internal__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +module Cardano.Ledger.Conway.TxBody.Internal ( + ConwayEraTxBody (..), + ConwayTxBody ( + .., + ConwayTxBody, + ctbSpendInputs, + ctbCollateralInputs, + ctbReferenceInputs, + ctbOutputs, + ctbCollateralReturn, + ctbTotalCollateral, + ctbCerts, + ctbWithdrawals, + ctbTxfee, + ctbVldt, + ctbReqSignerHashes, + ctbMint, + ctbScriptIntegrityHash, + ctbAdHash, + ctbTxNetworkId, + ctbVotingProcedures, + ctbProposalProcedures, + ctbCurrentTreasuryValue, + ctbTreasuryDonation + ), + ConwayTxBodyRaw (..), + conwayTotalDepositsTxBody, + conwayProposalsDeposits, +) where + +import Cardano.Ledger.Alonzo.TxAuxData (AuxiliaryDataHash (..)) +import Cardano.Ledger.Alonzo.TxBody (Indexable (..)) +import Cardano.Ledger.Babbage.Core +import Cardano.Ledger.Babbage.TxBody ( + BabbageTxBody (..), + allSizedOutputsBabbageTxBodyF, + babbageAllInputsTxBodyF, + babbageSpendableInputsTxBodyF, + ) +import Cardano.Ledger.BaseTypes (Network, fromSMaybe, isSJust) +import Cardano.Ledger.Binary ( + Annotator, + DecCBOR (..), + EncCBOR (..), + Sized (..), + ToCBOR (..), + mkSized, + ) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Density (..), + Encode (..), + Field (..), + Wrapped (..), + decode, + encode, + encodeKeyedStrictMaybe, + field, + fieldGuarded, + ofield, + (!>), + ) +import Cardano.Ledger.Coin (Coin (..), decodePositiveCoin) +import Cardano.Ledger.Conway.Era (ConwayEra) +import Cardano.Ledger.Conway.Governance.Procedures (ProposalProcedure, VotingProcedures (..)) +import Cardano.Ledger.Conway.PParams (ConwayEraPParams, ppGovActionDepositL) +import Cardano.Ledger.Conway.Scripts (ConwayEraScript, ConwayPlutusPurpose (..)) +import Cardano.Ledger.Conway.TxCert ( + ConwayEraTxCert, + ConwayTxCert (..), + ConwayTxCertUpgradeError, + ) +import Cardano.Ledger.Conway.TxOut () +import Cardano.Ledger.Crypto +import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) +import Cardano.Ledger.Mary.Value ( + MaryValue (..), + MultiAsset (..), + PolicyID, + policies, + ) +import Cardano.Ledger.MemoBytes ( + EqRaw, + Mem, + MemoBytes (..), + MemoHashIndex, + Memoized (..), + getMemoRawType, + getMemoSafeHash, + lensMemoRawType, + mkMemoized, + ) +import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) +import Cardano.Ledger.TxIn (TxIn (..)) +import Cardano.Ledger.Val (Val (..)) +import Control.Arrow (left) +import Control.DeepSeq (NFData) +import Control.Monad (unless, when) +import Data.Maybe.Strict (StrictMaybe (..)) +import qualified Data.OSet.Strict as OSet +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Lens.Micro (Lens', to, (^.)) +import NoThunks.Class (NoThunks) + +instance Memoized ConwayTxBody where + type RawType ConwayTxBody = ConwayTxBodyRaw + +data ConwayTxBodyRaw era = ConwayTxBodyRaw + { ctbrSpendInputs :: !(Set (TxIn (EraCrypto era))) + , ctbrCollateralInputs :: !(Set (TxIn (EraCrypto era))) + , ctbrReferenceInputs :: !(Set (TxIn (EraCrypto era))) + , ctbrOutputs :: !(StrictSeq (Sized (TxOut era))) + , ctbrCollateralReturn :: !(StrictMaybe (Sized (TxOut era))) + , ctbrTotalCollateral :: !(StrictMaybe Coin) + , ctbrCerts :: !(OSet.OSet (ConwayTxCert era)) + , ctbrWithdrawals :: !(Withdrawals (EraCrypto era)) + , ctbrTxfee :: !Coin + , ctbrVldt :: !ValidityInterval + , ctbrReqSignerHashes :: !(Set (KeyHash 'Witness (EraCrypto era))) + , ctbrMint :: !(MultiAsset (EraCrypto era)) + , ctbrScriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) + , ctbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) + , ctbrTxNetworkId :: !(StrictMaybe Network) + , ctbrVotingProcedures :: !(VotingProcedures era) + , ctbrProposalProcedures :: !(OSet.OSet (ProposalProcedure era)) + , ctbrCurrentTreasuryValue :: !(StrictMaybe Coin) + , ctbrTreasuryDonation :: !Coin + } + deriving (Generic, Typeable) + +deriving instance (EraPParams era, Eq (TxOut era)) => Eq (ConwayTxBodyRaw era) + +instance + (EraPParams era, NoThunks (TxOut era)) => + NoThunks (ConwayTxBodyRaw era) + +instance + (EraPParams era, NFData (TxOut era)) => + NFData (ConwayTxBodyRaw era) + +deriving instance + (EraPParams era, Show (TxOut era)) => + Show (ConwayTxBodyRaw era) + +instance + ( EraPParams era + , DecCBOR (TxOut era) + , ShelleyEraTxCert era + , TxCert era ~ ConwayTxCert era + ) => + DecCBOR (ConwayTxBodyRaw era) + where + decCBOR = + decode $ + SparseKeyed + "TxBodyRaw" + basicConwayTxBodyRaw + bodyFields + requiredFields + where + bodyFields :: Word -> Field (ConwayTxBodyRaw era) + bodyFields 0 = field (\x tx -> tx {ctbrSpendInputs = x}) From + bodyFields 1 = field (\x tx -> tx {ctbrOutputs = x}) From + bodyFields 2 = field (\x tx -> tx {ctbrTxfee = x}) From + bodyFields 3 = + ofield + (\x tx -> tx {ctbrVldt = (ctbrVldt tx) {invalidHereafter = x}}) + From + bodyFields 4 = + fieldGuarded + (emptyFailure "Certificates" "non-empty") + OSet.null + (\x tx -> tx {ctbrCerts = x}) + From + bodyFields 5 = + fieldGuarded + (emptyFailure "Withdrawals" "non-empty") + (null . unWithdrawals) + (\x tx -> tx {ctbrWithdrawals = x}) + From + bodyFields 7 = ofield (\x tx -> tx {ctbrAuxDataHash = x}) From + bodyFields 8 = + ofield + (\x tx -> tx {ctbrVldt = (ctbrVldt tx) {invalidBefore = x}}) + From + bodyFields 9 = + fieldGuarded + (emptyFailure "Mint" "non-empty") + (== mempty) + (\x tx -> tx {ctbrMint = x}) + From + bodyFields 11 = ofield (\x tx -> tx {ctbrScriptIntegrityHash = x}) From + bodyFields 13 = + fieldGuarded + (emptyFailure "Collateral Inputs" "non-empty") + null + (\x tx -> tx {ctbrCollateralInputs = x}) + From + bodyFields 14 = + fieldGuarded + (emptyFailure "Required Signer Hashes" "non-empty") + null + (\x tx -> tx {ctbrReqSignerHashes = x}) + From + bodyFields 15 = ofield (\x tx -> tx {ctbrTxNetworkId = x}) From + bodyFields 16 = ofield (\x tx -> tx {ctbrCollateralReturn = x}) From + bodyFields 17 = ofield (\x tx -> tx {ctbrTotalCollateral = x}) From + bodyFields 18 = + fieldGuarded + (emptyFailure "Reference Inputs" "non-empty") + null + (\x tx -> tx {ctbrReferenceInputs = x}) + From + bodyFields 19 = + fieldGuarded + (emptyFailure "VotingProcedures" "non-empty") + (null . unVotingProcedures) + (\x tx -> tx {ctbrVotingProcedures = x}) + From + bodyFields 20 = + fieldGuarded + (emptyFailure "ProposalProcedures" "non-empty") + OSet.null + (\x tx -> tx {ctbrProposalProcedures = x}) + From + bodyFields 21 = ofield (\x tx -> tx {ctbrCurrentTreasuryValue = x}) From + bodyFields 22 = + ofield + (\x tx -> tx {ctbrTreasuryDonation = fromSMaybe zero x}) + (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero")) + bodyFields n = field (\_ t -> t) (Invalid n) + requiredFields :: [(Word, String)] + requiredFields = + [ (0, "inputs") + , (1, "outputs") + , (2, "fee") + ] + emptyFailure fieldName requirement = + "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied" + +newtype ConwayTxBody era = TxBodyConstr (MemoBytes ConwayTxBodyRaw era) + deriving (Generic, SafeToHash, ToCBOR) + +deriving instance + (EraPParams era, NoThunks (TxOut era)) => + NoThunks (ConwayTxBody era) + +deriving instance + (EraPParams era, Eq (TxOut era)) => + Eq (ConwayTxBody era) + +deriving newtype instance + (EraPParams era, NFData (TxOut era)) => + NFData (ConwayTxBody era) + +deriving instance + (EraPParams era, Show (TxOut era)) => + Show (ConwayTxBody era) + +type instance MemoHashIndex ConwayTxBodyRaw = EraIndependentTxBody + +instance c ~ EraCrypto era => HashAnnotated (ConwayTxBody era) EraIndependentTxBody c where + hashAnnotated = getMemoSafeHash + +instance + ( DecCBOR (TxOut era) + , EraPParams era + , ShelleyEraTxCert era + , TxCert era ~ ConwayTxCert era + ) => + DecCBOR (Annotator (ConwayTxBodyRaw era)) + where + decCBOR = pure <$> decCBOR + +deriving via + (Mem ConwayTxBodyRaw era) + instance + ( DecCBOR (TxOut era) + , EraPParams era + , ShelleyEraTxCert era + , TxCert era ~ ConwayTxCert era + ) => + DecCBOR (Annotator (ConwayTxBody era)) + +mkConwayTxBody :: ConwayEraTxBody era => ConwayTxBody era +mkConwayTxBody = mkMemoized basicConwayTxBodyRaw + +basicConwayTxBodyRaw :: ConwayTxBodyRaw era +basicConwayTxBodyRaw = + ConwayTxBodyRaw + mempty + mempty + mempty + mempty + SNothing + SNothing + OSet.empty + (Withdrawals mempty) + mempty + (ValidityInterval SNothing SNothing) + mempty + mempty + SNothing + SNothing + SNothing + (VotingProcedures mempty) + OSet.empty + SNothing + mempty + +data ConwayTxBodyUpgradeError c + = CTBUETxCert ConwayTxCertUpgradeError + | -- | The TxBody contains an update proposal from a pre-Conway era. Since + -- this can only have come from the genesis delegates, we just discard it. + CTBUEContainsUpdate + | -- | In eras prior to Conway duplicate certificates where allowed + CTBUEContainsDuplicateCerts (Set (TxCert (ConwayEra c))) + deriving (Eq, Show) + +instance Crypto c => EraTxBody (ConwayEra c) where + {-# SPECIALIZE instance EraTxBody (ConwayEra StandardCrypto) #-} + + type TxBody (ConwayEra c) = ConwayTxBody (ConwayEra c) + type TxBodyUpgradeError (ConwayEra c) = ConwayTxBodyUpgradeError c + + mkBasicTxBody = mkConwayTxBody + + inputsTxBodyL = lensMemoRawType ctbrSpendInputs (\txb x -> txb {ctbrSpendInputs = x}) + {-# INLINE inputsTxBodyL #-} + + outputsTxBodyL = + lensMemoRawType + (fmap sizedValue . ctbrOutputs) + (\txb x -> txb {ctbrOutputs = mkSized (eraProtVerLow @(ConwayEra c)) <$> x}) + {-# INLINE outputsTxBodyL #-} + + feeTxBodyL = lensMemoRawType ctbrTxfee (\txb x -> txb {ctbrTxfee = x}) + {-# INLINE feeTxBodyL #-} + + auxDataHashTxBodyL = lensMemoRawType ctbrAuxDataHash (\txb x -> txb {ctbrAuxDataHash = x}) + {-# INLINE auxDataHashTxBodyL #-} + + spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + {-# INLINE spendableInputsTxBodyF #-} + + allInputsTxBodyF = babbageAllInputsTxBodyF + {-# INLINE allInputsTxBodyF #-} + + withdrawalsTxBodyL = lensMemoRawType ctbrWithdrawals (\txb x -> txb {ctbrWithdrawals = x}) + {-# INLINE withdrawalsTxBodyL #-} + + certsTxBodyL = + lensMemoRawType (OSet.toStrictSeq . ctbrCerts) (\txb x -> txb {ctbrCerts = OSet.fromStrictSeq x}) + {-# INLINE certsTxBodyL #-} + + getTotalDepositsTxBody = conwayTotalDepositsTxBody + + getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = + getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) + + upgradeTxBody btb = do + when (isSJust (btbUpdate btb)) $ Left CTBUEContainsUpdate + certs <- traverse (left CTBUETxCert . upgradeTxCert) (btbCerts btb) + let (duplicates, certsOSet) = OSet.fromStrictSeqDuplicates certs + unless (null duplicates) $ Left $ CTBUEContainsDuplicateCerts duplicates + pure $ + ConwayTxBody + { ctbSpendInputs = btbInputs btb + , ctbOutputs = + mkSized (eraProtVerLow @(ConwayEra c)) + . upgradeTxOut + . sizedValue + <$> btbOutputs btb + , ctbCerts = certsOSet + , ctbWithdrawals = btbWithdrawals btb + , ctbTxfee = btbTxFee btb + , ctbVldt = btbValidityInterval btb + , ctbAdHash = btbAuxDataHash btb + , ctbMint = btbMint btb + , ctbCollateralInputs = btbCollateral btb + , ctbReqSignerHashes = btbReqSignerHashes btb + , ctbScriptIntegrityHash = btbScriptIntegrityHash btb + , ctbTxNetworkId = btbTxNetworkId btb + , ctbReferenceInputs = btbReferenceInputs btb + , ctbCollateralReturn = + mkSized (eraProtVerLow @(ConwayEra c)) + . upgradeTxOut + . sizedValue + <$> btbCollateralReturn btb + , ctbTotalCollateral = btbTotalCollateral btb + , ctbCurrentTreasuryValue = SNothing + , ctbProposalProcedures = OSet.empty + , ctbVotingProcedures = VotingProcedures mempty + , ctbTreasuryDonation = Coin 0 + } + +-- ========================================== +-- Deposits and Refunds for Conway TxBody + +-- | Compute all the deposits in a TxBody. This includes deposits for: +-- +-- 1. registering Stake +-- 2. registering a StakePool +-- 3. registering a DRep +-- 4. submitting a Proposal +-- +-- This is the contribution of a TxBody towards the total +-- `Cardano.Ledger.CertState.Obligations` +conwayTotalDepositsTxBody :: + ConwayEraTxBody era => + PParams era -> + (KeyHash 'StakePool (EraCrypto era) -> Bool) -> + TxBody era -> + Coin +conwayTotalDepositsTxBody pp isPoolRegisted txBody = + getTotalDepositsTxCerts pp isPoolRegisted (txBody ^. certsTxBodyL) + <+> conwayProposalsDeposits pp txBody + +-- | Total number of deposits in the proposals in TxBody +conwayProposalsDeposits :: + ConwayEraTxBody era => + PParams era -> + TxBody era -> + Coin +conwayProposalsDeposits pp txBody = numProposals <×> depositPerProposal + where + numProposals = length (txBody ^. proposalProceduresTxBodyL) + depositPerProposal = pp ^. ppGovActionDepositL + +instance Crypto c => AllegraEraTxBody (ConwayEra c) where + {-# SPECIALIZE instance AllegraEraTxBody (ConwayEra StandardCrypto) #-} + + vldtTxBodyL = lensMemoRawType ctbrVldt (\txb x -> txb {ctbrVldt = x}) + {-# INLINE vldtTxBodyL #-} + +instance Crypto c => MaryEraTxBody (ConwayEra c) where + {-# SPECIALIZE instance MaryEraTxBody (ConwayEra StandardCrypto) #-} + + mintTxBodyL = lensMemoRawType ctbrMint (\txb x -> txb {ctbrMint = x}) + {-# INLINE mintTxBodyL #-} + + mintValueTxBodyF = mintTxBodyL . to (MaryValue mempty) + + mintedTxBodyF = + to (\(TxBodyConstr (Memo txBodyRaw _)) -> policies (ctbrMint txBodyRaw)) + {-# INLINE mintedTxBodyF #-} + +instance Crypto c => AlonzoEraTxBody (ConwayEra c) where + {-# SPECIALIZE instance AlonzoEraTxBody (ConwayEra StandardCrypto) #-} + + collateralInputsTxBodyL = + lensMemoRawType ctbrCollateralInputs (\txb x -> txb {ctbrCollateralInputs = x}) + {-# INLINE collateralInputsTxBodyL #-} + + reqSignerHashesTxBodyL = + lensMemoRawType ctbrReqSignerHashes (\txb x -> txb {ctbrReqSignerHashes = x}) + {-# INLINE reqSignerHashesTxBodyL #-} + + scriptIntegrityHashTxBodyL = + lensMemoRawType ctbrScriptIntegrityHash (\txb x -> txb {ctbrScriptIntegrityHash = x}) + {-# INLINE scriptIntegrityHashTxBodyL #-} + + networkIdTxBodyL = lensMemoRawType ctbrTxNetworkId (\txb x -> txb {ctbrTxNetworkId = x}) + {-# INLINE networkIdTxBodyL #-} + + redeemerPointer = conwayRedeemerPointer + + redeemerPointerInverse = conwayRedeemerPointerInverse + +instance Crypto c => BabbageEraTxBody (ConwayEra c) where + {-# SPECIALIZE instance BabbageEraTxBody (ConwayEra StandardCrypto) #-} + + sizedOutputsTxBodyL = lensMemoRawType ctbrOutputs (\txb x -> txb {ctbrOutputs = x}) + {-# INLINE sizedOutputsTxBodyL #-} + + referenceInputsTxBodyL = + lensMemoRawType ctbrReferenceInputs (\txb x -> txb {ctbrReferenceInputs = x}) + {-# INLINE referenceInputsTxBodyL #-} + + totalCollateralTxBodyL = + lensMemoRawType ctbrTotalCollateral (\txb x -> txb {ctbrTotalCollateral = x}) + {-# INLINE totalCollateralTxBodyL #-} + + collateralReturnTxBodyL = + lensMemoRawType + (fmap sizedValue . ctbrCollateralReturn) + (\txb x -> txb {ctbrCollateralReturn = mkSized (eraProtVerLow @(ConwayEra c)) <$> x}) + {-# INLINE collateralReturnTxBodyL #-} + + sizedCollateralReturnTxBodyL = + lensMemoRawType ctbrCollateralReturn (\txb x -> txb {ctbrCollateralReturn = x}) + {-# INLINE sizedCollateralReturnTxBodyL #-} + + allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF + {-# INLINE allSizedOutputsTxBodyF #-} + +instance Crypto c => ConwayEraTxBody (ConwayEra c) where + votingProceduresTxBodyL = + lensMemoRawType ctbrVotingProcedures (\txb x -> txb {ctbrVotingProcedures = x}) + {-# INLINE votingProceduresTxBodyL #-} + proposalProceduresTxBodyL = + lensMemoRawType ctbrProposalProcedures (\txb x -> txb {ctbrProposalProcedures = x}) + {-# INLINE proposalProceduresTxBodyL #-} + currentTreasuryValueTxBodyL = + lensMemoRawType ctbrCurrentTreasuryValue (\txb x -> txb {ctbrCurrentTreasuryValue = x}) + {-# INLINE currentTreasuryValueTxBodyL #-} + treasuryDonationTxBodyL = + lensMemoRawType ctbrTreasuryDonation (\txb x -> txb {ctbrTreasuryDonation = x}) + {-# INLINE treasuryDonationTxBodyL #-} + +instance + (EraPParams era, Eq (TxOut era), Eq (TxCert era)) => + EqRaw (ConwayTxBody era) + +pattern ConwayTxBody :: + ConwayEraTxBody era => + Set (TxIn (EraCrypto era)) -> + Set (TxIn (EraCrypto era)) -> + Set (TxIn (EraCrypto era)) -> + StrictSeq (Sized (TxOut era)) -> + StrictMaybe (Sized (TxOut era)) -> + StrictMaybe Coin -> + OSet.OSet (ConwayTxCert era) -> + Withdrawals (EraCrypto era) -> + Coin -> + ValidityInterval -> + Set (KeyHash 'Witness (EraCrypto era)) -> + MultiAsset (EraCrypto era) -> + StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -> + StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> + StrictMaybe Network -> + VotingProcedures era -> + OSet.OSet (ProposalProcedure era) -> + StrictMaybe Coin -> + Coin -> + ConwayTxBody era +pattern ConwayTxBody + { ctbSpendInputs + , ctbCollateralInputs + , ctbReferenceInputs + , ctbOutputs + , ctbCollateralReturn + , ctbTotalCollateral + , ctbCerts + , ctbWithdrawals + , ctbTxfee + , ctbVldt + , ctbReqSignerHashes + , ctbMint + , ctbScriptIntegrityHash + , ctbAdHash + , ctbTxNetworkId + , ctbVotingProcedures + , ctbProposalProcedures + , ctbCurrentTreasuryValue + , ctbTreasuryDonation + } <- + ( getMemoRawType -> + ConwayTxBodyRaw + { ctbrSpendInputs = ctbSpendInputs + , ctbrCollateralInputs = ctbCollateralInputs + , ctbrReferenceInputs = ctbReferenceInputs + , ctbrOutputs = ctbOutputs + , ctbrCollateralReturn = ctbCollateralReturn + , ctbrTotalCollateral = ctbTotalCollateral + , ctbrCerts = ctbCerts + , ctbrWithdrawals = ctbWithdrawals + , ctbrTxfee = ctbTxfee + , ctbrVldt = ctbVldt + , ctbrReqSignerHashes = ctbReqSignerHashes + , ctbrMint = ctbMint + , ctbrScriptIntegrityHash = ctbScriptIntegrityHash + , ctbrAuxDataHash = ctbAdHash + , ctbrTxNetworkId = ctbTxNetworkId + , ctbrVotingProcedures = ctbVotingProcedures + , ctbrProposalProcedures = ctbProposalProcedures + , ctbrCurrentTreasuryValue = ctbCurrentTreasuryValue + , ctbrTreasuryDonation = ctbTreasuryDonation + } + ) + where + ConwayTxBody + inputsX + collateralX + referenceInputsX + outputsX + collateralReturnX + totalCollateralX + certsX + withdrawalsX + txfeeX + vldtX + reqSignerHashesX + mintX + scriptIntegrityHashX + adHashX + txnetworkidX + votingProcedures + proposalProcedures + currentTreasuryValue + treasuryDonation = + mkMemoized $ + ConwayTxBodyRaw + inputsX + collateralX + referenceInputsX + outputsX + collateralReturnX + totalCollateralX + certsX + withdrawalsX + txfeeX + vldtX + reqSignerHashesX + mintX + scriptIntegrityHashX + adHashX + txnetworkidX + votingProcedures + proposalProcedures + currentTreasuryValue + treasuryDonation + +{-# COMPLETE ConwayTxBody #-} + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +encodeTxBodyRaw :: + ConwayEraTxBody era => + ConwayTxBodyRaw era -> + Encode ('Closed 'Sparse) (ConwayTxBodyRaw era) +encodeTxBodyRaw ConwayTxBodyRaw {..} = + let ValidityInterval bot top = ctbrVldt + in Keyed + ( \i ci ri o cr tc f t c w b -> + ConwayTxBodyRaw i ci ri o cr tc c w f (ValidityInterval b t) + ) + !> Key 0 (To ctbrSpendInputs) + !> Omit null (Key 13 (To ctbrCollateralInputs)) + !> Omit null (Key 18 (To ctbrReferenceInputs)) + !> Key 1 (To ctbrOutputs) + !> encodeKeyedStrictMaybe 16 ctbrCollateralReturn + !> encodeKeyedStrictMaybe 17 ctbrTotalCollateral + !> Key 2 (To ctbrTxfee) + !> encodeKeyedStrictMaybe 3 top + !> Omit OSet.null (Key 4 (To ctbrCerts)) + !> Omit (null . unWithdrawals) (Key 5 (To ctbrWithdrawals)) + !> encodeKeyedStrictMaybe 8 bot + !> Omit null (Key 14 (To ctbrReqSignerHashes)) + !> Omit (== mempty) (Key 9 (To ctbrMint)) + !> encodeKeyedStrictMaybe 11 ctbrScriptIntegrityHash + !> encodeKeyedStrictMaybe 7 ctbrAuxDataHash + !> encodeKeyedStrictMaybe 15 ctbrTxNetworkId + !> Omit (null . unVotingProcedures) (Key 19 (To ctbrVotingProcedures)) + !> Omit OSet.null (Key 20 (To ctbrProposalProcedures)) + !> encodeKeyedStrictMaybe 21 ctbrCurrentTreasuryValue + !> Omit (== mempty) (Key 22 $ To ctbrTreasuryDonation) + +instance ConwayEraTxBody era => EncCBOR (ConwayTxBodyRaw era) where + encCBOR = encode . encodeTxBodyRaw + +-- | Encodes memoized bytes created upon construction. +instance Era era => EncCBOR (ConwayTxBody era) + +class + (BabbageEraTxBody era, ConwayEraTxCert era, ConwayEraPParams era, ConwayEraScript era) => + ConwayEraTxBody era + where + -- | Lens for getting and setting number of `Coin` that is expected to be in the + -- Treasury at the current Epoch + currentTreasuryValueTxBodyL :: Lens' (TxBody era) (StrictMaybe Coin) + + -- | Lens for getting and setting `VotingProcedures`. + votingProceduresTxBodyL :: Lens' (TxBody era) (VotingProcedures era) + + -- | Lens for getting and setting `ProposalProcedures`. + proposalProceduresTxBodyL :: Lens' (TxBody era) (OSet.OSet (ProposalProcedure era)) + + treasuryDonationTxBodyL :: Lens' (TxBody era) Coin + +conwayRedeemerPointer :: + forall era. + ConwayEraTxBody era => + TxBody era -> + ConwayPlutusPurpose AsItem era -> + StrictMaybe (ConwayPlutusPurpose AsIx era) +conwayRedeemerPointer txBody = \case + ConwayMinting policyID -> + ConwayMinting <$> indexOf policyID (txBody ^. mintedTxBodyF :: Set (PolicyID (EraCrypto era))) + ConwaySpending txIn -> + ConwaySpending <$> indexOf txIn (txBody ^. inputsTxBodyL) + ConwayRewarding rewardAccount -> + ConwayRewarding <$> indexOf rewardAccount (unWithdrawals (txBody ^. withdrawalsTxBodyL)) + ConwayCertifying txCert -> + ConwayCertifying <$> indexOf txCert (txBody ^. certsTxBodyL) + ConwayVoting votingProcedure -> + ConwayVoting <$> indexOf votingProcedure (txBody ^. votingProceduresTxBodyL) + ConwayProposing proposalProcedure -> + ConwayProposing <$> indexOf proposalProcedure (txBody ^. proposalProceduresTxBodyL) + +conwayRedeemerPointerInverse :: + ConwayEraTxBody era => + TxBody era -> + ConwayPlutusPurpose AsIx era -> + StrictMaybe (ConwayPlutusPurpose AsIxItem era) +conwayRedeemerPointerInverse txBody = \case + ConwayMinting idx -> + ConwayMinting <$> fromIndex idx (txBody ^. mintedTxBodyF) + ConwaySpending idx -> + ConwaySpending <$> fromIndex idx (txBody ^. inputsTxBodyL) + ConwayRewarding idx -> + ConwayRewarding <$> fromIndex idx (unWithdrawals (txBody ^. withdrawalsTxBodyL)) + ConwayCertifying idx -> + ConwayCertifying <$> fromIndex idx (txBody ^. certsTxBodyL) + ConwayVoting idx -> + ConwayVoting <$> fromIndex idx (txBody ^. votingProceduresTxBodyL) + ConwayProposing idx -> + ConwayProposing <$> fromIndex idx (txBody ^. proposalProceduresTxBodyL) diff --git a/eras/mary/impl/cardano-ledger-mary.cabal b/eras/mary/impl/cardano-ledger-mary.cabal index 11f3809c728..8c06470c833 100644 --- a/eras/mary/impl/cardano-ledger-mary.cabal +++ b/eras/mary/impl/cardano-ledger-mary.cabal @@ -35,6 +35,7 @@ library Cardano.Ledger.Mary.Transition Cardano.Ledger.Mary.Translation Cardano.Ledger.Mary.TxBody + Cardano.Ledger.Mary.TxBody.Internal Cardano.Ledger.Mary.TxOut Cardano.Ledger.Mary.UTxO Cardano.Ledger.Mary.Value diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs index 89dc4d6e5b8..1fd9f5256f2 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs @@ -1,22 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Cardano.Ledger.Mary.TxBody ( MaryEraTxBody (..), MaryTxBody ( @@ -35,282 +16,4 @@ module Cardano.Ledger.Mary.TxBody ( ) where -import Cardano.Ledger.Allegra.Core -import Cardano.Ledger.Allegra.TxBody -import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) -import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR (..), ToCBOR (..)) -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Crypto (Crypto, StandardCrypto) -import Cardano.Ledger.Mary.Era (MaryEra) -import Cardano.Ledger.Mary.TxCert () -import Cardano.Ledger.Mary.TxOut () -import Cardano.Ledger.Mary.Value -import Cardano.Ledger.MemoBytes ( - EqRaw, - Mem, - MemoBytes (Memo), - MemoHashIndex, - Memoized (RawType), - getMemoRawType, - getMemoSafeHash, - lensMemoRawType, - mkMemoized, - ) -import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) -import Cardano.Ledger.Shelley.PParams (Update, upgradeUpdate) -import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) -import Cardano.Ledger.TxIn (TxIn (..)) -import Control.DeepSeq (NFData (..)) -import Data.Sequence.Strict (StrictSeq) -import Data.Set (Set) -import GHC.Generics (Generic) -import Lens.Micro -import NoThunks.Class (NoThunks (..)) - -class AllegraEraTxBody era => MaryEraTxBody era where - mintTxBodyL :: Lens' (TxBody era) (MultiAsset (EraCrypto era)) - - mintValueTxBodyF :: SimpleGetter (TxBody era) (Value era) - - mintedTxBodyF :: SimpleGetter (TxBody era) (Set (PolicyID (EraCrypto era))) - --- =========================================================================== --- Wrap it all up in a newtype, hiding the insides with a pattern constructor. - -newtype MaryTxBodyRaw era = MaryTxBodyRaw (AllegraTxBodyRaw (MultiAsset (EraCrypto era)) era) - -deriving newtype instance - (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => - NFData (MaryTxBodyRaw era) - -deriving newtype instance - (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => - Eq (MaryTxBodyRaw era) - -deriving newtype instance - (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => - Show (MaryTxBodyRaw era) - -deriving instance Generic (MaryTxBodyRaw era) - -deriving newtype instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => - NoThunks (MaryTxBodyRaw era) - -deriving newtype instance AllegraEraTxBody era => DecCBOR (MaryTxBodyRaw era) - -newtype MaryTxBody era = TxBodyConstr (MemoBytes MaryTxBodyRaw era) - deriving newtype (SafeToHash, ToCBOR) - --- | Encodes memoized bytes created upon construction. -instance Era era => EncCBOR (MaryTxBody era) - -instance - (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => - EqRaw (MaryTxBody era) - -instance AllegraEraTxBody era => DecCBOR (Annotator (MaryTxBodyRaw era)) where - decCBOR = pure <$> decCBOR - -deriving newtype instance (EraTxOut era, EraTxCert era) => EncCBOR (MaryTxBodyRaw era) - -instance Memoized MaryTxBody where - type RawType MaryTxBody = MaryTxBodyRaw - -deriving newtype instance - (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => - Eq (MaryTxBody era) - -deriving newtype instance - (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => - Show (MaryTxBody era) - -deriving instance Generic (MaryTxBody era) - -deriving newtype instance - (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => - NoThunks (MaryTxBody era) - -deriving newtype instance - (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => - NFData (MaryTxBody era) - -deriving via - Mem MaryTxBodyRaw era - instance - MaryEraTxBody era => DecCBOR (Annotator (MaryTxBody era)) - -type instance MemoHashIndex MaryTxBodyRaw = EraIndependentTxBody - -instance (c ~ EraCrypto era, Era era) => HashAnnotated (MaryTxBody era) EraIndependentTxBody c where - hashAnnotated = getMemoSafeHash - --- | A pattern to keep the newtype and the MemoBytes hidden -pattern MaryTxBody :: - (EraTxOut era, EraTxCert era) => - Set (TxIn (EraCrypto era)) -> - StrictSeq (TxOut era) -> - StrictSeq (TxCert era) -> - Withdrawals (EraCrypto era) -> - Coin -> - ValidityInterval -> - StrictMaybe (Update era) -> - StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> - MultiAsset (EraCrypto era) -> - MaryTxBody era -pattern MaryTxBody - { mtbInputs - , mtbOutputs - , mtbCerts - , mtbWithdrawals - , mtbTxFee - , mtbValidityInterval - , mtbUpdate - , mtbAuxDataHash - , mtbMint - } <- - ( getMemoRawType -> - MaryTxBodyRaw - ( AllegraTxBodyRaw - { atbrInputs = mtbInputs - , atbrOutputs = mtbOutputs - , atbrCerts = mtbCerts - , atbrWithdrawals = mtbWithdrawals - , atbrTxFee = mtbTxFee - , atbrValidityInterval = mtbValidityInterval - , atbrUpdate = mtbUpdate - , atbrAuxDataHash = mtbAuxDataHash - , atbrMint = mtbMint - } - ) - ) - where - MaryTxBody - inputs - outputs - certs - withdrawals - txFee - validityInterval - update - auxDataHash - mint = - mkMemoized $ - MaryTxBodyRaw $ - AllegraTxBodyRaw - { atbrInputs = inputs - , atbrOutputs = outputs - , atbrCerts = certs - , atbrWithdrawals = withdrawals - , atbrTxFee = txFee - , atbrValidityInterval = validityInterval - , atbrUpdate = update - , atbrAuxDataHash = auxDataHash - , atbrMint = mint - } - -{-# COMPLETE MaryTxBody #-} - --- | This is a helper Lens creator for any Memoized type. -lensMaryTxBodyRaw :: - (EraTxOut era, EraTxCert era) => - (AllegraTxBodyRaw (MultiAsset (EraCrypto era)) era -> a) -> - ( AllegraTxBodyRaw (MultiAsset (EraCrypto era)) era -> - b -> - AllegraTxBodyRaw (MultiAsset (EraCrypto era)) era - ) -> - Lens (MaryTxBody era) (MaryTxBody era) a b -lensMaryTxBodyRaw getter setter = - lensMemoRawType - (\(MaryTxBodyRaw atbr) -> getter atbr) - (\(MaryTxBodyRaw atbr) a -> MaryTxBodyRaw (setter atbr a)) -{-# INLINEABLE lensMaryTxBodyRaw #-} - -instance Crypto c => EraTxBody (MaryEra c) where - {-# SPECIALIZE instance EraTxBody (MaryEra StandardCrypto) #-} - - type TxBody (MaryEra c) = MaryTxBody (MaryEra c) - - mkBasicTxBody = mkMemoized $ MaryTxBodyRaw emptyAllegraTxBodyRaw - - inputsTxBodyL = - lensMaryTxBodyRaw atbrInputs $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} - {-# INLINEABLE inputsTxBodyL #-} - - outputsTxBodyL = - lensMaryTxBodyRaw atbrOutputs $ \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} - {-# INLINEABLE outputsTxBodyL #-} - - feeTxBodyL = - lensMaryTxBodyRaw atbrTxFee $ \txBodyRaw fee -> txBodyRaw {atbrTxFee = fee} - {-# INLINEABLE feeTxBodyL #-} - - auxDataHashTxBodyL = - lensMaryTxBodyRaw atbrAuxDataHash $ - \txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} - {-# INLINEABLE auxDataHashTxBodyL #-} - - spendableInputsTxBodyF = inputsTxBodyL - {-# INLINE spendableInputsTxBodyF #-} - - allInputsTxBodyF = inputsTxBodyL - {-# INLINEABLE allInputsTxBodyF #-} - - withdrawalsTxBodyL = - lensMaryTxBodyRaw atbrWithdrawals $ \txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} - {-# INLINEABLE withdrawalsTxBodyL #-} - - certsTxBodyL = - lensMaryTxBodyRaw atbrCerts $ \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} - {-# INLINEABLE certsTxBodyL #-} - - getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody - - upgradeTxBody atb = do - certs <- traverse upgradeTxCert (atbCerts atb) - pure $ - MaryTxBody - { mtbInputs = atbInputs atb - , mtbOutputs = upgradeTxOut <$> atbOutputs atb - , mtbCerts = certs - , mtbWithdrawals = atbWithdrawals atb - , mtbTxFee = atbTxFee atb - , mtbValidityInterval = atbValidityInterval atb - , mtbUpdate = upgradeUpdate () <$> atbUpdate atb - , mtbAuxDataHash = atbAuxDataHash atb - , mtbMint = mempty - } - -instance Crypto c => ShelleyEraTxBody (MaryEra c) where - {-# SPECIALIZE instance ShelleyEraTxBody (MaryEra StandardCrypto) #-} - - ttlTxBodyL = notSupportedInThisEraL - {-# INLINEABLE ttlTxBodyL #-} - - updateTxBodyL = - lensMaryTxBodyRaw atbrUpdate $ \txBodyRaw update -> txBodyRaw {atbrUpdate = update} - {-# INLINEABLE updateTxBodyL #-} - -instance Crypto c => AllegraEraTxBody (MaryEra c) where - {-# SPECIALIZE instance AllegraEraTxBody (MaryEra StandardCrypto) #-} - - vldtTxBodyL = - lensMaryTxBodyRaw atbrValidityInterval $ - \txBodyRaw vldt -> txBodyRaw {atbrValidityInterval = vldt} - {-# INLINEABLE vldtTxBodyL #-} - -instance Crypto c => MaryEraTxBody (MaryEra c) where - {-# SPECIALIZE instance MaryEraTxBody (MaryEra StandardCrypto) #-} - - mintTxBodyL = - lensMaryTxBodyRaw atbrMint (\txBodyRaw mint -> txBodyRaw {atbrMint = mint}) - {-# INLINEABLE mintTxBodyL #-} - - mintValueTxBodyF = - to $ \(TxBodyConstr (Memo (MaryTxBodyRaw txBodyRaw) _)) -> - MaryValue mempty (atbrMint txBodyRaw) - {-# INLINEABLE mintValueTxBodyF #-} - - mintedTxBodyF = - to $ \(TxBodyConstr (Memo (MaryTxBodyRaw txBodyRaw) _)) -> policies (atbrMint txBodyRaw) - {-# INLINEABLE mintedTxBodyF #-} +import Cardano.Ledger.Mary.TxBody.Internal diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs new file mode 100644 index 00000000000..474cf452654 --- /dev/null +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Provides Mary TxBody internals +-- +-- = Warning +-- +-- This module is considered __internal__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +module Cardano.Ledger.Mary.TxBody.Internal ( + MaryEraTxBody (..), + MaryTxBody ( + .., + MaryTxBody, + mtbAuxDataHash, + mtbCerts, + mtbInputs, + mtbOutputs, + mtbTxFee, + mtbUpdate, + mtbValidityInterval, + mtbWithdrawals, + mtbMint + ), + MaryTxBodyRaw (..), +) +where + +import Cardano.Ledger.Allegra.Core +import Cardano.Ledger.Allegra.TxBody +import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) +import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR (..), ToCBOR (..)) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Crypto (Crypto, StandardCrypto) +import Cardano.Ledger.Mary.Era (MaryEra) +import Cardano.Ledger.Mary.TxCert () +import Cardano.Ledger.Mary.TxOut () +import Cardano.Ledger.Mary.Value +import Cardano.Ledger.MemoBytes ( + EqRaw, + Mem, + MemoBytes (Memo), + MemoHashIndex, + Memoized (RawType), + getMemoRawType, + getMemoSafeHash, + lensMemoRawType, + mkMemoized, + ) +import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) +import Cardano.Ledger.Shelley.PParams (Update, upgradeUpdate) +import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody) +import Cardano.Ledger.TxIn (TxIn (..)) +import Control.DeepSeq (NFData (..)) +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import GHC.Generics (Generic) +import Lens.Micro +import NoThunks.Class (NoThunks (..)) + +class AllegraEraTxBody era => MaryEraTxBody era where + mintTxBodyL :: Lens' (TxBody era) (MultiAsset (EraCrypto era)) + + mintValueTxBodyF :: SimpleGetter (TxBody era) (Value era) + + mintedTxBodyF :: SimpleGetter (TxBody era) (Set (PolicyID (EraCrypto era))) + +-- =========================================================================== +-- Wrap it all up in a newtype, hiding the insides with a pattern constructor. + +newtype MaryTxBodyRaw era = MaryTxBodyRaw (AllegraTxBodyRaw (MultiAsset (EraCrypto era)) era) + +deriving newtype instance + (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => + NFData (MaryTxBodyRaw era) + +deriving newtype instance + (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => + Eq (MaryTxBodyRaw era) + +deriving newtype instance + (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => + Show (MaryTxBodyRaw era) + +deriving instance Generic (MaryTxBodyRaw era) + +deriving newtype instance + (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => + NoThunks (MaryTxBodyRaw era) + +deriving newtype instance AllegraEraTxBody era => DecCBOR (MaryTxBodyRaw era) + +newtype MaryTxBody era = TxBodyConstr (MemoBytes MaryTxBodyRaw era) + deriving newtype (SafeToHash, ToCBOR) + +-- | Encodes memoized bytes created upon construction. +instance Era era => EncCBOR (MaryTxBody era) + +instance + (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => + EqRaw (MaryTxBody era) + +instance AllegraEraTxBody era => DecCBOR (Annotator (MaryTxBodyRaw era)) where + decCBOR = pure <$> decCBOR + +deriving newtype instance (EraTxOut era, EraTxCert era) => EncCBOR (MaryTxBodyRaw era) + +instance Memoized MaryTxBody where + type RawType MaryTxBody = MaryTxBodyRaw + +deriving newtype instance + (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => + Eq (MaryTxBody era) + +deriving newtype instance + (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => + Show (MaryTxBody era) + +deriving instance Generic (MaryTxBody era) + +deriving newtype instance + (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => + NoThunks (MaryTxBody era) + +deriving newtype instance + (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => + NFData (MaryTxBody era) + +deriving via + Mem MaryTxBodyRaw era + instance + MaryEraTxBody era => DecCBOR (Annotator (MaryTxBody era)) + +type instance MemoHashIndex MaryTxBodyRaw = EraIndependentTxBody + +instance (c ~ EraCrypto era, Era era) => HashAnnotated (MaryTxBody era) EraIndependentTxBody c where + hashAnnotated = getMemoSafeHash + +-- | A pattern to keep the newtype and the MemoBytes hidden +pattern MaryTxBody :: + (EraTxOut era, EraTxCert era) => + Set (TxIn (EraCrypto era)) -> + StrictSeq (TxOut era) -> + StrictSeq (TxCert era) -> + Withdrawals (EraCrypto era) -> + Coin -> + ValidityInterval -> + StrictMaybe (Update era) -> + StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> + MultiAsset (EraCrypto era) -> + MaryTxBody era +pattern MaryTxBody + { mtbInputs + , mtbOutputs + , mtbCerts + , mtbWithdrawals + , mtbTxFee + , mtbValidityInterval + , mtbUpdate + , mtbAuxDataHash + , mtbMint + } <- + ( getMemoRawType -> + MaryTxBodyRaw + ( AllegraTxBodyRaw + { atbrInputs = mtbInputs + , atbrOutputs = mtbOutputs + , atbrCerts = mtbCerts + , atbrWithdrawals = mtbWithdrawals + , atbrTxFee = mtbTxFee + , atbrValidityInterval = mtbValidityInterval + , atbrUpdate = mtbUpdate + , atbrAuxDataHash = mtbAuxDataHash + , atbrMint = mtbMint + } + ) + ) + where + MaryTxBody + inputs + outputs + certs + withdrawals + txFee + validityInterval + update + auxDataHash + mint = + mkMemoized $ + MaryTxBodyRaw $ + AllegraTxBodyRaw + { atbrInputs = inputs + , atbrOutputs = outputs + , atbrCerts = certs + , atbrWithdrawals = withdrawals + , atbrTxFee = txFee + , atbrValidityInterval = validityInterval + , atbrUpdate = update + , atbrAuxDataHash = auxDataHash + , atbrMint = mint + } + +{-# COMPLETE MaryTxBody #-} + +-- | This is a helper Lens creator for any Memoized type. +lensMaryTxBodyRaw :: + (EraTxOut era, EraTxCert era) => + (AllegraTxBodyRaw (MultiAsset (EraCrypto era)) era -> a) -> + ( AllegraTxBodyRaw (MultiAsset (EraCrypto era)) era -> + b -> + AllegraTxBodyRaw (MultiAsset (EraCrypto era)) era + ) -> + Lens (MaryTxBody era) (MaryTxBody era) a b +lensMaryTxBodyRaw getter setter = + lensMemoRawType + (\(MaryTxBodyRaw atbr) -> getter atbr) + (\(MaryTxBodyRaw atbr) a -> MaryTxBodyRaw (setter atbr a)) +{-# INLINEABLE lensMaryTxBodyRaw #-} + +instance Crypto c => EraTxBody (MaryEra c) where + {-# SPECIALIZE instance EraTxBody (MaryEra StandardCrypto) #-} + + type TxBody (MaryEra c) = MaryTxBody (MaryEra c) + + mkBasicTxBody = mkMemoized $ MaryTxBodyRaw emptyAllegraTxBodyRaw + + inputsTxBodyL = + lensMaryTxBodyRaw atbrInputs $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} + {-# INLINEABLE inputsTxBodyL #-} + + outputsTxBodyL = + lensMaryTxBodyRaw atbrOutputs $ \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} + {-# INLINEABLE outputsTxBodyL #-} + + feeTxBodyL = + lensMaryTxBodyRaw atbrTxFee $ \txBodyRaw fee -> txBodyRaw {atbrTxFee = fee} + {-# INLINEABLE feeTxBodyL #-} + + auxDataHashTxBodyL = + lensMaryTxBodyRaw atbrAuxDataHash $ + \txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} + {-# INLINEABLE auxDataHashTxBodyL #-} + + spendableInputsTxBodyF = inputsTxBodyL + {-# INLINE spendableInputsTxBodyF #-} + + allInputsTxBodyF = inputsTxBodyL + {-# INLINEABLE allInputsTxBodyF #-} + + withdrawalsTxBodyL = + lensMaryTxBodyRaw atbrWithdrawals $ \txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} + {-# INLINEABLE withdrawalsTxBodyL #-} + + certsTxBodyL = + lensMaryTxBodyRaw atbrCerts $ \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} + {-# INLINEABLE certsTxBodyL #-} + + getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody + + upgradeTxBody atb = do + certs <- traverse upgradeTxCert (atbCerts atb) + pure $ + MaryTxBody + { mtbInputs = atbInputs atb + , mtbOutputs = upgradeTxOut <$> atbOutputs atb + , mtbCerts = certs + , mtbWithdrawals = atbWithdrawals atb + , mtbTxFee = atbTxFee atb + , mtbValidityInterval = atbValidityInterval atb + , mtbUpdate = upgradeUpdate () <$> atbUpdate atb + , mtbAuxDataHash = atbAuxDataHash atb + , mtbMint = mempty + } + +instance Crypto c => ShelleyEraTxBody (MaryEra c) where + {-# SPECIALIZE instance ShelleyEraTxBody (MaryEra StandardCrypto) #-} + + ttlTxBodyL = notSupportedInThisEraL + {-# INLINEABLE ttlTxBodyL #-} + + updateTxBodyL = + lensMaryTxBodyRaw atbrUpdate $ \txBodyRaw update -> txBodyRaw {atbrUpdate = update} + {-# INLINEABLE updateTxBodyL #-} + +instance Crypto c => AllegraEraTxBody (MaryEra c) where + {-# SPECIALIZE instance AllegraEraTxBody (MaryEra StandardCrypto) #-} + + vldtTxBodyL = + lensMaryTxBodyRaw atbrValidityInterval $ + \txBodyRaw vldt -> txBodyRaw {atbrValidityInterval = vldt} + {-# INLINEABLE vldtTxBodyL #-} + +instance Crypto c => MaryEraTxBody (MaryEra c) where + {-# SPECIALIZE instance MaryEraTxBody (MaryEra StandardCrypto) #-} + + mintTxBodyL = + lensMaryTxBodyRaw atbrMint (\txBodyRaw mint -> txBodyRaw {atbrMint = mint}) + {-# INLINEABLE mintTxBodyL #-} + + mintValueTxBodyF = + to $ \(TxBodyConstr (Memo (MaryTxBodyRaw txBodyRaw) _)) -> + MaryValue mempty (atbrMint txBodyRaw) + {-# INLINEABLE mintValueTxBodyF #-} + + mintedTxBodyF = + to $ \(TxBodyConstr (Memo (MaryTxBodyRaw txBodyRaw) _)) -> policies (atbrMint txBodyRaw) + {-# INLINEABLE mintedTxBodyF #-} diff --git a/eras/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal index 980b1d8bf45..a4aa34627c9 100644 --- a/eras/shelley/impl/cardano-ledger-shelley.cabal +++ b/eras/shelley/impl/cardano-ledger-shelley.cabal @@ -53,6 +53,7 @@ library Cardano.Ledger.Shelley.Transition Cardano.Ledger.Shelley.Translation Cardano.Ledger.Shelley.Tx + Cardano.Ledger.Shelley.Tx.Internal Cardano.Ledger.Shelley.TxAuxData Cardano.Ledger.Shelley.TxBody Cardano.Ledger.Shelley.TxCert diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs index c61af5a8f75..4132710162a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs @@ -1,20 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Cardano.Ledger.Shelley.Tx ( -- * Transaction ShelleyTx ( @@ -41,375 +24,4 @@ module Cardano.Ledger.Shelley.Tx ( ) where -import Cardano.Ledger.Binary ( - Annotator (..), - DecCBOR (decCBOR), - EncCBOR (encCBOR), - ToCBOR, - decodeNullMaybe, - encodeNullMaybe, - runAnnotator, - ) -import Cardano.Ledger.Binary.Coders -import qualified Cardano.Ledger.Binary.Plain as Plain -import Cardano.Ledger.Coin (Coin) -import Cardano.Ledger.Core -import Cardano.Ledger.Crypto (Crypto, StandardCrypto) -import Cardano.Ledger.Keys (KeyHash, KeyRole (Witness)) -import Cardano.Ledger.Keys.Bootstrap (bootstrapWitKeyHash) -import Cardano.Ledger.Keys.WitVKey (witVKeyHash) -import Cardano.Ledger.MemoBytes ( - EqRaw (..), - Mem, - MemoBytes, - Memoized (..), - memoBytes, - mkMemoBytes, - pattern Memo, - ) -import Cardano.Ledger.SafeHash (SafeToHash (..)) -import Cardano.Ledger.Shelley.Era (ShelleyEra) -import Cardano.Ledger.Shelley.Scripts (MultiSig, validateMultiSig) -import Cardano.Ledger.Shelley.TxAuxData () -import Cardano.Ledger.Shelley.TxBody () -import Cardano.Ledger.Shelley.TxWits () -import Cardano.Ledger.Val ((<+>), (<×>)) -import Control.DeepSeq (NFData) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Short as SBS -import Data.Functor.Classes (Eq1 (liftEq)) -import Data.Map.Strict (Map) -import Data.Maybe.Strict ( - StrictMaybe (..), - maybeToStrictMaybe, - strictMaybeToMaybe, - ) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Typeable (Typeable) -import Data.Word (Word32) -import GHC.Generics (Generic) -import Lens.Micro (Lens', SimpleGetter, lens, to, (^.)) -import NoThunks.Class (NoThunks (..)) - --- ======================================================== - -data ShelleyTxRaw era = ShelleyTxRaw - { strBody :: !(TxBody era) - , strWits :: !(TxWits era) - , strAuxiliaryData :: !(StrictMaybe (TxAuxData era)) - } - deriving (Generic, Typeable) - -instance - ( NFData (TxBody era) - , NFData (TxWits era) - , NFData (TxAuxData era) - ) => - NFData (ShelleyTxRaw era) - -deriving instance - ( Era era - , Eq (TxBody era) - , Eq (TxWits era) - , Eq (TxAuxData era) - ) => - Eq (ShelleyTxRaw era) - -deriving instance - ( Era era - , Show (TxBody era) - , Show (TxWits era) - , Show (TxAuxData era) - ) => - Show (ShelleyTxRaw era) - -instance - ( Era era - , NoThunks (TxAuxData era) - , NoThunks (TxBody era) - , NoThunks (TxWits era) - ) => - NoThunks (ShelleyTxRaw era) - -newtype ShelleyTx era = TxConstr (MemoBytes ShelleyTxRaw era) - deriving newtype (SafeToHash, ToCBOR) - deriving (Generic) - -instance Memoized ShelleyTx where - type RawType ShelleyTx = ShelleyTxRaw - --- | `TxBody` setter and getter for `ShelleyTx`. The setter does update --- memoized binary representation. -bodyShelleyTxL :: EraTx era => Lens' (ShelleyTx era) (TxBody era) -bodyShelleyTxL = - lens (\(TxConstr (Memo tx _)) -> strBody tx) $ - \(TxConstr (Memo tx _)) txBody -> - TxConstr $ memoBytes $ encodeShelleyTxRaw $ tx {strBody = txBody} -{-# INLINEABLE bodyShelleyTxL #-} - --- | `TxWits` setter and getter for `ShelleyTx`. The setter does update --- memoized binary representation. -witsShelleyTxL :: EraTx era => Lens' (ShelleyTx era) (TxWits era) -witsShelleyTxL = - lens (\(TxConstr (Memo tx _)) -> strWits tx) $ - \(TxConstr (Memo tx _)) txWits -> - TxConstr $ memoBytes $ encodeShelleyTxRaw $ tx {strWits = txWits} -{-# INLINEABLE witsShelleyTxL #-} - --- | `TxAuxData` setter and getter for `ShelleyTx`. The setter does update --- memoized binary representation. -auxDataShelleyTxL :: EraTx era => Lens' (ShelleyTx era) (StrictMaybe (TxAuxData era)) -auxDataShelleyTxL = - lens (\(TxConstr (Memo tx _)) -> strAuxiliaryData tx) $ - \(TxConstr (Memo tx _)) auxData -> mkShelleyTx $ tx {strAuxiliaryData = auxData} -{-# INLINEABLE auxDataShelleyTxL #-} - --- | Size getter for `ShelleyTx`. -sizeShelleyTxF :: Era era => SimpleGetter (ShelleyTx era) Integer -sizeShelleyTxF = to (\(TxConstr (Memo _ bytes)) -> fromIntegral $ SBS.length bytes) -{-# INLINEABLE sizeShelleyTxF #-} - -wireSizeShelleyTxF :: Era era => SimpleGetter (ShelleyTx era) Word32 -wireSizeShelleyTxF = to $ \(TxConstr (Memo _ bytes)) -> - let n = SBS.length bytes - in if n <= fromIntegral (maxBound :: Word32) - then fromIntegral n - else error $ "Impossible: Size of the transaction is too big: " ++ show n -{-# INLINEABLE wireSizeShelleyTxF #-} - -mkShelleyTx :: EraTx era => ShelleyTxRaw era -> ShelleyTx era -mkShelleyTx = TxConstr . memoBytes . encodeShelleyTxRaw -{-# INLINEABLE mkShelleyTx #-} - -mkBasicShelleyTx :: EraTx era => TxBody era -> ShelleyTx era -mkBasicShelleyTx txBody = - mkShelleyTx $ - ShelleyTxRaw - { strBody = txBody - , strWits = mkBasicTxWits - , strAuxiliaryData = SNothing - } - -instance Crypto c => EraTx (ShelleyEra c) where - {-# SPECIALIZE instance EraTx (ShelleyEra StandardCrypto) #-} - - type Tx (ShelleyEra c) = ShelleyTx (ShelleyEra c) - - mkBasicTx = mkBasicShelleyTx - - bodyTxL = bodyShelleyTxL - {-# INLINE bodyTxL #-} - - witsTxL = witsShelleyTxL - {-# INLINE witsTxL #-} - - auxDataTxL = auxDataShelleyTxL - {-# INLINE auxDataTxL #-} - - sizeTxF = sizeShelleyTxF - {-# INLINE sizeTxF #-} - - wireSizeTxF = wireSizeShelleyTxF - {-# INLINE wireSizeTxF #-} - - validateNativeScript = validateMultiSig - {-# INLINE validateNativeScript #-} - - getMinFeeTx pp tx _ = shelleyMinFeeTx pp tx - - upgradeTx = - error - "Calling this function will cause a compilation error, since there is no Tx instance for Byron" - -instance (Tx era ~ ShelleyTx era, EraTx era) => EqRaw (ShelleyTx era) where - eqRaw = shelleyEqTxRaw - -shelleyEqTxRaw :: EraTx era => Tx era -> Tx era -> Bool -shelleyEqTxRaw tx1 tx2 = - eqRaw (tx1 ^. bodyTxL) (tx2 ^. bodyTxL) - && eqRaw (tx1 ^. witsTxL) (tx2 ^. witsTxL) - && liftEq -- TODO: Implement Eq1 instance for StrictMaybe - eqRaw - (strictMaybeToMaybe (tx1 ^. auxDataTxL)) - (strictMaybeToMaybe (tx2 ^. auxDataTxL)) - -deriving newtype instance - ( NFData (TxBody era) - , NFData (TxWits era) - , NFData (TxAuxData era) - ) => - NFData (ShelleyTx era) - -deriving newtype instance - ( Era era - , Eq (TxBody era) - , Eq (TxWits era) - , Eq (TxAuxData era) - ) => - Eq (ShelleyTx era) - -deriving newtype instance - (Era era, Show (TxBody era), Show (TxWits era), Show (TxAuxData era)) => - Show (ShelleyTx era) - -deriving newtype instance - ( Era era - , NoThunks (TxAuxData era) - , NoThunks (TxBody era) - , NoThunks (TxWits era) - ) => - NoThunks (ShelleyTx era) - -pattern ShelleyTx :: - EraTx era => - TxBody era -> - TxWits era -> - StrictMaybe (TxAuxData era) -> - ShelleyTx era -pattern ShelleyTx {body, wits, auxiliaryData} <- - TxConstr - ( Memo - ShelleyTxRaw - { strBody = body - , strWits = wits - , strAuxiliaryData = auxiliaryData - } - _ - ) - where - ShelleyTx b w a = mkShelleyTx $ ShelleyTxRaw b w a - -{-# COMPLETE ShelleyTx #-} - --------------------------------------------------------------------------------- --- Serialisation --------------------------------------------------------------------------------- - -encodeShelleyTxRaw :: - (EncCBOR (TxWits era), EncCBOR (TxBody era), EncCBOR (TxAuxData era)) => - ShelleyTxRaw era -> - Encode ('Closed 'Dense) (ShelleyTxRaw era) -encodeShelleyTxRaw ShelleyTxRaw {strBody, strWits, strAuxiliaryData} = - Rec ShelleyTxRaw - !> To strBody - !> To strWits - !> E (encodeNullMaybe encCBOR . strictMaybeToMaybe) strAuxiliaryData - -instance - (Era era, EncCBOR (TxWits era), EncCBOR (TxBody era), EncCBOR (TxAuxData era)) => - EncCBOR (ShelleyTxRaw era) - where - encCBOR = encode . encodeShelleyTxRaw - --- | Encodes memoized bytes created upon construction. -instance Era era => EncCBOR (ShelleyTx era) - -instance - ( Era era - , DecCBOR (Annotator (TxBody era)) - , DecCBOR (Annotator (TxWits era)) - , DecCBOR (Annotator (TxAuxData era)) - ) => - DecCBOR (Annotator (ShelleyTxRaw era)) - where - decCBOR = - decode $ - Ann (RecD ShelleyTxRaw) - <*! From - <*! From - <*! D - ( sequence . maybeToStrictMaybe - <$> decodeNullMaybe decCBOR - ) - -deriving via - Mem ShelleyTxRaw era - instance - EraTx era => DecCBOR (Annotator (ShelleyTx era)) - --- | Construct a Tx containing the explicit serialised bytes. --- --- This function is marked as unsafe since it makes no guarantee that the --- represented bytes are indeed the correct serialisation of the transaction. --- Thus, when calling this function, the caller is responsible for making this --- guarantee. --- --- The only intended use case for this is for segregated witness. -unsafeConstructTxWithBytes :: - Era era => - TxBody era -> - TxWits era -> - StrictMaybe (TxAuxData era) -> - LBS.ByteString -> - ShelleyTx era -unsafeConstructTxWithBytes b w a bytes = TxConstr (mkMemoBytes (ShelleyTxRaw b w a) bytes) - --------------------------------------------------------------------------------- --- Segregated witness --------------------------------------------------------------------------------- - -segwitTx :: - forall era. - EraTx era => - Annotator (TxBody era) -> - Annotator (TxWits era) -> - Maybe (Annotator (TxAuxData era)) -> - Annotator (ShelleyTx era) -segwitTx - bodyAnn - witsAnn - metaAnn = Annotator $ \bytes -> - let body' = runAnnotator bodyAnn bytes - witnessSet = runAnnotator witsAnn bytes - metadata = flip runAnnotator bytes <$> metaAnn - wrappedMetadataBytes = case metadata of - Nothing -> Plain.serialize Plain.encodeNull - Just b -> Plain.serialize b - fullBytes = - Plain.serialize (Plain.encodeListLen 3) - <> Plain.serialize body' - <> Plain.serialize witnessSet - <> wrappedMetadataBytes - in unsafeConstructTxWithBytes - body' - witnessSet - (maybeToStrictMaybe metadata) - fullBytes - --- =============================================================== - --- | Hashes native multi-signature script. -hashMultiSigScript :: - forall era. - ( EraScript era - , Script era ~ MultiSig (EraCrypto era) - ) => - MultiSig (EraCrypto era) -> - ScriptHash (EraCrypto era) -hashMultiSigScript = hashScript @era -{-# DEPRECATED hashMultiSigScript "In favor of `hashScript`" #-} - --- ======================================== - --- | Multi-signature script witness accessor function for Transactions -txwitsScript :: - EraTx era => - Tx era -> - Map (ScriptHash (EraCrypto era)) (Script era) -txwitsScript tx = tx ^. witsTxL . scriptTxWitsL -{-# DEPRECATED txwitsScript "In favor of `scriptTxWitsL`" #-} - --- | Minimum fee calculation -shelleyMinFeeTx :: EraTx era => PParams era -> Tx era -> Coin -shelleyMinFeeTx pp tx = - (tx ^. sizeTxF <×> pp ^. ppMinFeeAL) <+> pp ^. ppMinFeeBL - --- | Extract the witness hashes from the Transaction. -witsFromTxWitnesses :: - EraTx era => - Tx era -> - Set (KeyHash 'Witness (EraCrypto era)) -witsFromTxWitnesses tx = - Set.map witVKeyHash (tx ^. witsTxL . addrTxWitsL) - `Set.union` Set.map bootstrapWitKeyHash (tx ^. witsTxL . bootAddrTxWitsL) +import Cardano.Ledger.Shelley.Tx.Internal diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs new file mode 100644 index 00000000000..3290acae49a --- /dev/null +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Provides Shelley Tx internals +-- +-- = Warning +-- +-- This module is considered __internal__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +module Cardano.Ledger.Shelley.Tx.Internal ( + -- * Transaction + ShelleyTx ( + .., + ShelleyTx, + body, + wits, + auxiliaryData + ), + ShelleyTxRaw (..), + bodyShelleyTxL, + witsShelleyTxL, + auxDataShelleyTxL, + sizeShelleyTxF, + wireSizeShelleyTxF, + segwitTx, + mkBasicShelleyTx, + shelleyMinFeeTx, + witsFromTxWitnesses, + shelleyEqTxRaw, + + -- * Deprecated + txwitsScript, + hashMultiSigScript, +) +where + +import Cardano.Ledger.Binary ( + Annotator (..), + DecCBOR (decCBOR), + EncCBOR (encCBOR), + ToCBOR, + decodeNullMaybe, + encodeNullMaybe, + runAnnotator, + ) +import Cardano.Ledger.Binary.Coders +import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Coin (Coin) +import Cardano.Ledger.Core +import Cardano.Ledger.Crypto (Crypto, StandardCrypto) +import Cardano.Ledger.Keys (KeyHash, KeyRole (Witness)) +import Cardano.Ledger.Keys.Bootstrap (bootstrapWitKeyHash) +import Cardano.Ledger.Keys.WitVKey (witVKeyHash) +import Cardano.Ledger.MemoBytes ( + EqRaw (..), + Mem, + MemoBytes, + Memoized (..), + memoBytes, + mkMemoBytes, + pattern Memo, + ) +import Cardano.Ledger.SafeHash (SafeToHash (..)) +import Cardano.Ledger.Shelley.Era (ShelleyEra) +import Cardano.Ledger.Shelley.Scripts (MultiSig, validateMultiSig) +import Cardano.Ledger.Shelley.TxAuxData () +import Cardano.Ledger.Shelley.TxBody () +import Cardano.Ledger.Shelley.TxWits () +import Cardano.Ledger.Val ((<+>), (<×>)) +import Control.DeepSeq (NFData) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import Data.Functor.Classes (Eq1 (liftEq)) +import Data.Map.Strict (Map) +import Data.Maybe.Strict ( + StrictMaybe (..), + maybeToStrictMaybe, + strictMaybeToMaybe, + ) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (Typeable) +import Data.Word (Word32) +import GHC.Generics (Generic) +import Lens.Micro (Lens', SimpleGetter, lens, to, (^.)) +import NoThunks.Class (NoThunks (..)) + +-- ======================================================== + +data ShelleyTxRaw era = ShelleyTxRaw + { strBody :: !(TxBody era) + , strWits :: !(TxWits era) + , strAuxiliaryData :: !(StrictMaybe (TxAuxData era)) + } + deriving (Generic, Typeable) + +instance + ( NFData (TxBody era) + , NFData (TxWits era) + , NFData (TxAuxData era) + ) => + NFData (ShelleyTxRaw era) + +deriving instance + ( Era era + , Eq (TxBody era) + , Eq (TxWits era) + , Eq (TxAuxData era) + ) => + Eq (ShelleyTxRaw era) + +deriving instance + ( Era era + , Show (TxBody era) + , Show (TxWits era) + , Show (TxAuxData era) + ) => + Show (ShelleyTxRaw era) + +instance + ( Era era + , NoThunks (TxAuxData era) + , NoThunks (TxBody era) + , NoThunks (TxWits era) + ) => + NoThunks (ShelleyTxRaw era) + +newtype ShelleyTx era = TxConstr (MemoBytes ShelleyTxRaw era) + deriving newtype (SafeToHash, ToCBOR) + deriving (Generic) + +instance Memoized ShelleyTx where + type RawType ShelleyTx = ShelleyTxRaw + +-- | `TxBody` setter and getter for `ShelleyTx`. The setter does update +-- memoized binary representation. +bodyShelleyTxL :: EraTx era => Lens' (ShelleyTx era) (TxBody era) +bodyShelleyTxL = + lens (\(TxConstr (Memo tx _)) -> strBody tx) $ + \(TxConstr (Memo tx _)) txBody -> + TxConstr $ memoBytes $ encodeShelleyTxRaw $ tx {strBody = txBody} +{-# INLINEABLE bodyShelleyTxL #-} + +-- | `TxWits` setter and getter for `ShelleyTx`. The setter does update +-- memoized binary representation. +witsShelleyTxL :: EraTx era => Lens' (ShelleyTx era) (TxWits era) +witsShelleyTxL = + lens (\(TxConstr (Memo tx _)) -> strWits tx) $ + \(TxConstr (Memo tx _)) txWits -> + TxConstr $ memoBytes $ encodeShelleyTxRaw $ tx {strWits = txWits} +{-# INLINEABLE witsShelleyTxL #-} + +-- | `TxAuxData` setter and getter for `ShelleyTx`. The setter does update +-- memoized binary representation. +auxDataShelleyTxL :: EraTx era => Lens' (ShelleyTx era) (StrictMaybe (TxAuxData era)) +auxDataShelleyTxL = + lens (\(TxConstr (Memo tx _)) -> strAuxiliaryData tx) $ + \(TxConstr (Memo tx _)) auxData -> mkShelleyTx $ tx {strAuxiliaryData = auxData} +{-# INLINEABLE auxDataShelleyTxL #-} + +-- | Size getter for `ShelleyTx`. +sizeShelleyTxF :: Era era => SimpleGetter (ShelleyTx era) Integer +sizeShelleyTxF = to (\(TxConstr (Memo _ bytes)) -> fromIntegral $ SBS.length bytes) +{-# INLINEABLE sizeShelleyTxF #-} + +wireSizeShelleyTxF :: Era era => SimpleGetter (ShelleyTx era) Word32 +wireSizeShelleyTxF = to $ \(TxConstr (Memo _ bytes)) -> + let n = SBS.length bytes + in if n <= fromIntegral (maxBound :: Word32) + then fromIntegral n + else error $ "Impossible: Size of the transaction is too big: " ++ show n +{-# INLINEABLE wireSizeShelleyTxF #-} + +mkShelleyTx :: EraTx era => ShelleyTxRaw era -> ShelleyTx era +mkShelleyTx = TxConstr . memoBytes . encodeShelleyTxRaw +{-# INLINEABLE mkShelleyTx #-} + +mkBasicShelleyTx :: EraTx era => TxBody era -> ShelleyTx era +mkBasicShelleyTx txBody = + mkShelleyTx $ + ShelleyTxRaw + { strBody = txBody + , strWits = mkBasicTxWits + , strAuxiliaryData = SNothing + } + +instance Crypto c => EraTx (ShelleyEra c) where + {-# SPECIALIZE instance EraTx (ShelleyEra StandardCrypto) #-} + + type Tx (ShelleyEra c) = ShelleyTx (ShelleyEra c) + + mkBasicTx = mkBasicShelleyTx + + bodyTxL = bodyShelleyTxL + {-# INLINE bodyTxL #-} + + witsTxL = witsShelleyTxL + {-# INLINE witsTxL #-} + + auxDataTxL = auxDataShelleyTxL + {-# INLINE auxDataTxL #-} + + sizeTxF = sizeShelleyTxF + {-# INLINE sizeTxF #-} + + wireSizeTxF = wireSizeShelleyTxF + {-# INLINE wireSizeTxF #-} + + validateNativeScript = validateMultiSig + {-# INLINE validateNativeScript #-} + + getMinFeeTx pp tx _ = shelleyMinFeeTx pp tx + + upgradeTx = + error + "Calling this function will cause a compilation error, since there is no Tx instance for Byron" + +instance (Tx era ~ ShelleyTx era, EraTx era) => EqRaw (ShelleyTx era) where + eqRaw = shelleyEqTxRaw + +shelleyEqTxRaw :: EraTx era => Tx era -> Tx era -> Bool +shelleyEqTxRaw tx1 tx2 = + eqRaw (tx1 ^. bodyTxL) (tx2 ^. bodyTxL) + && eqRaw (tx1 ^. witsTxL) (tx2 ^. witsTxL) + && liftEq -- TODO: Implement Eq1 instance for StrictMaybe + eqRaw + (strictMaybeToMaybe (tx1 ^. auxDataTxL)) + (strictMaybeToMaybe (tx2 ^. auxDataTxL)) + +deriving newtype instance + ( NFData (TxBody era) + , NFData (TxWits era) + , NFData (TxAuxData era) + ) => + NFData (ShelleyTx era) + +deriving newtype instance + ( Era era + , Eq (TxBody era) + , Eq (TxWits era) + , Eq (TxAuxData era) + ) => + Eq (ShelleyTx era) + +deriving newtype instance + (Era era, Show (TxBody era), Show (TxWits era), Show (TxAuxData era)) => + Show (ShelleyTx era) + +deriving newtype instance + ( Era era + , NoThunks (TxAuxData era) + , NoThunks (TxBody era) + , NoThunks (TxWits era) + ) => + NoThunks (ShelleyTx era) + +pattern ShelleyTx :: + EraTx era => + TxBody era -> + TxWits era -> + StrictMaybe (TxAuxData era) -> + ShelleyTx era +pattern ShelleyTx {body, wits, auxiliaryData} <- + TxConstr + ( Memo + ShelleyTxRaw + { strBody = body + , strWits = wits + , strAuxiliaryData = auxiliaryData + } + _ + ) + where + ShelleyTx b w a = mkShelleyTx $ ShelleyTxRaw b w a + +{-# COMPLETE ShelleyTx #-} + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +encodeShelleyTxRaw :: + (EncCBOR (TxWits era), EncCBOR (TxBody era), EncCBOR (TxAuxData era)) => + ShelleyTxRaw era -> + Encode ('Closed 'Dense) (ShelleyTxRaw era) +encodeShelleyTxRaw ShelleyTxRaw {strBody, strWits, strAuxiliaryData} = + Rec ShelleyTxRaw + !> To strBody + !> To strWits + !> E (encodeNullMaybe encCBOR . strictMaybeToMaybe) strAuxiliaryData + +instance + (Era era, EncCBOR (TxWits era), EncCBOR (TxBody era), EncCBOR (TxAuxData era)) => + EncCBOR (ShelleyTxRaw era) + where + encCBOR = encode . encodeShelleyTxRaw + +-- | Encodes memoized bytes created upon construction. +instance Era era => EncCBOR (ShelleyTx era) + +instance + ( Era era + , DecCBOR (Annotator (TxBody era)) + , DecCBOR (Annotator (TxWits era)) + , DecCBOR (Annotator (TxAuxData era)) + ) => + DecCBOR (Annotator (ShelleyTxRaw era)) + where + decCBOR = + decode $ + Ann (RecD ShelleyTxRaw) + <*! From + <*! From + <*! D + ( sequence . maybeToStrictMaybe + <$> decodeNullMaybe decCBOR + ) + +deriving via + Mem ShelleyTxRaw era + instance + EraTx era => DecCBOR (Annotator (ShelleyTx era)) + +-- | Construct a Tx containing the explicit serialised bytes. +-- +-- This function is marked as unsafe since it makes no guarantee that the +-- represented bytes are indeed the correct serialisation of the transaction. +-- Thus, when calling this function, the caller is responsible for making this +-- guarantee. +-- +-- The only intended use case for this is for segregated witness. +unsafeConstructTxWithBytes :: + Era era => + TxBody era -> + TxWits era -> + StrictMaybe (TxAuxData era) -> + LBS.ByteString -> + ShelleyTx era +unsafeConstructTxWithBytes b w a bytes = TxConstr (mkMemoBytes (ShelleyTxRaw b w a) bytes) + +-------------------------------------------------------------------------------- +-- Segregated witness +-------------------------------------------------------------------------------- + +segwitTx :: + forall era. + EraTx era => + Annotator (TxBody era) -> + Annotator (TxWits era) -> + Maybe (Annotator (TxAuxData era)) -> + Annotator (ShelleyTx era) +segwitTx + bodyAnn + witsAnn + metaAnn = Annotator $ \bytes -> + let body' = runAnnotator bodyAnn bytes + witnessSet = runAnnotator witsAnn bytes + metadata = flip runAnnotator bytes <$> metaAnn + wrappedMetadataBytes = case metadata of + Nothing -> Plain.serialize Plain.encodeNull + Just b -> Plain.serialize b + fullBytes = + Plain.serialize (Plain.encodeListLen 3) + <> Plain.serialize body' + <> Plain.serialize witnessSet + <> wrappedMetadataBytes + in unsafeConstructTxWithBytes + body' + witnessSet + (maybeToStrictMaybe metadata) + fullBytes + +-- =============================================================== + +-- | Hashes native multi-signature script. +hashMultiSigScript :: + forall era. + ( EraScript era + , Script era ~ MultiSig (EraCrypto era) + ) => + MultiSig (EraCrypto era) -> + ScriptHash (EraCrypto era) +hashMultiSigScript = hashScript @era +{-# DEPRECATED hashMultiSigScript "In favor of `hashScript`" #-} + +-- ======================================== + +-- | Multi-signature script witness accessor function for Transactions +txwitsScript :: + EraTx era => + Tx era -> + Map (ScriptHash (EraCrypto era)) (Script era) +txwitsScript tx = tx ^. witsTxL . scriptTxWitsL +{-# DEPRECATED txwitsScript "In favor of `scriptTxWitsL`" #-} + +-- | Minimum fee calculation +shelleyMinFeeTx :: EraTx era => PParams era -> Tx era -> Coin +shelleyMinFeeTx pp tx = + (tx ^. sizeTxF <×> pp ^. ppMinFeeAL) <+> pp ^. ppMinFeeBL + +-- | Extract the witness hashes from the Transaction. +witsFromTxWitnesses :: + EraTx era => + Tx era -> + Set (KeyHash 'Witness (EraCrypto era)) +witsFromTxWitnesses tx = + Set.map witVKeyHash (tx ^. witsTxL . addrTxWitsL) + `Set.union` Set.map bootstrapWitKeyHash (tx ^. witsTxL . bootAddrTxWitsL) diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 1b239a67f22..1ff932901ea 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -49,6 +49,7 @@ library Cardano.Ledger.Keys.WitVKey Cardano.Ledger.Language Cardano.Ledger.MemoBytes + Cardano.Ledger.MemoBytes.Internal Cardano.Ledger.Metadata Cardano.Ledger.Orphans Cardano.Ledger.PoolDistr diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs index b2f8c5b972a..00473bb5c9e 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs @@ -1,23 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -- | MemoBytes is an abstraction for a data type that encodes its own serialization. -- The idea is to use a newtype around a MemoBytes applied to a non-memoizing type. -- For example: newtype Foo = Foo (`MemoBytes` NonMemoizingFoo) @@ -54,216 +34,4 @@ module Cardano.Ledger.MemoBytes ( ) where -import Cardano.Crypto.Hash (HashAlgorithm (hashAlgorithmName)) -import Cardano.Ledger.Binary ( - Annotator (..), - DecCBOR (decCBOR), - EncCBOR, - serialize, - withSlice, - ) -import Cardano.Ledger.Binary.Coders (Encode, encode, runE) -import qualified Cardano.Ledger.Binary.Plain as Plain -import Cardano.Ledger.Core.Era (Era (EraCrypto), eraProtVerLow) -import Cardano.Ledger.Crypto (HASH) -import Cardano.Ledger.SafeHash (SafeHash, SafeToHash (..)) -import Control.DeepSeq (NFData (..)) -import Data.ByteString.Lazy (fromStrict, toStrict) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy as Lazy -import Data.ByteString.Short (ShortByteString, fromShort, toShort) -import qualified Data.ByteString.Short as SBS (length) -import Data.Coerce -import Data.Typeable -import GHC.Base (Type) -import GHC.Generics (Generic) -import Lens.Micro -import NoThunks.Class (AllowThunksIn (..), NoThunks (..)) -import Prelude hiding (span) - --- ======================================================================== - --- | Pair together a type @t@ and its serialization. Used to encode a type --- that is serialized over the network, and to remember the original bytes --- that were used to transmit it. Important since hashes are computed --- from the serialization of a type, and EncCBOR instances do not have unique --- serializations. -data MemoBytes t era = Memo' - { mbRawType :: !(t era) - , mbBytes :: ShortByteString - , mbHash :: SafeHash (EraCrypto era) (MemoHashIndex t) - } - deriving (Generic) - deriving (NoThunks) via AllowThunksIn '["mbBytes", "mbHash"] (MemoBytes t era) - -pattern Memo :: Era era => t era -> ShortByteString -> MemoBytes t era -pattern Memo memoType memoBytes <- - Memo' memoType memoBytes _ - where - Memo mt mb = mkMemoBytes mt (shortToLazy mb) - -{-# COMPLETE Memo #-} - -type family MemoHashIndex (t :: Type -> Type) :: Type - -deriving instance NFData (t era) => NFData (MemoBytes t era) - -instance (Typeable t, Typeable era) => Plain.ToCBOR (MemoBytes t era) where - toCBOR (Memo' _ bytes _hash) = Plain.encodePreEncoded (fromShort bytes) - -instance - ( Typeable t - , DecCBOR (Annotator (t era)) - , Era era - ) => - DecCBOR (Annotator (MemoBytes t era)) - where - decCBOR = do - (Annotator getT, Annotator getBytes) <- withSlice decCBOR - pure (Annotator (\fullbytes -> mkMemoBytes (getT fullbytes) (getBytes fullbytes))) - --- | Both binary representation and Haskell types are compared. -instance Eq (t era) => Eq (MemoBytes t era) where - x == y = mbBytes x == mbBytes y && mbRawType x == mbRawType y - -instance (Show (t era), HashAlgorithm (HASH (EraCrypto era))) => Show (MemoBytes t era) where - show (Memo' y _ h) = - show y - <> " (" - <> hashAlgorithmName (Proxy :: Proxy (HASH (EraCrypto era))) - <> ": " - <> show h - <> ")" - -instance SafeToHash (MemoBytes t era) where - originalBytes = fromShort . mbBytes - originalBytesSize = SBS.length . mbBytes - --- | Turn a lazy bytestring into a short bytestring. -shorten :: Lazy.ByteString -> ShortByteString -shorten x = toShort (toStrict x) - --- | Useful when deriving DecCBOR(Annotator T) --- deriving via (Mem T) instance (Era era) => DecCBOR (Annotator T) -type Mem t era = Annotator (MemoBytes t era) - --- | Smart constructor -mkMemoBytes :: forall era t. Era era => t era -> BSL.ByteString -> MemoBytes t era -mkMemoBytes t bsl = - Memo' - t - (toShort bs) - (makeHashWithExplicitProxys (Proxy @(EraCrypto era)) (Proxy @(MemoHashIndex t)) bs) - where - bs = toStrict bsl - --- | Turn a MemoBytes into a string, Showing both its internal structure and its original bytes. --- Useful since the Show instance of MemoBytes does not display the original bytes. -showMemo :: Show (t era) => MemoBytes t era -> String -showMemo (Memo' t b _) = "(Memo " ++ show t ++ " " ++ show b ++ ")" - -printMemo :: Show (t era) => MemoBytes t era -> IO () -printMemo x = putStrLn (showMemo x) - --- | Create MemoBytes from its CBOR encoding -memoBytes :: forall era w t. Era era => Encode w (t era) -> MemoBytes t era -memoBytes t = mkMemoBytes (runE t) (serialize (eraProtVerLow @era) (encode t)) - --- | Helper function. Converts a short bytestring to a lazy bytestring. -shortToLazy :: ShortByteString -> BSL.ByteString -shortToLazy = fromStrict . fromShort - --- | Returns true if the contents of the MemoBytes are equal -contentsEq :: Eq (t era) => MemoBytes t era -> MemoBytes t era -> Bool -contentsEq x y = mbRawType x == mbRawType y - --- | Extract the inner type of the MemoBytes -getMemoBytesType :: MemoBytes t era -> t era -getMemoBytesType = mbRawType - --- | Extract the hash value of the binary representation of the MemoBytes -getMemoBytesHash :: MemoBytes t era -> SafeHash (EraCrypto era) (MemoHashIndex t) -getMemoBytesHash = mbHash - --- | Class that relates the actual type with its raw and byte representations -class Memoized t where - type RawType t = (r :: Type -> Type) | r -> t - - -- | This is a coercion from the memoized type to the MemoBytes. This implementation - -- cannot be changed since `getMemoBytes` is not exported, therefore it will only work - -- on newtypes around `MemoBytes` - getMemoBytes :: t era -> MemoBytes (RawType t) era - default getMemoBytes :: - Coercible (t era) (MemoBytes (RawType t) era) => - t era -> - MemoBytes (RawType t) era - getMemoBytes = coerce - - -- | This is a coercion from the MemoBytes to the momoized type. This implementation - -- cannot be changed since `warpMemoBytes` is not exported, therefore it will only work - -- on newtypes around `MemoBytes` - wrapMemoBytes :: MemoBytes (RawType t) era -> t era - default wrapMemoBytes :: - Coercible (MemoBytes (RawType t) era) (t era) => - MemoBytes (RawType t) era -> - t era - wrapMemoBytes = coerce - --- | Construct memoized type from the raw type using its EncCBOR instance -mkMemoized :: forall era t. (Era era, EncCBOR (RawType t era), Memoized t) => RawType t era -> t era -mkMemoized rawType = wrapMemoBytes (mkMemoBytes rawType (serialize (eraProtVerLow @era) rawType)) - --- | Extract memoized SafeHash -getMemoSafeHash :: Memoized t => t era -> SafeHash (EraCrypto era) (MemoHashIndex (RawType t)) -getMemoSafeHash t = mbHash (getMemoBytes t) - --- | Extract the raw type from the memoized version -getMemoRawType :: Memoized t => t era -> RawType t era -getMemoRawType t = mbRawType (getMemoBytes t) - --- | Extract the raw bytes from the memoized version -getMemoRawBytes :: Memoized t => t era -> ShortByteString -getMemoRawBytes t = mbBytes (getMemoBytes t) - --- | This is a helper function that operates on raw types of two memoized types. -zipMemoRawType :: - (Memoized t1, Memoized t2) => - (RawType t1 era -> RawType t2 era -> a) -> - t1 era -> - t2 era -> - a -zipMemoRawType f x y = f (getMemoRawType x) (getMemoRawType y) - -eqRawType :: - forall t era. - (Memoized t, Eq (RawType t era)) => - t era -> - t era -> - Bool -eqRawType = zipMemoRawType @t (==) - --- | This is a helper Lens creator for any Memoized type. -lensMemoRawType :: - (Era era, EncCBOR (RawType t era), Memoized t) => - (RawType t era -> a) -> - (RawType t era -> b -> RawType t era) -> - Lens (t era) (t era) a b -lensMemoRawType getter setter = - lens (getter . getMemoRawType) (\t v -> mkMemoized $ setter (getMemoRawType t) v) -{-# INLINEABLE lensMemoRawType #-} - --- | This is a helper SimpleGetter creator for any Memoized type -getterMemoRawType :: - Memoized t => - (RawType t era -> a) -> - SimpleGetter (t era) a -getterMemoRawType getter = - to (getter . getMemoRawType) -{-# INLINEABLE getterMemoRawType #-} - --- | Type class that implements equality on the Haskell type, ignoring any of the --- potentially memoized binary representation of the type. -class EqRaw a where - eqRaw :: a -> a -> Bool - default eqRaw :: (a ~ t era, Memoized t, Eq (RawType t era)) => a -> a -> Bool - eqRaw = eqRawType +import Cardano.Ledger.MemoBytes.Internal diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs new file mode 100644 index 00000000000..eeb12d0c9c0 --- /dev/null +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Provides MemoBytes internals +-- +-- = Warning +-- +-- This module is considered __internal__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +module Cardano.Ledger.MemoBytes.Internal ( + MemoBytes (.., Memo), + MemoHashIndex, + Mem, + mkMemoBytes, + getMemoBytesType, + getMemoBytesHash, + memoBytes, + shorten, + showMemo, + printMemo, + shortToLazy, + contentsEq, + + -- * Memoized + Memoized (RawType), + mkMemoized, + getMemoSafeHash, + getMemoRawType, + zipMemoRawType, + eqRawType, + getMemoRawBytes, + lensMemoRawType, + getterMemoRawType, + + -- * Raw equality + EqRaw (..), +) +where + +import Cardano.Crypto.Hash (HashAlgorithm (hashAlgorithmName)) +import Cardano.Ledger.Binary ( + Annotator (..), + DecCBOR (decCBOR), + EncCBOR, + serialize, + withSlice, + ) +import Cardano.Ledger.Binary.Coders (Encode, encode, runE) +import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Core.Era (Era (EraCrypto), eraProtVerLow) +import Cardano.Ledger.Crypto (HASH) +import Cardano.Ledger.SafeHash (SafeHash, SafeToHash (..)) +import Control.DeepSeq (NFData (..)) +import Data.ByteString.Lazy (fromStrict, toStrict) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy as Lazy +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import qualified Data.ByteString.Short as SBS (length) +import Data.Coerce +import Data.Typeable +import GHC.Base (Type) +import GHC.Generics (Generic) +import Lens.Micro +import NoThunks.Class (AllowThunksIn (..), NoThunks (..)) +import Prelude hiding (span) + +-- ======================================================================== + +-- | Pair together a type @t@ and its serialization. Used to encode a type +-- that is serialized over the network, and to remember the original bytes +-- that were used to transmit it. Important since hashes are computed +-- from the serialization of a type, and EncCBOR instances do not have unique +-- serializations. +data MemoBytes t era = Memo' + { mbRawType :: !(t era) + , mbBytes :: ShortByteString + , mbHash :: SafeHash (EraCrypto era) (MemoHashIndex t) + } + deriving (Generic) + deriving (NoThunks) via AllowThunksIn '["mbBytes", "mbHash"] (MemoBytes t era) + +pattern Memo :: Era era => t era -> ShortByteString -> MemoBytes t era +pattern Memo memoType memoBytes <- + Memo' memoType memoBytes _ + where + Memo mt mb = mkMemoBytes mt (shortToLazy mb) + +{-# COMPLETE Memo #-} + +type family MemoHashIndex (t :: Type -> Type) :: Type + +deriving instance NFData (t era) => NFData (MemoBytes t era) + +instance (Typeable t, Typeable era) => Plain.ToCBOR (MemoBytes t era) where + toCBOR (Memo' _ bytes _hash) = Plain.encodePreEncoded (fromShort bytes) + +instance + ( Typeable t + , DecCBOR (Annotator (t era)) + , Era era + ) => + DecCBOR (Annotator (MemoBytes t era)) + where + decCBOR = do + (Annotator getT, Annotator getBytes) <- withSlice decCBOR + pure (Annotator (\fullbytes -> mkMemoBytes (getT fullbytes) (getBytes fullbytes))) + +-- | Both binary representation and Haskell types are compared. +instance Eq (t era) => Eq (MemoBytes t era) where + x == y = mbBytes x == mbBytes y && mbRawType x == mbRawType y + +instance (Show (t era), HashAlgorithm (HASH (EraCrypto era))) => Show (MemoBytes t era) where + show (Memo' y _ h) = + show y + <> " (" + <> hashAlgorithmName (Proxy :: Proxy (HASH (EraCrypto era))) + <> ": " + <> show h + <> ")" + +instance SafeToHash (MemoBytes t era) where + originalBytes = fromShort . mbBytes + originalBytesSize = SBS.length . mbBytes + +-- | Turn a lazy bytestring into a short bytestring. +shorten :: Lazy.ByteString -> ShortByteString +shorten x = toShort (toStrict x) + +-- | Useful when deriving DecCBOR(Annotator T) +-- deriving via (Mem T) instance (Era era) => DecCBOR (Annotator T) +type Mem t era = Annotator (MemoBytes t era) + +-- | Smart constructor +mkMemoBytes :: forall era t. Era era => t era -> BSL.ByteString -> MemoBytes t era +mkMemoBytes t bsl = + Memo' + t + (toShort bs) + (makeHashWithExplicitProxys (Proxy @(EraCrypto era)) (Proxy @(MemoHashIndex t)) bs) + where + bs = toStrict bsl + +-- | Turn a MemoBytes into a string, Showing both its internal structure and its original bytes. +-- Useful since the Show instance of MemoBytes does not display the original bytes. +showMemo :: Show (t era) => MemoBytes t era -> String +showMemo (Memo' t b _) = "(Memo " ++ show t ++ " " ++ show b ++ ")" + +printMemo :: Show (t era) => MemoBytes t era -> IO () +printMemo x = putStrLn (showMemo x) + +-- | Create MemoBytes from its CBOR encoding +memoBytes :: forall era w t. Era era => Encode w (t era) -> MemoBytes t era +memoBytes t = mkMemoBytes (runE t) (serialize (eraProtVerLow @era) (encode t)) + +-- | Helper function. Converts a short bytestring to a lazy bytestring. +shortToLazy :: ShortByteString -> BSL.ByteString +shortToLazy = fromStrict . fromShort + +-- | Returns true if the contents of the MemoBytes are equal +contentsEq :: Eq (t era) => MemoBytes t era -> MemoBytes t era -> Bool +contentsEq x y = mbRawType x == mbRawType y + +-- | Extract the inner type of the MemoBytes +getMemoBytesType :: MemoBytes t era -> t era +getMemoBytesType = mbRawType + +-- | Extract the hash value of the binary representation of the MemoBytes +getMemoBytesHash :: MemoBytes t era -> SafeHash (EraCrypto era) (MemoHashIndex t) +getMemoBytesHash = mbHash + +-- | Class that relates the actual type with its raw and byte representations +class Memoized t where + type RawType t = (r :: Type -> Type) | r -> t + + -- | This is a coercion from the memoized type to the MemoBytes. This implementation + -- cannot be changed since `getMemoBytes` is not exported, therefore it will only work + -- on newtypes around `MemoBytes` + getMemoBytes :: t era -> MemoBytes (RawType t) era + default getMemoBytes :: + Coercible (t era) (MemoBytes (RawType t) era) => + t era -> + MemoBytes (RawType t) era + getMemoBytes = coerce + + -- | This is a coercion from the MemoBytes to the momoized type. This implementation + -- cannot be changed since `warpMemoBytes` is not exported, therefore it will only work + -- on newtypes around `MemoBytes` + wrapMemoBytes :: MemoBytes (RawType t) era -> t era + default wrapMemoBytes :: + Coercible (MemoBytes (RawType t) era) (t era) => + MemoBytes (RawType t) era -> + t era + wrapMemoBytes = coerce + +-- | Construct memoized type from the raw type using its EncCBOR instance +mkMemoized :: forall era t. (Era era, EncCBOR (RawType t era), Memoized t) => RawType t era -> t era +mkMemoized rawType = wrapMemoBytes (mkMemoBytes rawType (serialize (eraProtVerLow @era) rawType)) + +-- | Extract memoized SafeHash +getMemoSafeHash :: Memoized t => t era -> SafeHash (EraCrypto era) (MemoHashIndex (RawType t)) +getMemoSafeHash t = mbHash (getMemoBytes t) + +-- | Extract the raw type from the memoized version +getMemoRawType :: Memoized t => t era -> RawType t era +getMemoRawType t = mbRawType (getMemoBytes t) + +-- | Extract the raw bytes from the memoized version +getMemoRawBytes :: Memoized t => t era -> ShortByteString +getMemoRawBytes t = mbBytes (getMemoBytes t) + +-- | This is a helper function that operates on raw types of two memoized types. +zipMemoRawType :: + (Memoized t1, Memoized t2) => + (RawType t1 era -> RawType t2 era -> a) -> + t1 era -> + t2 era -> + a +zipMemoRawType f x y = f (getMemoRawType x) (getMemoRawType y) + +eqRawType :: + forall t era. + (Memoized t, Eq (RawType t era)) => + t era -> + t era -> + Bool +eqRawType = zipMemoRawType @t (==) + +-- | This is a helper Lens creator for any Memoized type. +lensMemoRawType :: + (Era era, EncCBOR (RawType t era), Memoized t) => + (RawType t era -> a) -> + (RawType t era -> b -> RawType t era) -> + Lens (t era) (t era) a b +lensMemoRawType getter setter = + lens (getter . getMemoRawType) (\t v -> mkMemoized $ setter (getMemoRawType t) v) +{-# INLINEABLE lensMemoRawType #-} + +-- | This is a helper SimpleGetter creator for any Memoized type +getterMemoRawType :: + Memoized t => + (RawType t era -> a) -> + SimpleGetter (t era) a +getterMemoRawType getter = + to (getter . getMemoRawType) +{-# INLINEABLE getterMemoRawType #-} + +-- | Type class that implements equality on the Haskell type, ignoring any of the +-- potentially memoized binary representation of the type. +class EqRaw a where + eqRaw :: a -> a -> Bool + default eqRaw :: (a ~ t era, Memoized t, Eq (RawType t era)) => a -> a -> Bool + eqRaw = eqRawType