Merge pull request #5215 from IntersectMBO/jj/dijkstra-txbody-guards

Add guards field to DijkstraTxBody

Author: lehins

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.14.0.0
 
+* Add `reqSignerHashesTxBodyG`
 * Add `mkScriptIntegrity`
 * Changed the type of `hashScriptIntegrity`
 * Add `ScriptIntegrityHashMismatch`

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs

@@ -285,7 +285,7 @@ transTxBodyWithdrawals txBody = Map.toList (transWithdrawals (txBody ^. withdraw
 -- | Translate all required signers produced by `reqSignerHashesTxBodyL`s from within a
 -- `TxBody`
 transTxBodyReqSignerHashes :: AlonzoEraTxBody era => TxBody era -> [PV1.PubKeyHash]
-transTxBodyReqSignerHashes txBody = transKeyHash <$> Set.toList (txBody ^. reqSignerHashesTxBodyL)
+transTxBodyReqSignerHashes txBody = transKeyHash <$> Set.toList (txBody ^. reqSignerHashesTxBodyG)
 
 -- | Translate all `TxDats`s from within `TxWits`
 transTxWitsDatums :: AlonzoEraTxWits era => TxWits era -> [(PV1.DatumHash, PV1.Datum)]

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -140,7 +141,13 @@ type ScriptIntegrityHash = SafeHash EraIndependentScriptIntegrity
 class (MaryEraTxBody era, AlonzoEraTxOut era) => AlonzoEraTxBody era where
   collateralInputsTxBodyL :: Lens' (TxBody era) (Set TxIn)
 
-  reqSignerHashesTxBodyL :: Lens' (TxBody era) (Set (KeyHash 'Witness))
+  reqSignerHashesTxBodyL :: ProtVerAtMost era 11 => Lens' (TxBody era) (Set (KeyHash 'Witness))
+
+  reqSignerHashesTxBodyG ::
+    SimpleGetter (TxBody era) (Set (KeyHash Witness))
+  default reqSignerHashesTxBodyG ::
+    ProtVerAtMost era 11 => SimpleGetter (TxBody era) (Set (KeyHash Witness))
+  reqSignerHashesTxBodyG = reqSignerHashesTxBodyL
 
   scriptIntegrityHashTxBodyL ::
     Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/UTxO.hs

@@ -327,5 +327,5 @@ getAlonzoWitsVKeyNeeded ::
   Set.Set (KeyHash 'Witness)
 getAlonzoWitsVKeyNeeded certState utxo txBody =
   getShelleyWitsVKeyNeeded certState utxo txBody
-    `Set.union` (txBody ^. reqSignerHashesTxBodyL)
+    `Set.union` (txBody ^. reqSignerHashesTxBodyG)
 {-# INLINEABLE getAlonzoWitsVKeyNeeded #-}

eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs

@@ -178,7 +178,7 @@ getConwayWitsVKeyNeeded ::
   Set.Set (KeyHash 'Witness)
 getConwayWitsVKeyNeeded utxo txBody =
   getShelleyWitsVKeyNeededNoGov utxo txBody
-    `Set.union` (txBody ^. reqSignerHashesTxBodyL)
+    `Set.union` (txBody ^. reqSignerHashesTxBodyG)
     `Set.union` voterWitnesses txBody
 
 voterWitnesses ::

eras/dijkstra/cardano-ledger-dijkstra.cabal

@@ -129,6 +129,7 @@ library testlib
   build-depends:
     base,
     bytestring,
+    cardano-data,
     cardano-ledger-alonzo:testlib,
     cardano-ledger-babbage:{cardano-ledger-babbage, testlib},
     cardano-ledger-binary,

eras/dijkstra/cddl-files/dijkstra.cddl

@@ -139,7 +139,7 @@ transaction_body =
   , ? 9  : mint                            
   , ? 11 : script_data_hash                
   , ? 13 : nonempty_set<transaction_input>
-  , ? 14 : required_signers                
+  , ? 14 : guards                          
   , ? 15 : network_id                      
   , ? 16 : transaction_output              
   , ? 17 : coin                            
@@ -503,7 +503,7 @@ script_data_hash = hash32
 
 nonempty_set<a0> = #6.258([+ a0])/ [+ a0]
 
-required_signers = nonempty_set<addr_keyhash>
+guards = nonempty_set<addr_keyhash>/ nonempty_oset<credential>
 
 network_id = 0/ 1
 

eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxBody.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
@@ -12,10 +13,12 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Ledger.Dijkstra.TxBody (
+  DijkstraEraTxBody (..),
   TxBody (
     MkDijkstraTxBody,
     DijkstraTxBody,
@@ -29,15 +32,15 @@ module Cardano.Ledger.Dijkstra.TxBody (
     dtbWithdrawals,
     dtbTxfee,
     dtbVldt,
-    dtbReqSignerHashes,
     dtbMint,
     dtbScriptIntegrityHash,
     dtbAdHash,
     dtbTxNetworkId,
     dtbVotingProcedures,
     dtbProposalProcedures,
     dtbCurrentTreasuryValue,
-    dtbTreasuryDonation
+    dtbTreasuryDonation,
+    dtbGuards
   ),
   upgradeProposals,
   upgradeGovAction,
@@ -53,10 +56,14 @@ import Cardano.Ledger.BaseTypes (Network, StrictMaybe (..), fromSMaybe)
 import Cardano.Ledger.Binary (
   Annotator,
   DecCBOR (..),
+  Decoder,
   EncCBOR (..),
   Sized (..),
   ToCBOR,
+  TokenType (..),
+  liftST,
   mkSized,
+  peekTokenType,
  )
 import Cardano.Ledger.Binary.Coders (
   Decode (..),
@@ -87,9 +94,11 @@ import Cardano.Ledger.Conway.TxBody (
   conwayRedeemerPointerInverse,
  )
 import Cardano.Ledger.Core (EraPParams (..))
+import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
 import Cardano.Ledger.Dijkstra.Scripts ()
 import Cardano.Ledger.Dijkstra.TxOut ()
+import Cardano.Ledger.Keys (HasKeyRole (..))
 import Cardano.Ledger.Mary.Value (MultiAsset, policies)
 import Cardano.Ledger.MemoBytes (
   EqRaw,
@@ -106,11 +115,14 @@ import Cardano.Ledger.TxIn (TxIn)
 import Cardano.Ledger.Val (Val (..))
 import Control.DeepSeq (NFData)
 import Data.Coerce (coerce)
+import Data.OSet.Strict (OSet, decodeOSet)
 import qualified Data.OSet.Strict as OSet
+import Data.STRef (newSTRef, readSTRef, writeSTRef)
 import Data.Sequence.Strict (StrictSeq)
-import Data.Set (Set)
+import Data.Set (Set, foldr')
+import qualified Data.Set as Set
 import GHC.Generics (Generic)
-import Lens.Micro (to, (^.))
+import Lens.Micro (Lens', to, (^.))
 import NoThunks.Class (NoThunks)
 
 data DijkstraTxBodyRaw = DijkstraTxBodyRaw
@@ -124,7 +136,7 @@ data DijkstraTxBodyRaw = DijkstraTxBodyRaw
   , dtbrWithdrawals :: !Withdrawals
   , dtbrFee :: !Coin
   , dtbrVldt :: !ValidityInterval
-  , dtbrReqSignerHashes :: !(Set (KeyHash 'Witness))
+  , dtbrGuards :: !(OSet (Credential Guard))
   , dtbrMint :: !MultiAsset
   , dtbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash)
   , dtbrAuxDataHash :: !(StrictMaybe TxAuxDataHash)
@@ -217,11 +229,9 @@ instance DecCBOR DijkstraTxBodyRaw where
           (\x tx -> tx {dtbrCollateralInputs = x})
           From
       bodyFields 14 =
-        fieldGuarded
-          (emptyFailure "Required Signer Hashes" "non-empty")
-          null
-          (\x tx -> tx {dtbrReqSignerHashes = x})
-          From
+        ofield
+          (\x tx -> tx {dtbrGuards = fromSMaybe mempty x})
+          (D decodeGuards)
       bodyFields 15 = ofield (\x tx -> tx {dtbrNetworkId = x}) From
       bodyFields 16 = ofield (\x tx -> tx {dtbrCollateralReturn = x}) From
       bodyFields 17 = ofield (\x tx -> tx {dtbrTotalCollateral = x}) From
@@ -278,7 +288,7 @@ encodeTxBodyRaw DijkstraTxBodyRaw {..} =
         !> Omit OSet.null (Key 4 (To dtbrCerts))
         !> Omit (null . unWithdrawals) (Key 5 (To dtbrWithdrawals))
         !> encodeKeyedStrictMaybe 8 bot
-        !> Omit null (Key 14 (To dtbrReqSignerHashes))
+        !> Omit null (Key 14 (To dtbrGuards))
         !> Omit (== mempty) (Key 9 (To dtbrMint))
         !> encodeKeyedStrictMaybe 11 dtbrScriptIntegrityHash
         !> encodeKeyedStrictMaybe 7 dtbrAuxDataHash
@@ -310,7 +320,7 @@ pattern DijkstraTxBody ::
   Withdrawals ->
   Coin ->
   ValidityInterval ->
-  Set (KeyHash 'Witness) ->
+  OSet (Credential Guard) ->
   MultiAsset ->
   StrictMaybe ScriptIntegrityHash ->
   StrictMaybe TxAuxDataHash ->
@@ -331,7 +341,7 @@ pattern DijkstraTxBody
   , dtbWithdrawals
   , dtbTxfee
   , dtbVldt
-  , dtbReqSignerHashes
+  , dtbGuards
   , dtbMint
   , dtbScriptIntegrityHash
   , dtbAdHash
@@ -353,7 +363,7 @@ pattern DijkstraTxBody
         , dtbrWithdrawals = dtbWithdrawals
         , dtbrFee = dtbTxfee
         , dtbrVldt = dtbVldt
-        , dtbrReqSignerHashes = dtbReqSignerHashes
+        , dtbrGuards = dtbGuards
         , dtbrMint = dtbMint
         , dtbrScriptIntegrityHash = dtbScriptIntegrityHash
         , dtbrAuxDataHash = dtbAdHash
@@ -376,7 +386,7 @@ pattern DijkstraTxBody
       withdrawalsX
       txfeeX
       vldtX
-      reqSignerHashesX
+      guards
       mintX
       scriptIntegrityHashX
       adHashX
@@ -397,7 +407,7 @@ pattern DijkstraTxBody
             withdrawalsX
             txfeeX
             vldtX
-            reqSignerHashesX
+            guards
             mintX
             scriptIntegrityHashX
             adHashX
@@ -514,11 +524,15 @@ instance AlonzoEraTxBody DijkstraEra where
       \txb x -> txb {dtbrCollateralInputs = x}
   {-# INLINE collateralInputsTxBodyL #-}
 
-  reqSignerHashesTxBodyL =
-    lensMemoRawType @DijkstraEra dtbrReqSignerHashes $
-      \txb x -> txb {dtbrReqSignerHashes = x}
+  reqSignerHashesTxBodyL = notSupportedInThisEraL
   {-# INLINE reqSignerHashesTxBodyL #-}
 
+  reqSignerHashesTxBodyG = guardsTxBodyL . to (foldr' insertKeyHash mempty . OSet.toSet)
+    where
+      insertKeyHash (KeyHashObj kh) = Set.insert $ coerceKeyRole kh
+      insertKeyHash (ScriptHashObj _) = id
+  {-# INLINE reqSignerHashesTxBodyG #-}
+
   scriptIntegrityHashTxBodyL =
     lensMemoRawType @DijkstraEra dtbrScriptIntegrityHash $
       \txb x -> txb {dtbrScriptIntegrityHash = x}
@@ -577,3 +591,34 @@ instance ConwayEraTxBody DijkstraEra where
     lensMemoRawType @DijkstraEra dtbrTreasuryDonation $
       \txb x -> txb {dtbrTreasuryDonation = x}
   {-# INLINE treasuryDonationTxBodyL #-}
+
+class ConwayEraTxBody era => DijkstraEraTxBody era where
+  guardsTxBodyL :: Lens' (TxBody era) (OSet (Credential Guard))
+
+instance DijkstraEraTxBody DijkstraEra where
+  {-# INLINE guardsTxBodyL #-}
+  guardsTxBodyL =
+    lensMemoRawType @DijkstraEra dtbrGuards $
+      \txb x -> txb {dtbrGuards = x}
+
+-- | Decoder for decoding guards in a backwards-compatible manner. It peeks at
+-- the first element and if it's a credential, it decodes the rest of the
+-- elements as credentials. If the first element is a plain keyhash, it will
+-- decode rest of the elements as keyhashes.
+decodeGuards :: Decoder s (OSet (Credential Guard))
+decodeGuards = do
+  elementsAreCredentials <- liftST $ newSTRef Nothing
+  let
+    decodeElement = do
+      liftST (readSTRef elementsAreCredentials) >>= \case
+        Nothing -> do
+          tokenType <- peekTokenType
+          liftST . writeSTRef elementsAreCredentials . Just $ case tokenType of
+            TypeListLen -> True
+            TypeListLen64 -> True
+            TypeListLenIndef -> True
+            _ -> False
+          decodeElement
+        Just True -> decCBOR
+        Just False -> KeyHashObj <$> decCBOR
+  decodeOSet decodeElement

eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/CDDL.hs

@@ -147,7 +147,7 @@ transaction_body =
       , opt (idx 9 ==> mint)
       , opt (idx 11 ==> script_data_hash)
       , opt (idx 13 ==> nonempty_set transaction_input)
-      , opt (idx 14 ==> required_signers)
+      , opt (idx 14 ==> guards)
       , opt (idx 15 ==> network_id)
       , opt (idx 16 ==> transaction_output)
       , opt (idx 17 ==> coin)
@@ -158,6 +158,12 @@ transaction_body =
       , opt (idx 22 ==> positive_coin)
       ]
 
+guards :: Rule
+guards =
+  "guards"
+    =:= nonempty_set addr_keyhash
+    / nonempty_oset credential
+
 proposal_procedure :: Rule
 proposal_procedure =
   "proposal_procedure"

eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs

@@ -27,12 +27,14 @@ import Cardano.Ledger.Plutus.Data (
 import Cardano.Ledger.Plutus.Language (Language (..))
 import Cardano.Ledger.Shelley.API (
   ApplyTxError (..),
+  Credential (..),
   RewardAccount (..),
   TxId (..),
  )
 import Cardano.Ledger.TxIn (mkTxInPartial)
 import Control.State.Transition.Extended (Embed (..))
 import qualified Data.Map.Strict as Map
+import qualified Data.OSet.Strict as OSet
 import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
 import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds)
@@ -54,6 +56,7 @@ import Test.Cardano.Ledger.Shelley.Examples (
   exampleStakeKey,
   keyToCredential,
   mkKeyHash,
+  mkScriptHash,
  )
 
 ledgerExamples :: LedgerExamples DijkstraEra
@@ -96,7 +99,7 @@ exampleTxBodyDijkstra =
     )
     (Coin 999) -- txfee
     (ValidityInterval (SJust (SlotNo 2)) (SJust (SlotNo 4))) -- txvldt
-    (Set.singleton $ mkKeyHash 212) -- reqSignerHashes
+    (OSet.fromList [KeyHashObj $ mkKeyHash 212, ScriptHashObj $ mkScriptHash 213]) -- guards
     exampleMultiAsset -- mint
     (SJust $ mkDummySafeHash 42) -- scriptIntegrityHash
     (SJust . TxAuxDataHash $ mkDummySafeHash 42) -- adHash