Merge pull request #734 from IntersectMBO/mgalazyn/fix/correct-certif…

…icates-representation

Change a representation of witnesses in transaction's certificates to an ordered map where a certificate is the key

cardano-api/cardano-api.cabal

@@ -207,6 +207,7 @@ library internal
     mtl,
     network,
     network-mux,
+    ordered-containers,
     ouroboros-consensus ^>=0.22,
     ouroboros-consensus-cardano ^>=0.21,
     ouroboros-consensus-diffusion ^>=0.19,

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
@@ -185,6 +186,7 @@ import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Gen.QuickCheck as Q
 import qualified Hedgehog.Range as Range
 
+
 genAddressByron :: Gen (Address ByronAddr)
 genAddressByron =
   makeByronAddress
@@ -697,33 +699,135 @@ genTxCertificates =
         certs <- Gen.list (Range.constant 0 3) $ genCertificate w
         Gen.choice
           [ pure TxCertificatesNone
-          , pure (TxCertificates w certs $ BuildTxWith mempty)
+          , pure (TxCertificates w $ fromList ((,BuildTxWith Nothing) <$> certs))
           -- TODO: Generate certificates
           ]
     )
 
--- TODO: Add remaining certificates
--- TODO: This should be parameterised on ShelleyBasedEra
-genCertificate :: ShelleyBasedEra era -> Gen (Certificate era)
+genCertificate :: forall era. ShelleyBasedEra era -> Gen (Certificate era)
 genCertificate sbe =
   Gen.choice
-    [ makeStakeAddressRegistrationCertificate <$> genStakeAddressRequirements sbe
-    , makeStakeAddressUnregistrationCertificate <$> genStakeAddressRequirements sbe
+    $ catMaybes
+    [ Just $ makeStakeAddressDelegationCertificate <$> genStakeDelegationRequirements sbe
+    , Just $ makeStakeAddressRegistrationCertificate <$> genStakeAddressRequirements sbe
+    , Just $ makeStakeAddressUnregistrationCertificate <$> genStakeAddressRequirements sbe
+    , Just $ makeStakePoolRegistrationCertificate <$> genStakePoolRegistrationRequirements sbe
+    , Just $ makeStakePoolRetirementCertificate <$> genStakePoolRetirementRequirements sbe
+    , fmap makeCommitteeColdkeyResignationCertificate <$> forEonMaybe genCommitteeColdkeyResignationRequirements
+    , fmap makeCommitteeHotKeyAuthorizationCertificate <$> forEonMaybe genCommitteeHotKeyAuthorizationRequirements
+    , forEonMaybe $ \w ->
+        makeDrepRegistrationCertificate
+          <$> genDRepRegistrationRequirements w
+          <*> conwayEraOnwardsConstraints w (Gen.maybe Q.arbitrary)
+    , fmap makeDrepUnregistrationCertificate <$> forEonMaybe genDRepUnregistrationRequirements
+    , forEonMaybe $ \w ->
+        makeDrepUpdateCertificate
+          <$> genDRepUpdateRequirements w
+          <*> conwayEraOnwardsConstraints w (Gen.maybe Q.arbitrary)
+    , forEonMaybe $ \w ->
+      conwayEraOnwardsConstraints w $
+        makeStakeAddressAndDRepDelegationCertificate w
+          <$> genStakeCredential
+          <*> Q.arbitrary
+          <*> genLovelace
+    , fmap makeMIRCertificate <$> forEonMaybe genMirCertificateRequirements
+    , fmap makeGenesisKeyDelegationCertificate <$> forEonMaybe genGenesisKeyDelegationRequirements
     ]
+  where
+    forEonMaybe :: forall eon a. Eon eon => (eon era -> a) -> Maybe a
+    forEonMaybe f = inEonForShelleyBasedEraMaybe f sbe
+
+genStakeDelegationRequirements :: ShelleyBasedEra era -> Gen (StakeDelegationRequirements era)
+genStakeDelegationRequirements =
+  caseShelleyToBabbageOrConwayEraOnwards
+    ( \w ->
+      StakeDelegationRequirementsPreConway w
+          <$> genStakeCredential
+          <*> genVerificationKeyHash AsStakePoolKey
+    )
+    ( \w ->
+      StakeDelegationRequirementsConwayOnwards w
+          <$> genStakeCredential
+          <*> Q.arbitrary
+    )
 
 genStakeAddressRequirements :: ShelleyBasedEra era -> Gen (StakeAddressRequirements era)
 genStakeAddressRequirements =
   caseShelleyToBabbageOrConwayEraOnwards
     ( \w ->
-        StakeAddrRegistrationPreConway w
+      StakeAddrRegistrationPreConway w
           <$> genStakeCredential
     )
     ( \w ->
-        StakeAddrRegistrationConway w
+      StakeAddrRegistrationConway w
           <$> genLovelace
           <*> genStakeCredential
     )
 
+genStakePoolRegistrationRequirements :: ShelleyBasedEra era -> Gen (StakePoolRegistrationRequirements era)
+genStakePoolRegistrationRequirements =
+  caseShelleyToBabbageOrConwayEraOnwards
+    ( \w ->
+      StakePoolRegistrationRequirementsPreConway w
+          <$> Q.arbitrary
+    )
+    ( \w ->
+      StakePoolRegistrationRequirementsConwayOnwards w
+          <$> Q.arbitrary
+    )
+
+genStakePoolRetirementRequirements :: ShelleyBasedEra era -> Gen (StakePoolRetirementRequirements era)
+genStakePoolRetirementRequirements =
+  caseShelleyToBabbageOrConwayEraOnwards
+    ( \w ->
+      StakePoolRetirementRequirementsPreConway w
+          <$> genVerificationKeyHash AsStakePoolKey
+          <*> Q.arbitrary
+    )
+    ( \w ->
+      StakePoolRetirementRequirementsConwayOnwards w
+          <$> genVerificationKeyHash AsStakePoolKey
+          <*> Q.arbitrary
+    )
+
+genCommitteeColdkeyResignationRequirements :: ConwayEraOnwards era -> Gen (CommitteeColdkeyResignationRequirements era)
+genCommitteeColdkeyResignationRequirements w =
+  conwayEraOnwardsConstraints w $
+    CommitteeColdkeyResignationRequirements w <$> Q.arbitrary <*> Gen.maybe Q.arbitrary
+
+genCommitteeHotKeyAuthorizationRequirements :: ConwayEraOnwards era -> Gen (CommitteeHotKeyAuthorizationRequirements era)
+genCommitteeHotKeyAuthorizationRequirements w =
+  conwayEraOnwardsConstraints w $
+    CommitteeHotKeyAuthorizationRequirements w <$> Q.arbitrary <*> Q.arbitrary
+
+genDRepRegistrationRequirements :: ConwayEraOnwards era -> Gen (DRepRegistrationRequirements era)
+genDRepRegistrationRequirements w =
+  conwayEraOnwardsConstraints w $
+    DRepRegistrationRequirements w <$> Q.arbitrary <*> genLovelace
+
+genDRepUnregistrationRequirements :: ConwayEraOnwards era -> Gen (DRepUnregistrationRequirements era)
+genDRepUnregistrationRequirements w =
+  conwayEraOnwardsConstraints w $
+    DRepUnregistrationRequirements w <$> Q.arbitrary  <*> genLovelace
+
+genDRepUpdateRequirements :: ConwayEraOnwards era -> Gen (DRepUpdateRequirements era)
+genDRepUpdateRequirements w =
+  conwayEraOnwardsConstraints w $
+    DRepUpdateRequirements w <$> Q.arbitrary
+
+genGenesisKeyDelegationRequirements :: ShelleyToBabbageEra era -> Gen (GenesisKeyDelegationRequirements era)
+genGenesisKeyDelegationRequirements w =
+  shelleyToBabbageEraConstraints w $
+    GenesisKeyDelegationRequirements w
+     <$> genVerificationKeyHash AsGenesisKey
+     <*> genVerificationKeyHash AsGenesisDelegateKey
+     <*> genVerificationKeyHash AsVrfKey
+
+genMirCertificateRequirements :: ShelleyToBabbageEra era -> Gen (MirCertificateRequirements era)
+genMirCertificateRequirements w =
+  shelleyToBabbageEraConstraints w $
+    MirCertificateRequirements w <$> Q.arbitrary <*> Q.arbitrary
+
 genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era)
 genTxUpdateProposal sbe =
   Gen.choice $

cardano-api/internal/Cardano/Api/Certificate.hs

@@ -142,6 +142,8 @@ data Certificate era where
 
 deriving instance Eq (Certificate era)
 
+deriving instance Ord (Certificate era)
+
 deriving instance Show (Certificate era)
 
 instance Typeable era => HasTypeProxy (Certificate era) where

cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs

@@ -55,6 +55,8 @@ deriving instance Show (ConwayEraOnwards era)
 
 deriving instance Eq (ConwayEraOnwards era)
 
+deriving instance Ord (ConwayEraOnwards era)
+
 instance Eon ConwayEraOnwards where
   inEonForEra no yes = \case
     ByronEra -> no

cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs

@@ -50,6 +50,8 @@ deriving instance Show (ShelleyToBabbageEra era)
 
 deriving instance Eq (ShelleyToBabbageEra era)
 
+deriving instance Ord (ShelleyToBabbageEra era)
+
 instance Eon ShelleyToBabbageEra where
   inEonForEra no yes = \case
     ByronEra -> no

cardano-api/internal/Cardano/Api/Fees.hs

@@ -245,10 +245,7 @@ estimateBalancedTxBody
     --  1. Subtract certificate and proposal deposits
     -- from the total available Ada value!
     -- Page 24 Shelley ledger spec
-    let certificates =
-          case txCertificates txbodycontent1 of
-            TxCertificatesNone -> []
-            TxCertificates _ certs _ -> map toShelleyCertificate certs
+    let certificates = convCertificates sbe $ txCertificates txbodycontent1
 
         proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
         proposalProcedures =
@@ -478,8 +475,9 @@ estimateTransactionKeyWitnessCount
             length [() | (_, _, BuildTxWith KeyWitness{}) <- withdrawals]
           _ -> 0
         + case txCertificates of
-          TxCertificates _ _ (BuildTxWith witnesses) ->
-            length [() | (_, KeyWitness{}) <- witnesses]
+          TxCertificates _ credWits ->
+            length
+              [() | (_, BuildTxWith (Just (_, KeyWitness{}))) <- toList credWits]
           _ -> 0
         + case txUpdateProposal of
           TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) ->
@@ -1500,18 +1498,27 @@ substituteExecutionUnits
       :: TxCertificates BuildTx era
       -> Either (TxBodyErrorAutoBalance era) (TxCertificates BuildTx era)
     mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone
-    mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported certs _) =
+    mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported _) = do
       let mappedScriptWitnesses
-            :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))]
+            :: [ ( Certificate era
+                 , Either
+                    (TxBodyErrorAutoBalance era)
+                    ( BuildTxWith
+                        BuildTx
+                        ( Maybe
+                            ( StakeCredential
+                            , Witness WitCtxStake era
+                            )
+                        )
+                    )
+                 )
+               ]
           mappedScriptWitnesses =
-            [ (stakeCred, witness')
-            | (ix, _, stakeCred, witness) <- indexTxCertificates txCertificates'
-            , let witness' = adjustScriptWitness (substituteExecUnits ix) witness
+            [ (cert, BuildTxWith . Just . (stakeCred,) <$> eWitness')
+            | (ix, cert, stakeCred, witness) <- indexTxCertificates txCertificates'
+            , let eWitness' = adjustScriptWitness (substituteExecUnits ix) witness
             ]
-       in TxCertificates supported certs . BuildTxWith
-            <$> traverse
-              (\(sCred, eScriptWitness) -> (sCred,) <$> eScriptWitness)
-              mappedScriptWitnesses
+      TxCertificates supported . fromList <$> traverseScriptWitnesses mappedScriptWitnesses
 
     mapScriptWitnessesVotes
       :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era))

cardano-api/internal/Cardano/Api/Script.hs

@@ -587,6 +587,8 @@ data ScriptLanguageInEra lang era where
 
 deriving instance Eq (ScriptLanguageInEra lang era)
 
+deriving instance Ord (ScriptLanguageInEra lang era)
+
 deriving instance Show (ScriptLanguageInEra lang era)
 
 instance ToJSON (ScriptLanguageInEra lang era) where
@@ -764,7 +766,7 @@ data ScriptWitness witctx era where
 
 deriving instance Show (ScriptWitness witctx era)
 
--- The GADT in the SimpleScriptWitness constructor requires a custom instance
+-- The existential in the SimpleScriptWitness constructor requires a custom instance
 instance Eq (ScriptWitness witctx era) where
   (==)
     (SimpleScriptWitness langInEra script)

cardano-api/internal/Cardano/Api/Tx/Body.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -135,6 +136,7 @@ module Cardano.Api.Tx.Body
   , TxWithdrawals (..)
   , indexTxWithdrawals
   , TxCertificates (..)
+  , mkTxCertificates
   , indexTxCertificates
   , TxUpdateProposal (..)
   , TxMintValue (..)
@@ -302,6 +304,7 @@ import           Data.Functor (($>))
 import           Data.List (sortBy)
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NonEmpty
+import           Data.Map.Ordered.Strict (OMap)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
@@ -1280,38 +1283,61 @@ indexTxWithdrawals (TxWithdrawals _ withdrawals) =
 --
 
 data TxCertificates build era where
+  -- | No certificates
   TxCertificatesNone
     :: TxCertificates build era
+  -- | Represents certificates present in transaction. Prefer using 'mkTxCertificates' to constructing
+  -- this type with a constructor
   TxCertificates
     :: ShelleyBasedEra era
-    -> [Certificate era]
-    -> BuildTxWith build [(StakeCredential, Witness WitCtxStake era)]
-    -- ^ There can be more than one script witness per stake credential
+    -> OMap
+        (Certificate era)
+        ( BuildTxWith
+            build
+            (Maybe (StakeCredential, Witness WitCtxStake era))
+        )
     -> TxCertificates build era
 
 deriving instance Eq (TxCertificates build era)
 
 deriving instance Show (TxCertificates build era)
 
--- | Index certificates with witnesses by the order they appear in the list (in the transaction). If there are multiple witnesses for the same stake credential, they will be present multiple times with the same index.
--- are multiple witnesses for the credential, there will be multiple entries for
+-- | Create 'TxCertificates'. Note that 'Certificate era' will be deduplicated. Only Certificates with a
+-- stake credential will be in the result.
+--
+-- Note that, when building a transaction in Conway era, a witness is not required for staking credential
+-- registration, but this is only the case during the transitional period of Conway era and only for staking
+-- credential registration certificates without a deposit. Future eras will require a witness for
+-- registration certificates, because the one without a deposit will be removed.
+mkTxCertificates
+  :: Applicative (BuildTxWith build)
+  => ShelleyBasedEra era
+  -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
+  -> TxCertificates build era
+mkTxCertificates _ [] = TxCertificatesNone
+mkTxCertificates sbe certs = TxCertificates sbe . fromList $ map getStakeCred certs
+ where
+  getStakeCred (cert, mWit) = do
+    let wit =
+          maybe
+            (KeyWitness KeyWitnessForStakeAddr)
+            (ScriptWitness ScriptWitnessForStakeAddr)
+            mWit
+    ( cert
+      , pure $
+          (,wit) <$> selectStakeCredentialWitness cert
+      )
+
+-- | Index certificates with witnesses by the order they appear in the list (in the transaction).
 -- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf
 indexTxCertificates
   :: TxCertificates BuildTx era
   -> [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)]
 indexTxCertificates TxCertificatesNone = []
-indexTxCertificates (TxCertificates _ certs (BuildTxWith witnesses)) =
-  [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, wit)
-  | (ix, cert) <- zip [0 ..] certs
-  , stakeCred <- maybeToList (selectStakeCredentialWitness cert)
-  , wit <- findAll stakeCred witnesses
+indexTxCertificates (TxCertificates _ certsWits) =
+  [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, witness)
+  | (ix, (cert, BuildTxWith (Just (stakeCred, witness)))) <- zip [0 ..] $ toList certsWits
   ]
- where
-  findAll needle = map snd . filter ((==) needle . fst)
-
--- ----------------------------------------------------------------------------
--- Transaction update proposal (era-dependent)
---
 
 data TxUpdateProposal era where
   TxUpdateProposalNone :: TxUpdateProposal era
@@ -2538,7 +2564,8 @@ fromLedgerTxCertificates sbe body =
     let certificates = body ^. L.certsTxBodyL
      in if null certificates
           then TxCertificatesNone
-          else TxCertificates sbe (map (fromShelleyCertificate sbe) $ toList certificates) ViewTx
+          else
+            TxCertificates sbe . fromList $ map ((,ViewTx) . fromShelleyCertificate sbe) $ toList certificates
 
 maybeFromLedgerTxUpdateProposal
   :: ()
@@ -2646,7 +2673,7 @@ convCertificates
   -> Seq.StrictSeq (Shelley.TxCert (ShelleyLedgerEra era))
 convCertificates _ = \case
   TxCertificatesNone -> Seq.empty
-  TxCertificates _ cs _ -> fromList (map toShelleyCertificate cs)
+  TxCertificates _ cs -> fromList . map (toShelleyCertificate . fst) $ toList cs
 
 convWithdrawals :: TxWithdrawals build era -> L.Withdrawals StandardCrypto
 convWithdrawals txWithdrawals =