profile
viewpoint
Alexey Kuleshevich lehins @input-output-hk Minsk, Belarus https://alexey.kuleshevi.ch Software Engineer at IOHK

haskell/vector 317

An efficient implementation of Int-indexed arrays (both mutable and immutable), with a powerful loop optimisation framework .

lehins/Color 53

Extensive collection of color spaces and color models

input-output-hk/cardano-base 44

Code used throughout the Cardano eco-system

idontgetoutmuch/random 4

Random number library

commercialhaskell/all-cabal-tool 3

Update the various all-cabal-* repos

ChristinaKuleshevich/ZooFriend 1

Mobile application "ZooДруг"

PR merged input-output-hk/cardano-ledger

Reviewers
Sharing of values during deserialization

This is an alternative approach to the one implemented in #2548

Applied sharing to all places possible in EpochState, including TxOuts in the UTxO. These are the results we get:

Case                                 Max          MaxOS           Live        Allocated      GCs
EpochState (FromCBOR)      1,199,503,544  3,557,818,368  1,199,503,544   70,260,877,216   63,501
EpochState (no-sharing)    1,970,142,176  4,795,138,048  1,910,834,120  408,093,302,920  388,393
+712 -238

1 comment

27 changed files

lehins

pr closed time in a day

push eventinput-output-hk/cardano-ledger

TimSheard

commit sha 71f62639fdfcfe05271d2bdc0443d68efc3abbc0

Sharing during CBOR deserialization: * Added the Cardano.Ledger.Sharing module * This supports sharing when deserializing. Made changes to share `Credential 'Staking crypto` and `KeyHash 'StakePool crypto` in `EpochState` * Add shring to `NonMyopic` * Benchmark EpochState sharing * Avoid order of arguments with NamedFieldPuns in serialization * Simplify `FromSharedCBOR` by removing `StateT` from `fromSharedCBOR` * Apply sharing to `TxOut`

view details

Alexey Kuleshevich

commit sha 4e2d082d3a01d8a172d0659b9c6d7f56689570ca

Merge pull request #2557 from input-output-hk/lehins/sharing Sharing of values during deserialization

view details

push time in a day

PR closed haskell-hvr/missingh

Remove unused dependency: random

random package is not used. Removing it from cabal. A new version with such change would be greatly appreciated too.

+0 -1

2 comments

1 changed file

lehins

pr closed time in a day

pull request commenthaskell-hvr/missingh

Remove unused dependency: random

That works too. Thanks

lehins

comment created time in a day

push eventinput-output-hk/cardano-ledger

TimSheard

commit sha 71f62639fdfcfe05271d2bdc0443d68efc3abbc0

Sharing during CBOR deserialization: * Added the Cardano.Ledger.Sharing module * This supports sharing when deserializing. Made changes to share `Credential 'Staking crypto` and `KeyHash 'StakePool crypto` in `EpochState` * Add shring to `NonMyopic` * Benchmark EpochState sharing * Avoid order of arguments with NamedFieldPuns in serialization * Simplify `FromSharedCBOR` by removing `StateT` from `fromSharedCBOR` * Apply sharing to `TxOut`

view details

push time in a day

push eventinput-output-hk/cardano-ledger

whatisRT

commit sha fd34e0edb29ab94e242b440427168e1f815e8381

Babbage spec: first draft

view details

Tim Sheard

commit sha 13c53f5df93c64189952cb698cac6c5909368935

Added property tests for the KeyMap data structure. (#2552)

view details

Tim Sheard

commit sha ccaecc8029644fdda9190410680975dccd31b648

Reorganized SetAlgebra by breaking it into 4 modules. (#2564) * Reorganized SetAlgebra by breaking it into 4 modules. New ones are Control.Iterate.BaseTypes, Control.Iterate.Exp, and Control.Iterate.BiMap * fixed a revertion of PRs: #2563

view details

Jared Corduan

commit sha a03621a4526d8afa0a0ea9cad6c089989def1c3e

babbage makefile

view details

Jared Corduan

commit sha 2b079053e0d16d3ac004934cc9897c8081d10088

Merge pull request #2559 from input-output-hk/andre/babbage Babbage spec: first draft

view details

TimSheard

commit sha e400ad73ff5e1c48eb9a08ceb5d58b6798a51dbe

Sharing during CBOR deserialization: * Added the Cardano.Ledger.Sharing module * This supports sharing when deserializing. Made changes to share `Credential 'Staking crypto` and `KeyHash 'StakePool crypto` in `EpochState` * Add shring to `NonMyopic` * Benchmark EpochState sharing * Avoid order of arguments with NamedFieldPuns in serialization * Simplify `FromSharedCBOR` by removing `StateT` from `fromSharedCBOR` * Apply sharing to `TxOut`

view details

push time in a day

push eventinput-output-hk/cardano-ledger

Alexey Kuleshevich

commit sha 47284b84a0482a49188456720e66decb6ba24372

Update libs/small-steps/src/Data/Sharing.hs Co-authored-by: Nicholas Clarke <nicholas.clarke@iohk.io>

view details

push time in 2 days

push eventinput-output-hk/cardano-ledger

Alexey Kuleshevich

commit sha 3566e48ab9dd8b871788f5a948e36afa649a8519

Update libs/small-steps/src/Data/Sharing.hs Co-authored-by: Nicholas Clarke <nicholas.clarke@iohk.io>

view details

push time in 2 days

push eventinput-output-hk/cardano-ledger

Alexey Kuleshevich

commit sha 26b4f658d57d92977e0f3f203d6adbf742aaf9eb

Update libs/small-steps/src/Data/Sharing.hs Co-authored-by: Nicholas Clarke <nicholas.clarke@iohk.io>

view details

push time in 2 days

push eventinput-output-hk/cardano-ledger

Alexey Kuleshevich

commit sha 3fc9b124c024d47d23b840effdc458682fdcfcc9

Update libs/ledger-state/app/Main.hs Co-authored-by: Nicholas Clarke <nicholas.clarke@iohk.io>

view details

push time in 2 days

PullRequestReviewEvent

Pull request review commentinput-output-hk/cardano-ledger

Babbage: TxBody + TxOut

+{-# 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 ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Cardano.Ledger.Babbage.TxBody+  ( TxOut (TxOut, TxOutCompact, TxOutCompactDH, TxOutCompactDatum),+    TxBody+      ( TxBody,+        inputs,+        collateral,+        collateralReturn,+        outputs,+        txcerts,+        txwdrls,+        txfee,+        txvldt,+        txUpdates,+        reqSignerHashes,+        mint,+        scriptIntegrityHash,+        adHash,+        txnetworkid+      ),+    inputs',+    collateral',+    collateralReturn',+    outputs',+    certs',+    wdrls',+    txfee',+    vldt',+    update',+    reqSignerHashes',+    mint',+    scriptIntegrityHash',+    adHash',+    txnetworkid',+    AlonzoBody,+    EraIndependentScriptIntegrity,+    ScriptIntegrityHash,+  )+where++import Cardano.Binary+  ( DecoderError (..),+    FromCBOR (..),+    ToCBOR (..),+    decodeBreakOr,+    decodeListLenOrIndef,+    encodeListLen,+  )+import Cardano.Crypto.Hash+import Cardano.Ledger.Address (Addr (..))+import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash (..), Data, DataHash, hashData)+import Cardano.Ledger.Alonzo.TxBody (decodeAddress28, decodeDataHash32, encodeAddress28, encodeDataHash32, getAdaOnly)+import Cardano.Ledger.BaseTypes+  ( Network (..),+    StrictMaybe (..),+    isSNothing,+  )+import Cardano.Ledger.Coin (Coin (..))+import Cardano.Ledger.Compactible+import Cardano.Ledger.Core (PParamsDelta)+import qualified Cardano.Ledger.Core as Core+import Cardano.Ledger.Credential (Credential (..), StakeReference (..))+import qualified Cardano.Ledger.Crypto as CC+import Cardano.Ledger.Era (Crypto, Era)+import Cardano.Ledger.Hashes+  ( EraIndependentScriptIntegrity,+    EraIndependentTxBody,+  )+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))+import Cardano.Ledger.Mary.Value (Value (..), policies, policyID)+import qualified Cardano.Ledger.Mary.Value as Mary+import Cardano.Ledger.SafeHash+  ( HashAnnotated,+    SafeHash,+    SafeToHash,+  )+import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr, decompactAddr)+import Cardano.Ledger.Shelley.Delegation.Certificates (DCert)+import Cardano.Ledger.Shelley.PParams (Update)+import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))+import Cardano.Ledger.Shelley.TxBody (Wdrl (Wdrl), unWdrl)+import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))+import Cardano.Ledger.TxIn (TxIn (..))+import Cardano.Ledger.Val+  ( DecodeNonNegative,+    Val (..),+    decodeMint,+    decodeNonNegative,+    encodeMint,+    isZero,+  )+import Data.Coders+import Data.Maybe (fromMaybe)+import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)+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 (Proxy (..), Typeable, (:~:) (Refl))+import Data.Word+import GHC.Generics (Generic)+import GHC.Records (HasField (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits+import NoThunks.Class (InspectHeapNamed (..), NoThunks)+import Prelude hiding (lookup)++data TxOut era+  = TxOutCompact+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+  | TxOutCompactDH+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(DataHash (Crypto era))+  | TxOutCompactDatum+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(Data era)+  | TxOut_AddrHash28_AdaOnly+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+  | TxOut_AddrHash28_AdaOnly_DataHash32+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash++deriving stock instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  Eq (TxOut era)++viewCompactTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (CompactAddr (Crypto era), CompactForm (Core.Value era), StrictMaybe (DataHash (Crypto era)))+viewCompactTxOut txOut = case txOut of+  TxOutCompact addr val -> (addr, val, SNothing)+  TxOutCompactDH addr val dh -> (addr, val, SJust dh)+  TxOutCompactDatum addr val datum -> (addr, val, SJust $ hashData datum)+  TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      (compactAddr (decodeAddress28 stakeRef a b c d), toCompactValue adaVal, SNothing)+  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+      Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      ( compactAddr (decodeAddress28 stakeRef a b c d),+        toCompactValue adaVal,+        SJust (decodeDataHash32 e f g h)+      )+  TxOut_AddrHash28_AdaOnly {} -> error "Impossible: Compacted and address or hash of non-standard size"+  TxOut_AddrHash28_AdaOnly_DataHash32 {} -> error "Impossible: Compacted and address or hash of non-standard size"+  where+    toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)+    toCompactValue ada =+      fromMaybe (error "Failed to compact a `Coin` as `CompactForm (Core.Value era)`")+        . toCompact+        . inject+        $ fromCompact ada++viewTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (Addr (Crypto era), Core.Value era, StrictMaybe (DataHash (Crypto era)))+viewTxOut (TxOutCompact bs c) = (addr, val, SNothing)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDH bs c dh) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDatum bs c datum) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+    dh = hashData datum+viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SNothing)+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+    Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))+viewTxOut (TxOut_AddrHash28_AdaOnly {}) = error "Impossible: Compacted and address or hash of non-standard size"+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 {}) = error "Impossible: Compacted and address or hash of non-standard size"++instance+  ( Era era,+    Show (Core.Value era),+    Show (CompactForm (Core.Value era))+  ) =>+  Show (TxOut era)+  where+  show = show . viewTxOut++deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era)++pattern TxOut ::+  forall era.+  ( Era era,+    Compactible (Core.Value era),+    Val (Core.Value era),+    HasCallStack+  ) =>+  Addr (Crypto era) ->+  Core.Value era ->+  StrictMaybe (DataHash (Crypto era)) ->+  TxOut era+pattern TxOut addr vl dh <-

This doesn't make sense. How anyone would ever construct a TxOut with Data? If I had to guess this should be something like this instead:

  Addr (Crypto era) ->
  Core.Value era ->
  Either (DataHash (Crypto era)) (Data era) ->
  TxOut era
pattern TxOut addr vl ed <-
goolord

comment created time in 2 days

Pull request review commentinput-output-hk/cardano-ledger

Babbage: TxBody + TxOut

+{-# 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 ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Cardano.Ledger.Babbage.TxBody+  ( TxOut (TxOut, TxOutCompact, TxOutCompactDH, TxOutCompactDatum),+    TxBody+      ( TxBody,+        inputs,+        collateral,+        collateralReturn,+        outputs,+        txcerts,+        txwdrls,+        txfee,+        txvldt,+        txUpdates,+        reqSignerHashes,+        mint,+        scriptIntegrityHash,+        adHash,+        txnetworkid+      ),+    inputs',+    collateral',+    collateralReturn',+    outputs',+    certs',+    wdrls',+    txfee',+    vldt',+    update',+    reqSignerHashes',+    mint',+    scriptIntegrityHash',+    adHash',+    txnetworkid',+    AlonzoBody,+    EraIndependentScriptIntegrity,+    ScriptIntegrityHash,+  )+where++import Cardano.Binary+  ( DecoderError (..),+    FromCBOR (..),+    ToCBOR (..),+    decodeBreakOr,+    decodeListLenOrIndef,+    encodeListLen,+  )+import Cardano.Crypto.Hash+import Cardano.Ledger.Address (Addr (..))+import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash (..), Data, DataHash, hashData)+import Cardano.Ledger.Alonzo.TxBody (decodeAddress28, decodeDataHash32, encodeAddress28, encodeDataHash32, getAdaOnly)+import Cardano.Ledger.BaseTypes+  ( Network (..),+    StrictMaybe (..),+    isSNothing,+  )+import Cardano.Ledger.Coin (Coin (..))+import Cardano.Ledger.Compactible+import Cardano.Ledger.Core (PParamsDelta)+import qualified Cardano.Ledger.Core as Core+import Cardano.Ledger.Credential (Credential (..), StakeReference (..))+import qualified Cardano.Ledger.Crypto as CC+import Cardano.Ledger.Era (Crypto, Era)+import Cardano.Ledger.Hashes+  ( EraIndependentScriptIntegrity,+    EraIndependentTxBody,+  )+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))+import Cardano.Ledger.Mary.Value (Value (..), policies, policyID)+import qualified Cardano.Ledger.Mary.Value as Mary+import Cardano.Ledger.SafeHash+  ( HashAnnotated,+    SafeHash,+    SafeToHash,+  )+import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr, decompactAddr)+import Cardano.Ledger.Shelley.Delegation.Certificates (DCert)+import Cardano.Ledger.Shelley.PParams (Update)+import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))+import Cardano.Ledger.Shelley.TxBody (Wdrl (Wdrl), unWdrl)+import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))+import Cardano.Ledger.TxIn (TxIn (..))+import Cardano.Ledger.Val+  ( DecodeNonNegative,+    Val (..),+    decodeMint,+    decodeNonNegative,+    encodeMint,+    isZero,+  )+import Data.Coders+import Data.Maybe (fromMaybe)+import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)+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 (Proxy (..), Typeable, (:~:) (Refl))+import Data.Word+import GHC.Generics (Generic)+import GHC.Records (HasField (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits+import NoThunks.Class (InspectHeapNamed (..), NoThunks)+import Prelude hiding (lookup)++data TxOut era+  = TxOutCompact+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+  | TxOutCompactDH+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(DataHash (Crypto era))+  | TxOutCompactDatum+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(Data era)+  | TxOut_AddrHash28_AdaOnly+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+  | TxOut_AddrHash28_AdaOnly_DataHash32+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash++deriving stock instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  Eq (TxOut era)++viewCompactTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (CompactAddr (Crypto era), CompactForm (Core.Value era), StrictMaybe (DataHash (Crypto era)))+viewCompactTxOut txOut = case txOut of+  TxOutCompact addr val -> (addr, val, SNothing)+  TxOutCompactDH addr val dh -> (addr, val, SJust dh)+  TxOutCompactDatum addr val datum -> (addr, val, SJust $ hashData datum)+  TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      (compactAddr (decodeAddress28 stakeRef a b c d), toCompactValue adaVal, SNothing)+  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+      Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      ( compactAddr (decodeAddress28 stakeRef a b c d),+        toCompactValue adaVal,+        SJust (decodeDataHash32 e f g h)+      )+  TxOut_AddrHash28_AdaOnly {} -> error "Impossible: Compacted and address or hash of non-standard size"+  TxOut_AddrHash28_AdaOnly_DataHash32 {} -> error "Impossible: Compacted and address or hash of non-standard size"+  where+    toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)+    toCompactValue ada =+      fromMaybe (error "Failed to compact a `Coin` as `CompactForm (Core.Value era)`")+        . toCompact+        . inject+        $ fromCompact ada++viewTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (Addr (Crypto era), Core.Value era, StrictMaybe (DataHash (Crypto era)))+viewTxOut (TxOutCompact bs c) = (addr, val, SNothing)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDH bs c dh) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDatum bs c datum) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+    dh = hashData datum+viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SNothing)+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+    Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))+viewTxOut (TxOut_AddrHash28_AdaOnly {}) = error "Impossible: Compacted and address or hash of non-standard size"+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 {}) = error "Impossible: Compacted and address or hash of non-standard size"++instance+  ( Era era,+    Show (Core.Value era),+    Show (CompactForm (Core.Value era))+  ) =>+  Show (TxOut era)+  where+  show = show . viewTxOut++deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era)++pattern TxOut ::+  forall era.+  ( Era era,+    Compactible (Core.Value era),+    Val (Core.Value era),+    HasCallStack+  ) =>+  Addr (Crypto era) ->+  Core.Value era ->+  StrictMaybe (DataHash (Crypto era)) ->+  TxOut era+pattern TxOut addr vl dh <-+  (viewTxOut -> (addr, vl, dh))+  where+    TxOut (Addr network paymentCred stakeRef) vl SNothing+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred =+        TxOut_AddrHash28_AdaOnly stakeCred a b c d adaCompact+    TxOut (Addr network paymentCred stakeRef) vl (SJust dh)+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred,+        Just (Refl, e, f, g, h) <- encodeDataHash32 dh =+        TxOut_AddrHash28_AdaOnly_DataHash32 stakeCred a b c d adaCompact e f g h+    TxOut addr vl mdh =+      let v = fromMaybe (error "Illegal value in txout") $ toCompact vl+          a = compactAddr addr+       in case mdh of+            SNothing -> TxOutCompact a v+            SJust dh -> TxOutCompactDH a v dh++{-# COMPLETE TxOut #-}++-- ======================================++type ScriptIntegrityHash crypto = SafeHash crypto EraIndependentScriptIntegrity++data TxBodyRaw era = TxBodyRaw+  { _inputs :: !(Set (TxIn (Crypto era))),+    _collateral :: !(Set (TxIn (Crypto era))),+    _collateralReturn :: !(StrictMaybe (TxOut era)),+    _outputs :: !(StrictSeq (TxOut era)),+    _certs :: !(StrictSeq (DCert (Crypto era))),+    _wdrls :: !(Wdrl (Crypto era)),+    _txfee :: !Coin,+    _vldt :: !ValidityInterval,+    _update :: !(StrictMaybe (Update era)),+    _reqSignerHashes :: Set (KeyHash 'Witness (Crypto era)),+    _mint :: !(Value (Crypto era)),+    -- The spec makes it clear that the mint field is a+    -- Cardano.Ledger.Mary.Value.Value, not a Core.Value.+    -- Operations on the TxBody in the AlonzoEra depend upon this.+    _scriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (Crypto era))),+    _adHash :: !(StrictMaybe (AuxiliaryDataHash (Crypto era))),+    _txnetworkid :: !(StrictMaybe Network)+  }+  deriving (Generic, Typeable)++deriving instance+  ( Eq (Core.Value era),+    CC.Crypto (Crypto era),+    Compactible (Core.Value era),+    Eq (PParamsDelta era)+  ) =>+  Eq (TxBodyRaw era)++instance+  (Typeable era, NoThunks (Core.Value era), NoThunks (PParamsDelta era)) =>+  NoThunks (TxBodyRaw era)++deriving instance+  ( Era era,+    Show (Core.Value era),+    Show (PParamsDelta era)+  ) =>+  Show (TxBodyRaw era)++newtype TxBody era = TxBodyConstr (MemoBytes (TxBodyRaw era))+  deriving (ToCBOR)+  deriving newtype (SafeToHash)++deriving newtype instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era),+    CC.Crypto (Crypto era),+    Eq (PParamsDelta era)+  ) =>+  Eq (TxBody era)++deriving instance+  ( Typeable era,+    NoThunks (Core.Value era),+    NoThunks (PParamsDelta era)+  ) =>+  NoThunks (TxBody era)++deriving instance+  ( Era era,+    Compactible (Core.Value era),+    Show (Core.Value era),+    Show (PParamsDelta era)+  ) =>+  Show (TxBody era)++deriving via+  (Mem (TxBodyRaw era))+  instance+    ( Era era,+      Typeable (Core.Script era),+      Typeable (Core.AuxiliaryData era),+      Compactible (Core.Value era),+      Show (Core.Value era),+      DecodeNonNegative (Core.Value era),+      FromCBOR (Annotator (Core.Script era)),+      Core.SerialisableData (PParamsDelta era)+    ) =>+    FromCBOR (Annotator (TxBody era))++-- The Set of constraints necessary to use the TxBody pattern+type AlonzoBody era =+  ( Era era,+    Compactible (Core.Value era),+    ToCBOR (Core.Script era),+    Core.SerialisableData (PParamsDelta era)+  )++pattern TxBody ::+  AlonzoBody era =>+  Set (TxIn (Crypto era)) ->+  Set (TxIn (Crypto era)) ->+  StrictMaybe (TxOut era) ->+  StrictSeq (TxOut era) ->+  StrictSeq (DCert (Crypto era)) ->+  Wdrl (Crypto era) ->+  Coin ->+  ValidityInterval ->+  StrictMaybe (Update era) ->+  Set (KeyHash 'Witness (Crypto era)) ->+  Value (Crypto era) ->+  StrictMaybe (ScriptIntegrityHash (Crypto era)) ->+  StrictMaybe (AuxiliaryDataHash (Crypto era)) ->+  StrictMaybe Network ->+  TxBody era+pattern TxBody+  { inputs,+    collateral,+    collateralReturn,+    outputs,+    txcerts,+    txwdrls,+    txfee,+    txvldt,+    txUpdates,+    reqSignerHashes,+    mint,+    scriptIntegrityHash,+    adHash,+    txnetworkid+  } <-+  TxBodyConstr+    ( Memo+        TxBodyRaw+          { _inputs = inputs,+            _collateral = collateral,+            _collateralReturn = collateralReturn,+            _outputs = outputs,+            _certs = txcerts,+            _wdrls = txwdrls,+            _txfee = txfee,+            _vldt = txvldt,+            _update = txUpdates,+            _reqSignerHashes = reqSignerHashes,+            _mint = mint,+            _scriptIntegrityHash = scriptIntegrityHash,+            _adHash = adHash,+            _txnetworkid = txnetworkid+          }+        _+      )+  where+    TxBody+      inputsX+      collateralX+      collateralReturnX+      outputsX+      certsX+      wdrlsX+      txfeeX+      vldtX+      updateX+      reqSignerHashesX+      mintX+      scriptIntegrityHashX+      adHashX+      txnetworkidX =+        TxBodyConstr $+          memoBytes+            ( encodeTxBodyRaw $+                TxBodyRaw+                  inputsX+                  collateralX+                  collateralReturnX+                  outputsX+                  certsX+                  wdrlsX+                  txfeeX+                  vldtX+                  updateX+                  reqSignerHashesX+                  mintX+                  scriptIntegrityHashX+                  adHashX+                  txnetworkidX+            )++{-# COMPLETE TxBody #-}++instance (c ~ Crypto era) => HashAnnotated (TxBody era) EraIndependentTxBody c++-- ==============================================================================+-- 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' :: TxBody era -> Set (TxIn (Crypto era))+collateral' :: TxBody era -> Set (TxIn (Crypto era))+collateralReturn' :: TxBody era -> StrictMaybe (TxOut era)+outputs' :: TxBody era -> StrictSeq (TxOut era)+certs' :: TxBody era -> StrictSeq (DCert (Crypto era))+txfee' :: TxBody era -> Coin+wdrls' :: TxBody era -> Wdrl (Crypto era)+vldt' :: TxBody era -> ValidityInterval+update' :: TxBody era -> StrictMaybe (Update era)+reqSignerHashes' :: TxBody era -> Set (KeyHash 'Witness (Crypto era))+adHash' :: TxBody era -> StrictMaybe (AuxiliaryDataHash (Crypto era))+mint' :: TxBody era -> Value (Crypto era)+scriptIntegrityHash' :: TxBody era -> StrictMaybe (ScriptIntegrityHash (Crypto era))+inputs' (TxBodyConstr (Memo raw _)) = _inputs raw++txnetworkid' :: TxBody era -> StrictMaybe Network++collateral' (TxBodyConstr (Memo raw _)) = _collateral raw++collateralReturn' (TxBodyConstr (Memo raw _)) = _collateralReturn raw++outputs' (TxBodyConstr (Memo raw _)) = _outputs raw++certs' (TxBodyConstr (Memo raw _)) = _certs raw++wdrls' (TxBodyConstr (Memo raw _)) = _wdrls raw++txfee' (TxBodyConstr (Memo raw _)) = _txfee raw++vldt' (TxBodyConstr (Memo raw _)) = _vldt raw++update' (TxBodyConstr (Memo raw _)) = _update raw++reqSignerHashes' (TxBodyConstr (Memo raw _)) = _reqSignerHashes raw++adHash' (TxBodyConstr (Memo raw _)) = _adHash raw++mint' (TxBodyConstr (Memo raw _)) = _mint raw++scriptIntegrityHash' (TxBodyConstr (Memo raw _)) = _scriptIntegrityHash raw++txnetworkid' (TxBodyConstr (Memo raw _)) = _txnetworkid raw++--------------------------------------------------------------------------------+-- Serialisation+--------------------------------------------------------------------------------++instance+  ( Era era,+    Compactible (Core.Value era)+  ) =>+  ToCBOR (TxOut era)+  where+  toCBOR (TxOutCompact addr cv) =+    encodeListLen 2+      <> toCBOR addr+      <> toCBOR cv+  toCBOR (TxOutCompactDH addr cv dh) =+    encodeListLen 3+      <> toCBOR addr+      <> toCBOR cv+      <> toCBOR dh+  toCBOR x =+    let (addr, cv, dh) = viewCompactTxOut x+     in encodeListLen 3+          <> toCBOR addr+          <> toCBOR cv+          <> toCBOR dh

Serialization of TxOutCompactDatum is missing

goolord

comment created time in 2 days

Pull request review commentinput-output-hk/cardano-ledger

Babbage: TxBody + TxOut

+{-# 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 ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Cardano.Ledger.Babbage.TxBody+  ( TxOut (TxOut, TxOutCompact, TxOutCompactDH, TxOutCompactDatum),+    TxBody+      ( TxBody,+        inputs,+        collateral,+        collateralReturn,+        outputs,+        txcerts,+        txwdrls,+        txfee,+        txvldt,+        txUpdates,+        reqSignerHashes,+        mint,+        scriptIntegrityHash,+        adHash,+        txnetworkid+      ),+    inputs',+    collateral',+    collateralReturn',+    outputs',+    certs',+    wdrls',+    txfee',+    vldt',+    update',+    reqSignerHashes',+    mint',+    scriptIntegrityHash',+    adHash',+    txnetworkid',+    AlonzoBody,+    EraIndependentScriptIntegrity,+    ScriptIntegrityHash,+  )+where++import Cardano.Binary+  ( DecoderError (..),+    FromCBOR (..),+    ToCBOR (..),+    decodeBreakOr,+    decodeListLenOrIndef,+    encodeListLen,+  )+import Cardano.Crypto.Hash+import Cardano.Ledger.Address (Addr (..))+import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash (..), Data, DataHash, hashData)+import Cardano.Ledger.Alonzo.TxBody (decodeAddress28, decodeDataHash32, encodeAddress28, encodeDataHash32, getAdaOnly)+import Cardano.Ledger.BaseTypes+  ( Network (..),+    StrictMaybe (..),+    isSNothing,+  )+import Cardano.Ledger.Coin (Coin (..))+import Cardano.Ledger.Compactible+import Cardano.Ledger.Core (PParamsDelta)+import qualified Cardano.Ledger.Core as Core+import Cardano.Ledger.Credential (Credential (..), StakeReference (..))+import qualified Cardano.Ledger.Crypto as CC+import Cardano.Ledger.Era (Crypto, Era)+import Cardano.Ledger.Hashes+  ( EraIndependentScriptIntegrity,+    EraIndependentTxBody,+  )+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))+import Cardano.Ledger.Mary.Value (Value (..), policies, policyID)+import qualified Cardano.Ledger.Mary.Value as Mary+import Cardano.Ledger.SafeHash+  ( HashAnnotated,+    SafeHash,+    SafeToHash,+  )+import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr, decompactAddr)+import Cardano.Ledger.Shelley.Delegation.Certificates (DCert)+import Cardano.Ledger.Shelley.PParams (Update)+import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))+import Cardano.Ledger.Shelley.TxBody (Wdrl (Wdrl), unWdrl)+import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))+import Cardano.Ledger.TxIn (TxIn (..))+import Cardano.Ledger.Val+  ( DecodeNonNegative,+    Val (..),+    decodeMint,+    decodeNonNegative,+    encodeMint,+    isZero,+  )+import Data.Coders+import Data.Maybe (fromMaybe)+import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)+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 (Proxy (..), Typeable, (:~:) (Refl))+import Data.Word+import GHC.Generics (Generic)+import GHC.Records (HasField (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits+import NoThunks.Class (InspectHeapNamed (..), NoThunks)+import Prelude hiding (lookup)++data TxOut era+  = TxOutCompact+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+  | TxOutCompactDH+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(DataHash (Crypto era))+  | TxOutCompactDatum+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(Data era)+  | TxOut_AddrHash28_AdaOnly+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+  | TxOut_AddrHash28_AdaOnly_DataHash32+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash++deriving stock instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  Eq (TxOut era)++viewCompactTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (CompactAddr (Crypto era), CompactForm (Core.Value era), StrictMaybe (DataHash (Crypto era)))+viewCompactTxOut txOut = case txOut of+  TxOutCompact addr val -> (addr, val, SNothing)+  TxOutCompactDH addr val dh -> (addr, val, SJust dh)+  TxOutCompactDatum addr val datum -> (addr, val, SJust $ hashData datum)+  TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      (compactAddr (decodeAddress28 stakeRef a b c d), toCompactValue adaVal, SNothing)+  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+      Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      ( compactAddr (decodeAddress28 stakeRef a b c d),+        toCompactValue adaVal,+        SJust (decodeDataHash32 e f g h)+      )+  TxOut_AddrHash28_AdaOnly {} -> error "Impossible: Compacted and address or hash of non-standard size"+  TxOut_AddrHash28_AdaOnly_DataHash32 {} -> error "Impossible: Compacted and address or hash of non-standard size"+  where+    toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)+    toCompactValue ada =+      fromMaybe (error "Failed to compact a `Coin` as `CompactForm (Core.Value era)`")+        . toCompact+        . inject+        $ fromCompact ada++viewTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (Addr (Crypto era), Core.Value era, StrictMaybe (DataHash (Crypto era)))+viewTxOut (TxOutCompact bs c) = (addr, val, SNothing)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDH bs c dh) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDatum bs c datum) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+    dh = hashData datum+viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SNothing)+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+    Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))+viewTxOut (TxOut_AddrHash28_AdaOnly {}) = error "Impossible: Compacted and address or hash of non-standard size"+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 {}) = error "Impossible: Compacted and address or hash of non-standard size"++instance+  ( Era era,+    Show (Core.Value era),+    Show (CompactForm (Core.Value era))+  ) =>+  Show (TxOut era)+  where+  show = show . viewTxOut++deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era)++pattern TxOut ::+  forall era.+  ( Era era,+    Compactible (Core.Value era),+    Val (Core.Value era),+    HasCallStack+  ) =>+  Addr (Crypto era) ->+  Core.Value era ->+  StrictMaybe (DataHash (Crypto era)) ->+  TxOut era+pattern TxOut addr vl dh <-+  (viewTxOut -> (addr, vl, dh))+  where+    TxOut (Addr network paymentCred stakeRef) vl SNothing+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred =+        TxOut_AddrHash28_AdaOnly stakeCred a b c d adaCompact+    TxOut (Addr network paymentCred stakeRef) vl (SJust dh)+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred,+        Just (Refl, e, f, g, h) <- encodeDataHash32 dh =+        TxOut_AddrHash28_AdaOnly_DataHash32 stakeCred a b c d adaCompact e f g h+    TxOut addr vl mdh =+      let v = fromMaybe (error "Illegal value in txout") $ toCompact vl+          a = compactAddr addr+       in case mdh of+            SNothing -> TxOutCompact a v+            SJust dh -> TxOutCompactDH a v dh++{-# COMPLETE TxOut #-}++-- ======================================++type ScriptIntegrityHash crypto = SafeHash crypto EraIndependentScriptIntegrity++data TxBodyRaw era = TxBodyRaw+  { _inputs :: !(Set (TxIn (Crypto era))),+    _collateral :: !(Set (TxIn (Crypto era))),+    _collateralReturn :: !(StrictMaybe (TxOut era)),+    _outputs :: !(StrictSeq (TxOut era)),+    _certs :: !(StrictSeq (DCert (Crypto era))),+    _wdrls :: !(Wdrl (Crypto era)),+    _txfee :: !Coin,+    _vldt :: !ValidityInterval,+    _update :: !(StrictMaybe (Update era)),+    _reqSignerHashes :: Set (KeyHash 'Witness (Crypto era)),+    _mint :: !(Value (Crypto era)),+    -- The spec makes it clear that the mint field is a+    -- Cardano.Ledger.Mary.Value.Value, not a Core.Value.+    -- Operations on the TxBody in the AlonzoEra depend upon this.+    _scriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (Crypto era))),+    _adHash :: !(StrictMaybe (AuxiliaryDataHash (Crypto era))),+    _txnetworkid :: !(StrictMaybe Network)+  }+  deriving (Generic, Typeable)

@JaredCorduan or @nc6 can you comment on this? I think we could do something like this instead?

data TxBodyRaw era = TxBodyRaw
  { txBodyAlonzo :: Alonzo.TxBodyRaw era
  , txBodyCollateralReturn :: !(StrictMaybe (TxOut era))
  }

This way we could reuse all the serialization/deserialization logic from alonzo. All this copy pasting is hurting my eyes. I will of course not stand in a way if that is how era parameterization was designed to be used.

goolord

comment created time in 2 days

Pull request review commentinput-output-hk/cardano-ledger

Babbage: TxBody + TxOut

+{-# 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 ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Cardano.Ledger.Babbage.TxBody+  ( TxOut (TxOut, TxOutCompact, TxOutCompactDH, TxOutCompactDatum),+    TxBody+      ( TxBody,+        inputs,+        collateral,+        collateralReturn,+        outputs,+        txcerts,+        txwdrls,+        txfee,+        txvldt,+        txUpdates,+        reqSignerHashes,+        mint,+        scriptIntegrityHash,+        adHash,+        txnetworkid+      ),+    inputs',+    collateral',+    collateralReturn',+    outputs',+    certs',+    wdrls',+    txfee',+    vldt',+    update',+    reqSignerHashes',+    mint',+    scriptIntegrityHash',+    adHash',+    txnetworkid',+    AlonzoBody,+    EraIndependentScriptIntegrity,+    ScriptIntegrityHash,+  )+where++import Cardano.Binary+  ( DecoderError (..),+    FromCBOR (..),+    ToCBOR (..),+    decodeBreakOr,+    decodeListLenOrIndef,+    encodeListLen,+  )+import Cardano.Crypto.Hash+import Cardano.Ledger.Address (Addr (..))+import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash (..), Data, DataHash, hashData)+import Cardano.Ledger.Alonzo.TxBody (decodeAddress28, decodeDataHash32, encodeAddress28, encodeDataHash32, getAdaOnly)+import Cardano.Ledger.BaseTypes+  ( Network (..),+    StrictMaybe (..),+    isSNothing,+  )+import Cardano.Ledger.Coin (Coin (..))+import Cardano.Ledger.Compactible+import Cardano.Ledger.Core (PParamsDelta)+import qualified Cardano.Ledger.Core as Core+import Cardano.Ledger.Credential (Credential (..), StakeReference (..))+import qualified Cardano.Ledger.Crypto as CC+import Cardano.Ledger.Era (Crypto, Era)+import Cardano.Ledger.Hashes+  ( EraIndependentScriptIntegrity,+    EraIndependentTxBody,+  )+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))+import Cardano.Ledger.Mary.Value (Value (..), policies, policyID)+import qualified Cardano.Ledger.Mary.Value as Mary+import Cardano.Ledger.SafeHash+  ( HashAnnotated,+    SafeHash,+    SafeToHash,+  )+import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr, decompactAddr)+import Cardano.Ledger.Shelley.Delegation.Certificates (DCert)+import Cardano.Ledger.Shelley.PParams (Update)+import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))+import Cardano.Ledger.Shelley.TxBody (Wdrl (Wdrl), unWdrl)+import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))+import Cardano.Ledger.TxIn (TxIn (..))+import Cardano.Ledger.Val+  ( DecodeNonNegative,+    Val (..),+    decodeMint,+    decodeNonNegative,+    encodeMint,+    isZero,+  )+import Data.Coders+import Data.Maybe (fromMaybe)+import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)+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 (Proxy (..), Typeable, (:~:) (Refl))+import Data.Word+import GHC.Generics (Generic)+import GHC.Records (HasField (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits+import NoThunks.Class (InspectHeapNamed (..), NoThunks)+import Prelude hiding (lookup)++data TxOut era+  = TxOutCompact+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+  | TxOutCompactDH+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(DataHash (Crypto era))+  | TxOutCompactDatum+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(Data era)+  | TxOut_AddrHash28_AdaOnly+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+  | TxOut_AddrHash28_AdaOnly_DataHash32+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash++deriving stock instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  Eq (TxOut era)++viewCompactTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (CompactAddr (Crypto era), CompactForm (Core.Value era), StrictMaybe (DataHash (Crypto era)))+viewCompactTxOut txOut = case txOut of+  TxOutCompact addr val -> (addr, val, SNothing)+  TxOutCompactDH addr val dh -> (addr, val, SJust dh)+  TxOutCompactDatum addr val datum -> (addr, val, SJust $ hashData datum)+  TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      (compactAddr (decodeAddress28 stakeRef a b c d), toCompactValue adaVal, SNothing)+  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+      Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      ( compactAddr (decodeAddress28 stakeRef a b c d),+        toCompactValue adaVal,+        SJust (decodeDataHash32 e f g h)+      )+  TxOut_AddrHash28_AdaOnly {} -> error "Impossible: Compacted and address or hash of non-standard size"+  TxOut_AddrHash28_AdaOnly_DataHash32 {} -> error "Impossible: Compacted and address or hash of non-standard size"+  where+    toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)+    toCompactValue ada =+      fromMaybe (error "Failed to compact a `Coin` as `CompactForm (Core.Value era)`")+        . toCompact+        . inject+        $ fromCompact ada++viewTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (Addr (Crypto era), Core.Value era, StrictMaybe (DataHash (Crypto era)))+viewTxOut (TxOutCompact bs c) = (addr, val, SNothing)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDH bs c dh) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDatum bs c datum) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+    dh = hashData datum+viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SNothing)+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+    Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))+viewTxOut (TxOut_AddrHash28_AdaOnly {}) = error "Impossible: Compacted and address or hash of non-standard size"+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 {}) = error "Impossible: Compacted and address or hash of non-standard size"++instance+  ( Era era,+    Show (Core.Value era),+    Show (CompactForm (Core.Value era))+  ) =>+  Show (TxOut era)+  where+  show = show . viewTxOut++deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era)++pattern TxOut ::+  forall era.+  ( Era era,+    Compactible (Core.Value era),+    Val (Core.Value era),+    HasCallStack+  ) =>+  Addr (Crypto era) ->+  Core.Value era ->+  StrictMaybe (DataHash (Crypto era)) ->+  TxOut era+pattern TxOut addr vl dh <-+  (viewTxOut -> (addr, vl, dh))+  where+    TxOut (Addr network paymentCred stakeRef) vl SNothing+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred =+        TxOut_AddrHash28_AdaOnly stakeCred a b c d adaCompact+    TxOut (Addr network paymentCred stakeRef) vl (SJust dh)+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred,+        Just (Refl, e, f, g, h) <- encodeDataHash32 dh =+        TxOut_AddrHash28_AdaOnly_DataHash32 stakeCred a b c d adaCompact e f g h+    TxOut addr vl mdh =+      let v = fromMaybe (error "Illegal value in txout") $ toCompact vl+          a = compactAddr addr+       in case mdh of+            SNothing -> TxOutCompact a v+            SJust dh -> TxOutCompactDH a v dh++{-# COMPLETE TxOut #-}++-- ======================================++type ScriptIntegrityHash crypto = SafeHash crypto EraIndependentScriptIntegrity++data TxBodyRaw era = TxBodyRaw+  { _inputs :: !(Set (TxIn (Crypto era))),+    _collateral :: !(Set (TxIn (Crypto era))),+    _collateralReturn :: !(StrictMaybe (TxOut era)),+    _outputs :: !(StrictSeq (TxOut era)),+    _certs :: !(StrictSeq (DCert (Crypto era))),+    _wdrls :: !(Wdrl (Crypto era)),+    _txfee :: !Coin,+    _vldt :: !ValidityInterval,+    _update :: !(StrictMaybe (Update era)),+    _reqSignerHashes :: Set (KeyHash 'Witness (Crypto era)),+    _mint :: !(Value (Crypto era)),+    -- The spec makes it clear that the mint field is a+    -- Cardano.Ledger.Mary.Value.Value, not a Core.Value.+    -- Operations on the TxBody in the AlonzoEra depend upon this.+    _scriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (Crypto era))),+    _adHash :: !(StrictMaybe (AuxiliaryDataHash (Crypto era))),+    _txnetworkid :: !(StrictMaybe Network)+  }+  deriving (Generic, Typeable)++deriving instance+  ( Eq (Core.Value era),+    CC.Crypto (Crypto era),+    Compactible (Core.Value era),+    Eq (PParamsDelta era)+  ) =>+  Eq (TxBodyRaw era)++instance+  (Typeable era, NoThunks (Core.Value era), NoThunks (PParamsDelta era)) =>+  NoThunks (TxBodyRaw era)++deriving instance+  ( Era era,+    Show (Core.Value era),+    Show (PParamsDelta era)+  ) =>+  Show (TxBodyRaw era)++newtype TxBody era = TxBodyConstr (MemoBytes (TxBodyRaw era))+  deriving (ToCBOR)+  deriving newtype (SafeToHash)++deriving newtype instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era),+    CC.Crypto (Crypto era),+    Eq (PParamsDelta era)+  ) =>+  Eq (TxBody era)++deriving instance+  ( Typeable era,+    NoThunks (Core.Value era),+    NoThunks (PParamsDelta era)+  ) =>+  NoThunks (TxBody era)++deriving instance+  ( Era era,+    Compactible (Core.Value era),+    Show (Core.Value era),+    Show (PParamsDelta era)+  ) =>+  Show (TxBody era)++deriving via+  (Mem (TxBodyRaw era))+  instance+    ( Era era,+      Typeable (Core.Script era),+      Typeable (Core.AuxiliaryData era),+      Compactible (Core.Value era),+      Show (Core.Value era),+      DecodeNonNegative (Core.Value era),+      FromCBOR (Annotator (Core.Script era)),+      Core.SerialisableData (PParamsDelta era)+    ) =>+    FromCBOR (Annotator (TxBody era))++-- The Set of constraints necessary to use the TxBody pattern+type AlonzoBody era =+  ( Era era,+    Compactible (Core.Value era),+    ToCBOR (Core.Script era),+    Core.SerialisableData (PParamsDelta era)+  )++pattern TxBody ::+  AlonzoBody era =>+  Set (TxIn (Crypto era)) ->+  Set (TxIn (Crypto era)) ->+  StrictMaybe (TxOut era) ->+  StrictSeq (TxOut era) ->+  StrictSeq (DCert (Crypto era)) ->+  Wdrl (Crypto era) ->+  Coin ->+  ValidityInterval ->+  StrictMaybe (Update era) ->+  Set (KeyHash 'Witness (Crypto era)) ->+  Value (Crypto era) ->+  StrictMaybe (ScriptIntegrityHash (Crypto era)) ->+  StrictMaybe (AuxiliaryDataHash (Crypto era)) ->+  StrictMaybe Network ->+  TxBody era+pattern TxBody+  { inputs,+    collateral,+    collateralReturn,+    outputs,+    txcerts,+    txwdrls,+    txfee,+    txvldt,+    txUpdates,+    reqSignerHashes,+    mint,+    scriptIntegrityHash,+    adHash,+    txnetworkid+  } <-+  TxBodyConstr+    ( Memo+        TxBodyRaw+          { _inputs = inputs,+            _collateral = collateral,+            _collateralReturn = collateralReturn,+            _outputs = outputs,+            _certs = txcerts,+            _wdrls = txwdrls,+            _txfee = txfee,+            _vldt = txvldt,+            _update = txUpdates,+            _reqSignerHashes = reqSignerHashes,+            _mint = mint,+            _scriptIntegrityHash = scriptIntegrityHash,+            _adHash = adHash,+            _txnetworkid = txnetworkid+          }+        _+      )+  where+    TxBody+      inputsX+      collateralX+      collateralReturnX+      outputsX+      certsX+      wdrlsX+      txfeeX+      vldtX+      updateX+      reqSignerHashesX+      mintX+      scriptIntegrityHashX+      adHashX+      txnetworkidX =+        TxBodyConstr $+          memoBytes+            ( encodeTxBodyRaw $+                TxBodyRaw+                  inputsX+                  collateralX+                  collateralReturnX+                  outputsX+                  certsX+                  wdrlsX+                  txfeeX+                  vldtX+                  updateX+                  reqSignerHashesX+                  mintX+                  scriptIntegrityHashX+                  adHashX+                  txnetworkidX+            )++{-# COMPLETE TxBody #-}++instance (c ~ Crypto era) => HashAnnotated (TxBody era) EraIndependentTxBody c++-- ==============================================================================+-- 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' :: TxBody era -> Set (TxIn (Crypto era))+collateral' :: TxBody era -> Set (TxIn (Crypto era))+collateralReturn' :: TxBody era -> StrictMaybe (TxOut era)+outputs' :: TxBody era -> StrictSeq (TxOut era)+certs' :: TxBody era -> StrictSeq (DCert (Crypto era))+txfee' :: TxBody era -> Coin+wdrls' :: TxBody era -> Wdrl (Crypto era)+vldt' :: TxBody era -> ValidityInterval+update' :: TxBody era -> StrictMaybe (Update era)+reqSignerHashes' :: TxBody era -> Set (KeyHash 'Witness (Crypto era))+adHash' :: TxBody era -> StrictMaybe (AuxiliaryDataHash (Crypto era))+mint' :: TxBody era -> Value (Crypto era)+scriptIntegrityHash' :: TxBody era -> StrictMaybe (ScriptIntegrityHash (Crypto era))+inputs' (TxBodyConstr (Memo raw _)) = _inputs raw++txnetworkid' :: TxBody era -> StrictMaybe Network++collateral' (TxBodyConstr (Memo raw _)) = _collateral raw++collateralReturn' (TxBodyConstr (Memo raw _)) = _collateralReturn raw++outputs' (TxBodyConstr (Memo raw _)) = _outputs raw++certs' (TxBodyConstr (Memo raw _)) = _certs raw++wdrls' (TxBodyConstr (Memo raw _)) = _wdrls raw++txfee' (TxBodyConstr (Memo raw _)) = _txfee raw++vldt' (TxBodyConstr (Memo raw _)) = _vldt raw++update' (TxBodyConstr (Memo raw _)) = _update raw++reqSignerHashes' (TxBodyConstr (Memo raw _)) = _reqSignerHashes raw++adHash' (TxBodyConstr (Memo raw _)) = _adHash raw++mint' (TxBodyConstr (Memo raw _)) = _mint raw++scriptIntegrityHash' (TxBodyConstr (Memo raw _)) = _scriptIntegrityHash raw++txnetworkid' (TxBodyConstr (Memo raw _)) = _txnetworkid raw++--------------------------------------------------------------------------------+-- Serialisation+--------------------------------------------------------------------------------++instance+  ( Era era,+    Compactible (Core.Value era)+  ) =>+  ToCBOR (TxOut era)+  where+  toCBOR (TxOutCompact addr cv) =+    encodeListLen 2+      <> toCBOR addr+      <> toCBOR cv+  toCBOR (TxOutCompactDH addr cv dh) =+    encodeListLen 3+      <> toCBOR addr+      <> toCBOR cv+      <> toCBOR dh+  toCBOR x =+    let (addr, cv, dh) = viewCompactTxOut x+     in encodeListLen 3+          <> toCBOR addr+          <> toCBOR cv+          <> toCBOR dh++instance+  ( Era era,+    DecodeNonNegative (Core.Value era),+    Show (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  FromCBOR (TxOut era)+  where+  fromCBOR = do+    lenOrIndef <- decodeListLenOrIndef+    case lenOrIndef of+      Nothing -> do+        a <- fromCBOR+        cv <- decodeNonNegative+        decodeBreakOr >>= \case+          True -> pure $ TxOutCompact a cv+          False -> do+            dh <- fromCBOR+            decodeBreakOr >>= \case+              True -> pure $ TxOutCompactDH a cv dh+              False -> cborError $ DecoderErrorCustom "txout" "Excess terms in txout"+      Just 2 ->+        TxOutCompact+          <$> fromCBOR+          <*> decodeNonNegative+      Just 3 ->+        TxOutCompactDH+          <$> fromCBOR+          <*> decodeNonNegative+          <*> fromCBOR+      Just _ -> cborError $ DecoderErrorCustom "txout" "wrong number of terms in txout"++encodeTxBodyRaw ::+  ( Era era,+    ToCBOR (PParamsDelta era)+  ) =>+  TxBodyRaw era ->+  Encode ('Closed 'Sparse) (TxBodyRaw era)+encodeTxBodyRaw+  TxBodyRaw+    { _inputs,+      _collateral,+      _collateralReturn,+      _outputs,+      _certs,+      _wdrls,+      _txfee,+      _vldt = ValidityInterval bot top,+      _update,+      _reqSignerHashes,+      _mint,+      _scriptIntegrityHash,+      _adHash,+      _txnetworkid+    } =+    Keyed+      ( \i ifee ca o f t c w u b rsh mi sh ah ni ->+          TxBodyRaw i ifee ca o c w f (ValidityInterval b t) u rsh mi sh ah ni+      )+      !> Key 0 (E encodeFoldable _inputs)+      !> Key 13 (E encodeFoldable _collateral)+      !> Key 13 (To _collateralReturn)+      !> Key 1 (E encodeFoldable _outputs)+      !> Key 2 (To _txfee)+      !> encodeKeyedStrictMaybe 3 top+      !> Omit null (Key 4 (E encodeFoldable _certs))+      !> Omit (null . unWdrl) (Key 5 (To _wdrls))+      !> encodeKeyedStrictMaybe 6 _update+      !> encodeKeyedStrictMaybe 8 bot+      !> Key 14 (E encodeFoldable _reqSignerHashes)+      !> Omit isZero (Key 9 (E encodeMint _mint))+      !> encodeKeyedStrictMaybe 11 _scriptIntegrityHash+      !> encodeKeyedStrictMaybe 7 _adHash+      !> encodeKeyedStrictMaybe 15 _txnetworkid+    where+      encodeKeyedStrictMaybe key x =+        Omit isSNothing (Key key (E (toCBOR . fromSJust) x))++      fromSJust :: StrictMaybe a -> a+      fromSJust (SJust x) = x+      fromSJust SNothing = error "SNothing in fromSJust. This should never happen, it is guarded by isSNothing"++instance+  forall era.+  ( Era era,+    Typeable (Core.Script era),+    Typeable (Core.AuxiliaryData era),+    Compactible (Core.Value era),+    Show (Core.Value era),+    DecodeNonNegative (Core.Value era),+    FromCBOR (Annotator (Core.Script era)),+    FromCBOR (PParamsDelta era),+    ToCBOR (PParamsDelta era)+  ) =>+  FromCBOR (TxBodyRaw era)

Looks like deserialziation of collateralReturn is missing

goolord

comment created time in 2 days

Pull request review commentinput-output-hk/cardano-ledger

Babbage: TxBody + TxOut

+{-# 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 ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Cardano.Ledger.Babbage.TxBody+  ( TxOut (TxOut, TxOutCompact, TxOutCompactDH, TxOutCompactDatum),+    TxBody+      ( TxBody,+        inputs,+        collateral,+        collateralReturn,+        outputs,+        txcerts,+        txwdrls,+        txfee,+        txvldt,+        txUpdates,+        reqSignerHashes,+        mint,+        scriptIntegrityHash,+        adHash,+        txnetworkid+      ),+    inputs',+    collateral',+    collateralReturn',+    outputs',+    certs',+    wdrls',+    txfee',+    vldt',+    update',+    reqSignerHashes',+    mint',+    scriptIntegrityHash',+    adHash',+    txnetworkid',+    AlonzoBody,+    EraIndependentScriptIntegrity,+    ScriptIntegrityHash,+  )+where++import Cardano.Binary+  ( DecoderError (..),+    FromCBOR (..),+    ToCBOR (..),+    decodeBreakOr,+    decodeListLenOrIndef,+    encodeListLen,+  )+import Cardano.Crypto.Hash+import Cardano.Ledger.Address (Addr (..))+import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash (..), Data, DataHash, hashData)+import Cardano.Ledger.Alonzo.TxBody (decodeAddress28, decodeDataHash32, encodeAddress28, encodeDataHash32, getAdaOnly)+import Cardano.Ledger.BaseTypes+  ( Network (..),+    StrictMaybe (..),+    isSNothing,+  )+import Cardano.Ledger.Coin (Coin (..))+import Cardano.Ledger.Compactible+import Cardano.Ledger.Core (PParamsDelta)+import qualified Cardano.Ledger.Core as Core+import Cardano.Ledger.Credential (Credential (..), StakeReference (..))+import qualified Cardano.Ledger.Crypto as CC+import Cardano.Ledger.Era (Crypto, Era)+import Cardano.Ledger.Hashes+  ( EraIndependentScriptIntegrity,+    EraIndependentTxBody,+  )+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))+import Cardano.Ledger.Mary.Value (Value (..), policies, policyID)+import qualified Cardano.Ledger.Mary.Value as Mary+import Cardano.Ledger.SafeHash+  ( HashAnnotated,+    SafeHash,+    SafeToHash,+  )+import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr, decompactAddr)+import Cardano.Ledger.Shelley.Delegation.Certificates (DCert)+import Cardano.Ledger.Shelley.PParams (Update)+import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))+import Cardano.Ledger.Shelley.TxBody (Wdrl (Wdrl), unWdrl)+import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))+import Cardano.Ledger.TxIn (TxIn (..))+import Cardano.Ledger.Val+  ( DecodeNonNegative,+    Val (..),+    decodeMint,+    decodeNonNegative,+    encodeMint,+    isZero,+  )+import Data.Coders+import Data.Maybe (fromMaybe)+import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)+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 (Proxy (..), Typeable, (:~:) (Refl))+import Data.Word+import GHC.Generics (Generic)+import GHC.Records (HasField (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits+import NoThunks.Class (InspectHeapNamed (..), NoThunks)+import Prelude hiding (lookup)++data TxOut era+  = TxOutCompact+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+  | TxOutCompactDH+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(DataHash (Crypto era))+  | TxOutCompactDatum+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(Data era)+  | TxOut_AddrHash28_AdaOnly+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+  | TxOut_AddrHash28_AdaOnly_DataHash32+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash++deriving stock instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  Eq (TxOut era)++viewCompactTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (CompactAddr (Crypto era), CompactForm (Core.Value era), StrictMaybe (DataHash (Crypto era)))+viewCompactTxOut txOut = case txOut of+  TxOutCompact addr val -> (addr, val, SNothing)+  TxOutCompactDH addr val dh -> (addr, val, SJust dh)+  TxOutCompactDatum addr val datum -> (addr, val, SJust $ hashData datum)+  TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      (compactAddr (decodeAddress28 stakeRef a b c d), toCompactValue adaVal, SNothing)+  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+      Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      ( compactAddr (decodeAddress28 stakeRef a b c d),+        toCompactValue adaVal,+        SJust (decodeDataHash32 e f g h)+      )+  TxOut_AddrHash28_AdaOnly {} -> error "Impossible: Compacted and address or hash of non-standard size"+  TxOut_AddrHash28_AdaOnly_DataHash32 {} -> error "Impossible: Compacted and address or hash of non-standard size"+  where+    toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)+    toCompactValue ada =+      fromMaybe (error "Failed to compact a `Coin` as `CompactForm (Core.Value era)`")+        . toCompact+        . inject+        $ fromCompact ada++viewTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (Addr (Crypto era), Core.Value era, StrictMaybe (DataHash (Crypto era)))+viewTxOut (TxOutCompact bs c) = (addr, val, SNothing)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDH bs c dh) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDatum bs c datum) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+    dh = hashData datum+viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SNothing)+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+    Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))+viewTxOut (TxOut_AddrHash28_AdaOnly {}) = error "Impossible: Compacted and address or hash of non-standard size"+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 {}) = error "Impossible: Compacted and address or hash of non-standard size"++instance+  ( Era era,+    Show (Core.Value era),+    Show (CompactForm (Core.Value era))+  ) =>+  Show (TxOut era)+  where+  show = show . viewTxOut++deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era)++pattern TxOut ::+  forall era.+  ( Era era,+    Compactible (Core.Value era),+    Val (Core.Value era),+    HasCallStack+  ) =>+  Addr (Crypto era) ->+  Core.Value era ->+  StrictMaybe (DataHash (Crypto era)) ->+  TxOut era+pattern TxOut addr vl dh <-+  (viewTxOut -> (addr, vl, dh))+  where+    TxOut (Addr network paymentCred stakeRef) vl SNothing+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred =+        TxOut_AddrHash28_AdaOnly stakeCred a b c d adaCompact+    TxOut (Addr network paymentCred stakeRef) vl (SJust dh)+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred,+        Just (Refl, e, f, g, h) <- encodeDataHash32 dh =+        TxOut_AddrHash28_AdaOnly_DataHash32 stakeCred a b c d adaCompact e f g h+    TxOut addr vl mdh =+      let v = fromMaybe (error "Illegal value in txout") $ toCompact vl+          a = compactAddr addr+       in case mdh of+            SNothing -> TxOutCompact a v+            SJust dh -> TxOutCompactDH a v dh++{-# COMPLETE TxOut #-}++-- ======================================++type ScriptIntegrityHash crypto = SafeHash crypto EraIndependentScriptIntegrity++data TxBodyRaw era = TxBodyRaw+  { _inputs :: !(Set (TxIn (Crypto era))),+    _collateral :: !(Set (TxIn (Crypto era))),+    _collateralReturn :: !(StrictMaybe (TxOut era)),+    _outputs :: !(StrictSeq (TxOut era)),+    _certs :: !(StrictSeq (DCert (Crypto era))),+    _wdrls :: !(Wdrl (Crypto era)),+    _txfee :: !Coin,+    _vldt :: !ValidityInterval,+    _update :: !(StrictMaybe (Update era)),+    _reqSignerHashes :: Set (KeyHash 'Witness (Crypto era)),+    _mint :: !(Value (Crypto era)),+    -- The spec makes it clear that the mint field is a+    -- Cardano.Ledger.Mary.Value.Value, not a Core.Value.+    -- Operations on the TxBody in the AlonzoEra depend upon this.+    _scriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (Crypto era))),+    _adHash :: !(StrictMaybe (AuxiliaryDataHash (Crypto era))),+    _txnetworkid :: !(StrictMaybe Network)+  }+  deriving (Generic, Typeable)++deriving instance+  ( Eq (Core.Value era),+    CC.Crypto (Crypto era),+    Compactible (Core.Value era),+    Eq (PParamsDelta era)+  ) =>+  Eq (TxBodyRaw era)++instance+  (Typeable era, NoThunks (Core.Value era), NoThunks (PParamsDelta era)) =>+  NoThunks (TxBodyRaw era)++deriving instance+  ( Era era,+    Show (Core.Value era),+    Show (PParamsDelta era)+  ) =>+  Show (TxBodyRaw era)++newtype TxBody era = TxBodyConstr (MemoBytes (TxBodyRaw era))+  deriving (ToCBOR)+  deriving newtype (SafeToHash)++deriving newtype instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era),+    CC.Crypto (Crypto era),+    Eq (PParamsDelta era)+  ) =>+  Eq (TxBody era)++deriving instance+  ( Typeable era,+    NoThunks (Core.Value era),+    NoThunks (PParamsDelta era)+  ) =>+  NoThunks (TxBody era)++deriving instance+  ( Era era,+    Compactible (Core.Value era),+    Show (Core.Value era),+    Show (PParamsDelta era)+  ) =>+  Show (TxBody era)++deriving via+  (Mem (TxBodyRaw era))+  instance+    ( Era era,+      Typeable (Core.Script era),+      Typeable (Core.AuxiliaryData era),+      Compactible (Core.Value era),+      Show (Core.Value era),+      DecodeNonNegative (Core.Value era),+      FromCBOR (Annotator (Core.Script era)),+      Core.SerialisableData (PParamsDelta era)+    ) =>+    FromCBOR (Annotator (TxBody era))++-- The Set of constraints necessary to use the TxBody pattern+type AlonzoBody era =+  ( Era era,+    Compactible (Core.Value era),+    ToCBOR (Core.Script era),+    Core.SerialisableData (PParamsDelta era)+  )++pattern TxBody ::+  AlonzoBody era =>+  Set (TxIn (Crypto era)) ->+  Set (TxIn (Crypto era)) ->+  StrictMaybe (TxOut era) ->+  StrictSeq (TxOut era) ->+  StrictSeq (DCert (Crypto era)) ->+  Wdrl (Crypto era) ->+  Coin ->+  ValidityInterval ->+  StrictMaybe (Update era) ->+  Set (KeyHash 'Witness (Crypto era)) ->+  Value (Crypto era) ->+  StrictMaybe (ScriptIntegrityHash (Crypto era)) ->+  StrictMaybe (AuxiliaryDataHash (Crypto era)) ->+  StrictMaybe Network ->+  TxBody era+pattern TxBody+  { inputs,+    collateral,+    collateralReturn,+    outputs,+    txcerts,+    txwdrls,+    txfee,+    txvldt,+    txUpdates,+    reqSignerHashes,+    mint,+    scriptIntegrityHash,+    adHash,+    txnetworkid+  } <-+  TxBodyConstr+    ( Memo+        TxBodyRaw+          { _inputs = inputs,+            _collateral = collateral,+            _collateralReturn = collateralReturn,+            _outputs = outputs,+            _certs = txcerts,+            _wdrls = txwdrls,+            _txfee = txfee,+            _vldt = txvldt,+            _update = txUpdates,+            _reqSignerHashes = reqSignerHashes,+            _mint = mint,+            _scriptIntegrityHash = scriptIntegrityHash,+            _adHash = adHash,+            _txnetworkid = txnetworkid+          }+        _+      )+  where+    TxBody+      inputsX+      collateralX+      collateralReturnX+      outputsX+      certsX+      wdrlsX+      txfeeX+      vldtX+      updateX+      reqSignerHashesX+      mintX+      scriptIntegrityHashX+      adHashX+      txnetworkidX =+        TxBodyConstr $+          memoBytes+            ( encodeTxBodyRaw $+                TxBodyRaw+                  inputsX+                  collateralX+                  collateralReturnX+                  outputsX+                  certsX+                  wdrlsX+                  txfeeX+                  vldtX+                  updateX+                  reqSignerHashesX+                  mintX+                  scriptIntegrityHashX+                  adHashX+                  txnetworkidX+            )++{-# COMPLETE TxBody #-}++instance (c ~ Crypto era) => HashAnnotated (TxBody era) EraIndependentTxBody c++-- ==============================================================================+-- 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' :: TxBody era -> Set (TxIn (Crypto era))+collateral' :: TxBody era -> Set (TxIn (Crypto era))+collateralReturn' :: TxBody era -> StrictMaybe (TxOut era)+outputs' :: TxBody era -> StrictSeq (TxOut era)+certs' :: TxBody era -> StrictSeq (DCert (Crypto era))+txfee' :: TxBody era -> Coin+wdrls' :: TxBody era -> Wdrl (Crypto era)+vldt' :: TxBody era -> ValidityInterval+update' :: TxBody era -> StrictMaybe (Update era)+reqSignerHashes' :: TxBody era -> Set (KeyHash 'Witness (Crypto era))+adHash' :: TxBody era -> StrictMaybe (AuxiliaryDataHash (Crypto era))+mint' :: TxBody era -> Value (Crypto era)+scriptIntegrityHash' :: TxBody era -> StrictMaybe (ScriptIntegrityHash (Crypto era))+inputs' (TxBodyConstr (Memo raw _)) = _inputs raw++txnetworkid' :: TxBody era -> StrictMaybe Network++collateral' (TxBodyConstr (Memo raw _)) = _collateral raw++collateralReturn' (TxBodyConstr (Memo raw _)) = _collateralReturn raw++outputs' (TxBodyConstr (Memo raw _)) = _outputs raw++certs' (TxBodyConstr (Memo raw _)) = _certs raw++wdrls' (TxBodyConstr (Memo raw _)) = _wdrls raw++txfee' (TxBodyConstr (Memo raw _)) = _txfee raw++vldt' (TxBodyConstr (Memo raw _)) = _vldt raw++update' (TxBodyConstr (Memo raw _)) = _update raw++reqSignerHashes' (TxBodyConstr (Memo raw _)) = _reqSignerHashes raw++adHash' (TxBodyConstr (Memo raw _)) = _adHash raw++mint' (TxBodyConstr (Memo raw _)) = _mint raw++scriptIntegrityHash' (TxBodyConstr (Memo raw _)) = _scriptIntegrityHash raw++txnetworkid' (TxBodyConstr (Memo raw _)) = _txnetworkid raw++--------------------------------------------------------------------------------+-- Serialisation+--------------------------------------------------------------------------------++instance+  ( Era era,+    Compactible (Core.Value era)+  ) =>+  ToCBOR (TxOut era)+  where+  toCBOR (TxOutCompact addr cv) =+    encodeListLen 2+      <> toCBOR addr+      <> toCBOR cv+  toCBOR (TxOutCompactDH addr cv dh) =+    encodeListLen 3+      <> toCBOR addr+      <> toCBOR cv+      <> toCBOR dh+  toCBOR x =+    let (addr, cv, dh) = viewCompactTxOut x+     in encodeListLen 3+          <> toCBOR addr+          <> toCBOR cv+          <> toCBOR dh++instance+  ( Era era,+    DecodeNonNegative (Core.Value era),+    Show (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  FromCBOR (TxOut era)+  where+  fromCBOR = do+    lenOrIndef <- decodeListLenOrIndef+    case lenOrIndef of+      Nothing -> do+        a <- fromCBOR+        cv <- decodeNonNegative+        decodeBreakOr >>= \case+          True -> pure $ TxOutCompact a cv+          False -> do+            dh <- fromCBOR+            decodeBreakOr >>= \case+              True -> pure $ TxOutCompactDH a cv dh+              False -> cborError $ DecoderErrorCustom "txout" "Excess terms in txout"+      Just 2 ->+        TxOutCompact+          <$> fromCBOR+          <*> decodeNonNegative+      Just 3 ->+        TxOutCompactDH+          <$> fromCBOR+          <*> decodeNonNegative+          <*> fromCBOR+      Just _ -> cborError $ DecoderErrorCustom "txout" "wrong number of terms in txout"

Here is a good example of the problem from my other comment. Using TxOutCompact and TxOutCompactDH completely bypasses the ada only optimizations.

Also this deserialization does not account for decoding TxOut with datums

goolord

comment created time in 2 days

Pull request review commentinput-output-hk/cardano-ledger

Babbage: TxBody + TxOut

+{-# 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 ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Cardano.Ledger.Babbage.TxBody+  ( TxOut (TxOut, TxOutCompact, TxOutCompactDH, TxOutCompactDatum),+    TxBody+      ( TxBody,+        inputs,+        collateral,+        collateralReturn,+        outputs,+        txcerts,+        txwdrls,+        txfee,+        txvldt,+        txUpdates,+        reqSignerHashes,+        mint,+        scriptIntegrityHash,+        adHash,+        txnetworkid+      ),+    inputs',+    collateral',+    collateralReturn',+    outputs',+    certs',+    wdrls',+    txfee',+    vldt',+    update',+    reqSignerHashes',+    mint',+    scriptIntegrityHash',+    adHash',+    txnetworkid',+    AlonzoBody,+    EraIndependentScriptIntegrity,+    ScriptIntegrityHash,+  )+where++import Cardano.Binary+  ( DecoderError (..),+    FromCBOR (..),+    ToCBOR (..),+    decodeBreakOr,+    decodeListLenOrIndef,+    encodeListLen,+  )+import Cardano.Crypto.Hash+import Cardano.Ledger.Address (Addr (..))+import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash (..), Data, DataHash, hashData)+import Cardano.Ledger.Alonzo.TxBody (decodeAddress28, decodeDataHash32, encodeAddress28, encodeDataHash32, getAdaOnly)+import Cardano.Ledger.BaseTypes+  ( Network (..),+    StrictMaybe (..),+    isSNothing,+  )+import Cardano.Ledger.Coin (Coin (..))+import Cardano.Ledger.Compactible+import Cardano.Ledger.Core (PParamsDelta)+import qualified Cardano.Ledger.Core as Core+import Cardano.Ledger.Credential (Credential (..), StakeReference (..))+import qualified Cardano.Ledger.Crypto as CC+import Cardano.Ledger.Era (Crypto, Era)+import Cardano.Ledger.Hashes+  ( EraIndependentScriptIntegrity,+    EraIndependentTxBody,+  )+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))+import Cardano.Ledger.Mary.Value (Value (..), policies, policyID)+import qualified Cardano.Ledger.Mary.Value as Mary+import Cardano.Ledger.SafeHash+  ( HashAnnotated,+    SafeHash,+    SafeToHash,+  )+import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr, decompactAddr)+import Cardano.Ledger.Shelley.Delegation.Certificates (DCert)+import Cardano.Ledger.Shelley.PParams (Update)+import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))+import Cardano.Ledger.Shelley.TxBody (Wdrl (Wdrl), unWdrl)+import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))+import Cardano.Ledger.TxIn (TxIn (..))+import Cardano.Ledger.Val+  ( DecodeNonNegative,+    Val (..),+    decodeMint,+    decodeNonNegative,+    encodeMint,+    isZero,+  )+import Data.Coders+import Data.Maybe (fromMaybe)+import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)+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 (Proxy (..), Typeable, (:~:) (Refl))+import Data.Word+import GHC.Generics (Generic)+import GHC.Records (HasField (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits+import NoThunks.Class (InspectHeapNamed (..), NoThunks)+import Prelude hiding (lookup)++data TxOut era+  = TxOutCompact+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+  | TxOutCompactDH+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(DataHash (Crypto era))+  | TxOutCompactDatum+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(Data era)+  | TxOut_AddrHash28_AdaOnly+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+  | TxOut_AddrHash28_AdaOnly_DataHash32+      !(Credential 'Staking (Crypto era))+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey+      {-# UNPACK #-} !(CompactForm Coin) -- Ada value+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash+      {-# UNPACK #-} !Word64 -- DataHash++deriving stock instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  Eq (TxOut era)++viewCompactTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (CompactAddr (Crypto era), CompactForm (Core.Value era), StrictMaybe (DataHash (Crypto era)))+viewCompactTxOut txOut = case txOut of+  TxOutCompact addr val -> (addr, val, SNothing)+  TxOutCompactDH addr val dh -> (addr, val, SJust dh)+  TxOutCompactDatum addr val datum -> (addr, val, SJust $ hashData datum)+  TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      (compactAddr (decodeAddress28 stakeRef a b c d), toCompactValue adaVal, SNothing)+  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h+    | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+      Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->+      ( compactAddr (decodeAddress28 stakeRef a b c d),+        toCompactValue adaVal,+        SJust (decodeDataHash32 e f g h)+      )+  TxOut_AddrHash28_AdaOnly {} -> error "Impossible: Compacted and address or hash of non-standard size"+  TxOut_AddrHash28_AdaOnly_DataHash32 {} -> error "Impossible: Compacted and address or hash of non-standard size"+  where+    toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)+    toCompactValue ada =+      fromMaybe (error "Failed to compact a `Coin` as `CompactForm (Core.Value era)`")+        . toCompact+        . inject+        $ fromCompact ada++viewTxOut ::+  forall era.+  Era era =>+  TxOut era ->+  (Addr (Crypto era), Core.Value era, StrictMaybe (DataHash (Crypto era)))+viewTxOut (TxOutCompact bs c) = (addr, val, SNothing)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDH bs c dh) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+viewTxOut (TxOutCompactDatum bs c datum) = (addr, val, SJust dh)+  where+    addr = decompactAddr bs+    val = fromCompact c+    dh = hashData datum+viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SNothing)+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h)+  | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),+    Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =+    let addr = decodeAddress28 stakeRef a b c d+     in (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))+viewTxOut (TxOut_AddrHash28_AdaOnly {}) = error "Impossible: Compacted and address or hash of non-standard size"+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 {}) = error "Impossible: Compacted and address or hash of non-standard size"++instance+  ( Era era,+    Show (Core.Value era),+    Show (CompactForm (Core.Value era))+  ) =>+  Show (TxOut era)+  where+  show = show . viewTxOut++deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era)++pattern TxOut ::+  forall era.+  ( Era era,+    Compactible (Core.Value era),+    Val (Core.Value era),+    HasCallStack+  ) =>+  Addr (Crypto era) ->+  Core.Value era ->+  StrictMaybe (DataHash (Crypto era)) ->+  TxOut era+pattern TxOut addr vl dh <-+  (viewTxOut -> (addr, vl, dh))+  where+    TxOut (Addr network paymentCred stakeRef) vl SNothing+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred =+        TxOut_AddrHash28_AdaOnly stakeCred a b c d adaCompact+    TxOut (Addr network paymentCred stakeRef) vl (SJust dh)+      | StakeRefBase stakeCred <- stakeRef,+        Just adaCompact <- getAdaOnly (Proxy @era) vl,+        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred,+        Just (Refl, e, f, g, h) <- encodeDataHash32 dh =+        TxOut_AddrHash28_AdaOnly_DataHash32 stakeCred a b c d adaCompact e f g h+    TxOut addr vl mdh =+      let v = fromMaybe (error "Illegal value in txout") $ toCompact vl+          a = compactAddr addr+       in case mdh of+            SNothing -> TxOutCompact a v+            SJust dh -> TxOutCompactDH a v dh++{-# COMPLETE TxOut #-}++-- ======================================++type ScriptIntegrityHash crypto = SafeHash crypto EraIndependentScriptIntegrity++data TxBodyRaw era = TxBodyRaw+  { _inputs :: !(Set (TxIn (Crypto era))),+    _collateral :: !(Set (TxIn (Crypto era))),+    _collateralReturn :: !(StrictMaybe (TxOut era)),+    _outputs :: !(StrictSeq (TxOut era)),+    _certs :: !(StrictSeq (DCert (Crypto era))),+    _wdrls :: !(Wdrl (Crypto era)),+    _txfee :: !Coin,+    _vldt :: !ValidityInterval,+    _update :: !(StrictMaybe (Update era)),+    _reqSignerHashes :: Set (KeyHash 'Witness (Crypto era)),+    _mint :: !(Value (Crypto era)),+    -- The spec makes it clear that the mint field is a+    -- Cardano.Ledger.Mary.Value.Value, not a Core.Value.+    -- Operations on the TxBody in the AlonzoEra depend upon this.+    _scriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (Crypto era))),+    _adHash :: !(StrictMaybe (AuxiliaryDataHash (Crypto era))),+    _txnetworkid :: !(StrictMaybe Network)+  }+  deriving (Generic, Typeable)++deriving instance+  ( Eq (Core.Value era),+    CC.Crypto (Crypto era),+    Compactible (Core.Value era),+    Eq (PParamsDelta era)+  ) =>+  Eq (TxBodyRaw era)++instance+  (Typeable era, NoThunks (Core.Value era), NoThunks (PParamsDelta era)) =>+  NoThunks (TxBodyRaw era)++deriving instance+  ( Era era,+    Show (Core.Value era),+    Show (PParamsDelta era)+  ) =>+  Show (TxBodyRaw era)++newtype TxBody era = TxBodyConstr (MemoBytes (TxBodyRaw era))+  deriving (ToCBOR)+  deriving newtype (SafeToHash)++deriving newtype instance+  ( Eq (Core.Value era),+    Compactible (Core.Value era),+    CC.Crypto (Crypto era),+    Eq (PParamsDelta era)+  ) =>+  Eq (TxBody era)++deriving instance+  ( Typeable era,+    NoThunks (Core.Value era),+    NoThunks (PParamsDelta era)+  ) =>+  NoThunks (TxBody era)++deriving instance+  ( Era era,+    Compactible (Core.Value era),+    Show (Core.Value era),+    Show (PParamsDelta era)+  ) =>+  Show (TxBody era)++deriving via+  (Mem (TxBodyRaw era))+  instance+    ( Era era,+      Typeable (Core.Script era),+      Typeable (Core.AuxiliaryData era),+      Compactible (Core.Value era),+      Show (Core.Value era),+      DecodeNonNegative (Core.Value era),+      FromCBOR (Annotator (Core.Script era)),+      Core.SerialisableData (PParamsDelta era)+    ) =>+    FromCBOR (Annotator (TxBody era))++-- The Set of constraints necessary to use the TxBody pattern+type AlonzoBody era =+  ( Era era,+    Compactible (Core.Value era),+    ToCBOR (Core.Script era),+    Core.SerialisableData (PParamsDelta era)+  )++pattern TxBody ::+  AlonzoBody era =>+  Set (TxIn (Crypto era)) ->+  Set (TxIn (Crypto era)) ->+  StrictMaybe (TxOut era) ->+  StrictSeq (TxOut era) ->+  StrictSeq (DCert (Crypto era)) ->+  Wdrl (Crypto era) ->+  Coin ->+  ValidityInterval ->+  StrictMaybe (Update era) ->+  Set (KeyHash 'Witness (Crypto era)) ->+  Value (Crypto era) ->+  StrictMaybe (ScriptIntegrityHash (Crypto era)) ->+  StrictMaybe (AuxiliaryDataHash (Crypto era)) ->+  StrictMaybe Network ->+  TxBody era+pattern TxBody+  { inputs,+    collateral,+    collateralReturn,+    outputs,+    txcerts,+    txwdrls,+    txfee,+    txvldt,+    txUpdates,+    reqSignerHashes,+    mint,+    scriptIntegrityHash,+    adHash,+    txnetworkid+  } <-+  TxBodyConstr+    ( Memo+        TxBodyRaw+          { _inputs = inputs,+            _collateral = collateral,+            _collateralReturn = collateralReturn,+            _outputs = outputs,+            _certs = txcerts,+            _wdrls = txwdrls,+            _txfee = txfee,+            _vldt = txvldt,+            _update = txUpdates,+            _reqSignerHashes = reqSignerHashes,+            _mint = mint,+            _scriptIntegrityHash = scriptIntegrityHash,+            _adHash = adHash,+            _txnetworkid = txnetworkid+          }+        _+      )+  where+    TxBody+      inputsX+      collateralX+      collateralReturnX+      outputsX+      certsX+      wdrlsX+      txfeeX+      vldtX+      updateX+      reqSignerHashesX+      mintX+      scriptIntegrityHashX+      adHashX+      txnetworkidX =+        TxBodyConstr $+          memoBytes+            ( encodeTxBodyRaw $+                TxBodyRaw+                  inputsX+                  collateralX+                  collateralReturnX+                  outputsX+                  certsX+                  wdrlsX+                  txfeeX+                  vldtX+                  updateX+                  reqSignerHashesX+                  mintX+                  scriptIntegrityHashX+                  adHashX+                  txnetworkidX+            )++{-# COMPLETE TxBody #-}++instance (c ~ Crypto era) => HashAnnotated (TxBody era) EraIndependentTxBody c++-- ==============================================================================+-- 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' :: TxBody era -> Set (TxIn (Crypto era))+collateral' :: TxBody era -> Set (TxIn (Crypto era))+collateralReturn' :: TxBody era -> StrictMaybe (TxOut era)+outputs' :: TxBody era -> StrictSeq (TxOut era)+certs' :: TxBody era -> StrictSeq (DCert (Crypto era))+txfee' :: TxBody era -> Coin+wdrls' :: TxBody era -> Wdrl (Crypto era)+vldt' :: TxBody era -> ValidityInterval+update' :: TxBody era -> StrictMaybe (Update era)+reqSignerHashes' :: TxBody era -> Set (KeyHash 'Witness (Crypto era))+adHash' :: TxBody era -> StrictMaybe (AuxiliaryDataHash (Crypto era))+mint' :: TxBody era -> Value (Crypto era)+scriptIntegrityHash' :: TxBody era -> StrictMaybe (ScriptIntegrityHash (Crypto era))+inputs' (TxBodyConstr (Memo raw _)) = _inputs raw++txnetworkid' :: TxBody era -> StrictMaybe Network++collateral' (TxBodyConstr (Memo raw _)) = _collateral raw++collateralReturn' (TxBodyConstr (Memo raw _)) = _collateralReturn raw++outputs' (TxBodyConstr (Memo raw _)) = _outputs raw++certs' (TxBodyConstr (Memo raw _)) = _certs raw++wdrls' (TxBodyConstr (Memo raw _)) = _wdrls raw++txfee' (TxBodyConstr (Memo raw _)) = _txfee raw++vldt' (TxBodyConstr (Memo raw _)) = _vldt raw++update' (TxBodyConstr (Memo raw _)) = _update raw++reqSignerHashes' (TxBodyConstr (Memo raw _)) = _reqSignerHashes raw++adHash' (TxBodyConstr (Memo raw _)) = _adHash raw++mint' (TxBodyConstr (Memo raw _)) = _mint raw++scriptIntegrityHash' (TxBodyConstr (Memo raw _)) = _scriptIntegrityHash raw++txnetworkid' (TxBodyConstr (Memo raw _)) = _txnetworkid raw++--------------------------------------------------------------------------------+-- Serialisation+--------------------------------------------------------------------------------++instance+  ( Era era,+    Compactible (Core.Value era)+  ) =>+  ToCBOR (TxOut era)+  where+  toCBOR (TxOutCompact addr cv) =+    encodeListLen 2+      <> toCBOR addr+      <> toCBOR cv+  toCBOR (TxOutCompactDH addr cv dh) =+    encodeListLen 3+      <> toCBOR addr+      <> toCBOR cv+      <> toCBOR dh+  toCBOR x =+    let (addr, cv, dh) = viewCompactTxOut x+     in encodeListLen 3+          <> toCBOR addr+          <> toCBOR cv+          <> toCBOR dh++instance+  ( Era era,+    DecodeNonNegative (Core.Value era),+    Show (Core.Value era),+    Compactible (Core.Value era)+  ) =>+  FromCBOR (TxOut era)+  where+  fromCBOR = do+    lenOrIndef <- decodeListLenOrIndef+    case lenOrIndef of+      Nothing -> do+        a <- fromCBOR+        cv <- decodeNonNegative+        decodeBreakOr >>= \case+          True -> pure $ TxOutCompact a cv+          False -> do+            dh <- fromCBOR+            decodeBreakOr >>= \case+              True -> pure $ TxOutCompactDH a cv dh+              False -> cborError $ DecoderErrorCustom "txout" "Excess terms in txout"+      Just 2 ->+        TxOutCompact+          <$> fromCBOR+          <*> decodeNonNegative+      Just 3 ->+        TxOutCompactDH+          <$> fromCBOR+          <*> decodeNonNegative+          <*> fromCBOR+      Just _ -> cborError $ DecoderErrorCustom "txout" "wrong number of terms in txout"++encodeTxBodyRaw ::+  ( Era era,+    ToCBOR (PParamsDelta era)+  ) =>+  TxBodyRaw era ->+  Encode ('Closed 'Sparse) (TxBodyRaw era)+encodeTxBodyRaw+  TxBodyRaw+    { _inputs,+      _collateral,+      _collateralReturn,+      _outputs,+      _certs,+      _wdrls,+      _txfee,+      _vldt = ValidityInterval bot top,+      _update,+      _reqSignerHashes,+      _mint,+      _scriptIntegrityHash,+      _adHash,+      _txnetworkid+    } =+    Keyed+      ( \i ifee ca o f t c w u b rsh mi sh ah ni ->+          TxBodyRaw i ifee ca o c w f (ValidityInterval b t) u rsh mi sh ah ni+      )+      !> Key 0 (E encodeFoldable _inputs)+      !> Key 13 (E encodeFoldable _collateral)+      !> Key 13 (To _collateralReturn)

Correct me if I am wrong, but I assumed that key should be unique and reflect the position of the field during serlization/deserialization.

goolord

comment created time in 2 days

PullRequestReviewEvent

Pull request review commentinput-output-hk/cardano-ledger

Babbage: TxBody + TxOut

+{-# 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 ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Cardano.Ledger.Babbage.TxBody+  ( TxOut (TxOut, TxOutCompact, TxOutCompactDH, TxOutCompactDatum),+    TxBody+      ( TxBody,+        inputs,+        collateral,+        collateralReturn,+        outputs,+        txcerts,+        txwdrls,+        txfee,+        txvldt,+        txUpdates,+        reqSignerHashes,+        mint,+        scriptIntegrityHash,+        adHash,+        txnetworkid+      ),+    inputs',+    collateral',+    collateralReturn',+    outputs',+    certs',+    wdrls',+    txfee',+    vldt',+    update',+    reqSignerHashes',+    mint',+    scriptIntegrityHash',+    adHash',+    txnetworkid',+    AlonzoBody,+    EraIndependentScriptIntegrity,+    ScriptIntegrityHash,+  )+where++import Cardano.Binary+  ( DecoderError (..),+    FromCBOR (..),+    ToCBOR (..),+    decodeBreakOr,+    decodeListLenOrIndef,+    encodeListLen,+  )+import Cardano.Crypto.Hash+import Cardano.Ledger.Address (Addr (..))+import Cardano.Ledger.Alonzo.Data (AuxiliaryDataHash (..), Data, DataHash, hashData)+import Cardano.Ledger.Alonzo.TxBody (decodeAddress28, decodeDataHash32, encodeAddress28, encodeDataHash32, getAdaOnly)+import Cardano.Ledger.BaseTypes+  ( Network (..),+    StrictMaybe (..),+    isSNothing,+  )+import Cardano.Ledger.Coin (Coin (..))+import Cardano.Ledger.Compactible+import Cardano.Ledger.Core (PParamsDelta)+import qualified Cardano.Ledger.Core as Core+import Cardano.Ledger.Credential (Credential (..), StakeReference (..))+import qualified Cardano.Ledger.Crypto as CC+import Cardano.Ledger.Era (Crypto, Era)+import Cardano.Ledger.Hashes+  ( EraIndependentScriptIntegrity,+    EraIndependentTxBody,+  )+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))+import Cardano.Ledger.Mary.Value (Value (..), policies, policyID)+import qualified Cardano.Ledger.Mary.Value as Mary+import Cardano.Ledger.SafeHash+  ( HashAnnotated,+    SafeHash,+    SafeToHash,+  )+import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr, decompactAddr)+import Cardano.Ledger.Shelley.Delegation.Certificates (DCert)+import Cardano.Ledger.Shelley.PParams (Update)+import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))+import Cardano.Ledger.Shelley.TxBody (Wdrl (Wdrl), unWdrl)+import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))+import Cardano.Ledger.TxIn (TxIn (..))+import Cardano.Ledger.Val+  ( DecodeNonNegative,+    Val (..),+    decodeMint,+    decodeNonNegative,+    encodeMint,+    isZero,+  )+import Data.Coders+import Data.Maybe (fromMaybe)+import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)+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 (Proxy (..), Typeable, (:~:) (Refl))+import Data.Word+import GHC.Generics (Generic)+import GHC.Records (HasField (..))+import GHC.Stack (HasCallStack)+import GHC.TypeLits+import NoThunks.Class (InspectHeapNamed (..), NoThunks)+import Prelude hiding (lookup)++data TxOut era+  = TxOutCompact+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+  | TxOutCompactDH+      {-# UNPACK #-} !(CompactAddr (Crypto era))+      !(CompactForm (Core.Value era))+      !(DataHash (Crypto era))

Note that Alonzo's TxOut has separate pattern synonym defined for TxOutCompact and TxOutCompactDH. It is crucial not export these type contractors because they allow to bypass the optimization of unpacking ada only cases

goolord

comment created time in 2 days

pull request commentinput-output-hk/cardano-ledger

Add fast implementation of quicksort that does smart pivot choosing

@TimSheard Do you still need this sorting functionality?

lehins

comment created time in 3 days

PullRequestReviewEvent

Pull request review commentinput-output-hk/cardano-ledger

Sharing of values during deserialization

 import Weigh data Opts = Opts   { -- | Path to the CBOR encoded NewEpochState data type, which will be used to     -- load into sqlite database-    optsLedgerStateBinaryFile :: Maybe FilePath,+    optsNewEpochStateBinaryFile :: Maybe FilePath,+    -- | Path to the CBOR encoded EpochState data type, which will be used to+    -- load into sqlite database+    optsEpochStateBinaryFile :: Maybe FilePath,

Fixed comment

lehins

comment created time in 3 days

PullRequestReviewEvent
PullRequestReviewEvent

Pull request review commentinput-output-hk/cardano-ledger

Sharing of values during deserialization

+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Sharing+  ( FromSharedCBOR (..),+    Interns (..),+    Intern (..),+    fromSharedLensCBOR,+    fromSharedPlusLensCBOR,+    fromNotSharedCBOR,+    interns,+    internsFromMap,+    internsFromVMap,+    toMemptyLens,+  )+where++import Cardano.Binary (Decoder, FromCBOR (..), decodeListLen, dropMap)+import Control.Iterate.SetAlgebra (BiMap (..), biMapFromMap)+import Control.Monad (void)+import Control.Monad.Trans+import Control.Monad.Trans.State.Strict+import Data.Coders (decodeMap, decodeVMap, invalidKey)+import Data.Compact.VMap (VB, VMap, VP)+import qualified Data.Compact.VMap as VMap+import qualified Data.Foldable as F+import Data.Kind+import qualified Data.Map.Strict as Map+import Data.Map.Strict.Internal+import Data.Primitive.Types (Prim)+import Lens.Micro++-- =======================================++data Intern a = Intern+  { internMaybe :: a -> Maybe a,

I added some haddock, let me know if it makes sense and if it is enough of an explanation

lehins

comment created time in 3 days

push eventinput-output-hk/cardano-ledger

Nicholas Clarke

commit sha 5ba0d75116575beab30368966c98a01b93d76a20

Remove symbolic links. Dependencies have now had time to update.

view details

Nicholas Clarke

commit sha 451ae5d8338090e8eb62c0f36509c090e043398e

Remove deprecated packages, modules and functions. A little updating is needed, since it seems a few internal modules were still using `ShelleyBased`.

view details

Nicholas Clarke

commit sha 60e820d7b9dcdb9235e1b44df79826fa4951bc9c

Merge pull request #2555 from input-output-hk/nc/delete Delete all the things

view details

Alexey Kuleshevich

commit sha 67b866a4ad244ff52e7cd34f410be59a93e2dfa1

Fix generation of invalid `collateralPercent`

view details

Alexey Kuleshevich

commit sha 7ef96a683bc0ce6ab1be25ac0ced5c212dea90a7

Fix assumption that `BiMap` is indeed encoded in ascending order and has no duplicates

view details

Nicholas Clarke

commit sha 93c3dec530215a92165b9728a54b75ea4330171f

Merge pull request #2563 from input-output-hk/lehins/minor-bugfixes Minor bugfixes

view details

Nicholas Clarke

commit sha 3b4262026989aca672770dd0396f330788290f1d

Update benchmark transactions. There was a slight change in the transaction format, and the previous transactions were not working. Update them, and update the description of how to generate them.

view details

Nicholas Clarke

commit sha 0ff55dcc1ada9d11c483df56437255ceaba1e049

Remove tpraos symlink

view details

Nicholas Clarke

commit sha 1e30d448872fc9cf6a40e130de1025af9fb890c8

Add benchmark workflow.

view details

Nicholas Clarke

commit sha 1df452b7c110614ffd252e16cf756e58945f9332

Merge pull request #2561 from input-output-hk/nc/bench-tx Benchmarking

view details

Nicholas Clarke

commit sha 4091ae33397e3cb1d1336d2ca5f3510021bffe0e

Eq for MemoBytes should compare the bytes. Two instances of a memoised type are equal iff they have the same bytes. Justification: - We require that deserialisation is left inverse to serialisation. So if we have `serialise x == serialise y` `deserialise (serialise x) == deserialise (serialise y)` `x == y` - `Eq` should be compatible with hashing (e.g. if `a == b`, then `hash a == hash b`). Currently, this is broken. If I serialise a `TxBodyRaw` in two different valid ways (as is perfectly allowed), then the resulting `TxBody` will currently compare as equal but hash to a different value. - In choosing not to require a canonical serialisation, the serialised bytes are an integral part of the type, and must be considered in comparing for equality.

view details

Nicholas Clarke

commit sha 2ef3ed29a16714586f5c44977d2918c8d0edb8bf

Remove unnecessary `Eq` constraints. These are not needed now that `MemoBytes` is always comparable.

view details

Nicholas Clarke

commit sha ecdb4d1f5b5a0a2c6977ea915623d34cd3e1350a

Merge pull request #2565 from input-output-hk/nc/memo-eq Eq for MemoBytes should compare the bytes.

view details

Zachary Churchill

commit sha bdcff02a6d2006db17c35c3f3875d53457cdca08

add ghc event log traces to plutus script eval Co-authored-by: Alex Byaly <alexander.byaly@iohk.io>

view details

Nicholas Clarke

commit sha 08154a40314df7ed20af4ac80900a279349e2d48

Merge pull request #2554 from input-output-hk/zachc/script-tracing add traces to time plutus script evalutaiton

view details

kderme

commit sha fea8f54a5398cad80ad26295d1e9e150b2d97a98

Export an unsafe constructor for Validated Fixes https://github.com/input-output-hk/cardano-ledger/issues/2558

view details

Nicholas Clarke

commit sha 7422095b1c5e8277a993f5f55d5d4e33c30255d1

Merge pull request #2566 from input-output-hk/kderme/unsafe-export Export an unsafe constructor for Validated

view details

TimSheard

commit sha 5c04fb49b4663d86a36e0b3de0d2e81adaf7811b

Sharing during CBOR deserialization: * Added the Cardano.Ledger.Sharing module * This supports sharing when deserializing. Made changes to share `Credential 'Staking crypto` and `KeyHash 'StakePool crypto` in `EpochState` * Add shring to `NonMyopic` * Benchmark EpochState sharing * Avoid order of arguments with NamedFieldPuns in serialization * Simplify `FromSharedCBOR` by removing `StateT` from `fromSharedCBOR` * Apply sharing to `TxOut`

view details

push time in 3 days

Pull request review commentinput-output-hk/cardano-ledger

Sharing of values during deserialization

 deriving newtype instance Typeable crypto => NoThunks (Stake crypto) deriving newtype instance   CC.Crypto crypto => ToCBOR (Stake crypto) -deriving newtype instance-  CC.Crypto crypto => FromCBOR (Stake crypto)+instance CC.Crypto crypto => FromSharedCBOR (Stake crypto) where+  type Share (Stake crypto) = Share (VMap VB VP (Credential 'Staking crypto) (CompactForm Coin))

Yeah, if it wasn't for this problem this whole sharing approach could be pushed further up the stream into FromCBOR class and it would have been backwards compatible. But inability to derive for newtypes is a deal breaker on doing that, althoughusing an extra FromSharedCBOR is that terrible IMHO

lehins

comment created time in 3 days

PullRequestReviewEvent

push eventinput-output-hk/cardano-ledger

Alexey Kuleshevich

commit sha 9d9fb159fb761e90b75ef5d2c50802afe25e836c

Add some more haddock

view details

push time in 3 days

Pull request review commentinput-output-hk/cardano-ledger

Reorganized SetAlgebra by breaking it into 4 modules.

+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Control.Iterate.BiMap where++import Cardano.Binary+  ( Decoder,+    FromCBOR (..),+    ToCBOR (..),+    decodeListLen,+    decodeMapSkel,+    dropMap,+  )+import Codec.CBOR.Encoding (encodeListLen)+import Control.DeepSeq (NFData (rnf))+-- import Data.List (sortBy)+-- import qualified Data.List as List+-- import Data.Set (Set)++import Control.Monad (void)+import Data.Coders (invalidKey)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import NoThunks.Class (NoThunks (..))++-- =================== Basic BiMap =====================+-- For Bijections we define (BiMap v k v).  Reasons we can't use (Data.Bimap k v)+-- 1) We need to enforce that the second argument `v` is in the Ord class, when making it an Iter instance.+-- 2) The constructor for Data.BiMap is not exported, and it implements a Bijection+-- 3) Missing operation 'restrictkeys' and 'withoutkeys' make performant versions of operations  ◁ ⋪ ▷ ⋫ hard.+-- 4) Missing operation 'union', make performant versions of ∪ and ⨃ hard.+-- 5) So we roll our own which is really a (Data.Map k v) with an index that maps v to Set{k}++data BiMap v a b where MkBiMap :: (v ~ b) => !(Map.Map a b) -> !(Map.Map b (Set.Set a)) -> BiMap v a b++--  ^   the 1st and 3rd parameter must be the same:             ^   ^++biMapToMap :: BiMap v a b -> Map a b+biMapToMap (MkBiMap m _) = m++-- ============== begin necessary Cardano.Binary instances ===============+instance (Ord a, Ord b, ToCBOR a, ToCBOR b) => ToCBOR (BiMap b a b) where+  -- The `toCBOR` instance encodes only the forward map. We wrap this in a+  -- length-one list because a _previous_ encoding wrote out both maps, and we+  -- can easily use the list length token to distinguish between them.+  toCBOR (MkBiMap l _) = encodeListLen 1 <> toCBOR l++instance+  forall a b.+  (Ord a, Ord b, FromCBOR a, FromCBOR b) =>+  FromCBOR (BiMap b a b)+  where+  fromCBOR =+    decodeListLen >>= \case+      1 -> decodeMapAsBimap+      -- Previous encoding of 'BiMap' encoded both the forward and reverse+      -- directions. In this case we skip the reverse encoding. Note that,+      -- further, the reverse encoding was from 'b' to 'a', not the current 'b'+      -- to 'Set a', and hence the dropper reflects that.+      2 -> do+        !x <- decodeMapAsBimap+        dropMap (void $ fromCBOR @b) (void $ fromCBOR @a)+        return x+      k -> invalidKey (fromIntegral k)++-- | Decode a serialised CBOR Map as a Bimap+decodeMapAsBimap ::+  (FromCBOR a, FromCBOR b, Ord a, Ord b) =>+  Decoder s (BiMap b a b)+decodeMapAsBimap = decodeMapSkel biMapFromAscDistinctList

This function is broken again, see the fix in 7ef96a683bc0ce6ab1be25ac0ced5c212dea90a7

TimSheard

comment created time in 3 days

more