Use only stake credentials required in witnessing

cardano-api/cardano-api.cabal

@@ -205,6 +205,7 @@ library internal
                       , unordered-containers >= 0.2.11
                       , vector
                       , yaml
+                      , pretty-simple
 
 library
   import:               project-config

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

@@ -55,20 +55,21 @@ module Cardano.Api.Certificate (
     makeGenesisKeyDelegationCertificate,
     Ledger.MIRTarget (..),
     Ledger.MIRPot(..),
+    selectStakeCredentialWitness,
 
     -- * Internal conversion functions
     toShelleyCertificate,
     fromShelleyCertificate,
     toShelleyPoolParams,
     fromShelleyPoolParams,
 
+
     -- * Data family instances
     AsType(..),
 
     -- * Internal functions
     filterUnRegCreds,
     filterUnRegDRepCreds,
-    selectStakeCredential,
   ) where
 
 import           Cardano.Api.Address
@@ -86,7 +87,7 @@ import qualified Cardano.Api.ReexposeLedger as Ledger
 import           Cardano.Api.SerialiseCBOR
 import           Cardano.Api.SerialiseTextEnvelope
 import           Cardano.Api.StakePoolMetadata
-import           Cardano.Api.Utils (noInlineMaybeToStrictMaybe)
+import           Cardano.Api.Utils (noInlineMaybeToStrictMaybe, trace')
 import           Cardano.Api.Value
 
 import           Data.ByteString (ByteString)
@@ -467,29 +468,31 @@ makeStakeAddressAndDRepDelegationCertificate w cred delegatee deposit =
 -- Helper functions
 --
 
-selectStakeCredential
-  :: Certificate era -> Maybe StakeCredential
-selectStakeCredential = fmap fromShelleyStakeCredential . \case
+-- | Get the stake credential witness for a certificate that requires it.
+-- Only stake address deregistration and delegation requires witnessing (witness can be script or key).
+selectStakeCredentialWitness
+  :: Certificate era
+  -> Maybe StakeCredential
+selectStakeCredentialWitness = fmap fromShelleyStakeCredential . \case
   ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $
     case shelleyCert of
-      Ledger.RegTxCert sCred           -> Just sCred
-      Ledger.UnRegTxCert sCred         -> Just sCred
-      Ledger.DelegStakeTxCert sCred _  -> Just sCred
+      Ledger.RegTxCert _               -> Nothing -- contains stake cred
+      Ledger.UnRegTxCert sCred         -> trace' "unregtx" $ Just sCred
+      Ledger.DelegStakeTxCert sCred _  -> trace' "delegtx" $ Just sCred
       -- StakePool is always controlled by key, i.e. it is never a script. In other words,
       -- @Credential StakePool@ cannot exist, because @ScriptHashObj@ constructor can't be used for that type.
       Ledger.RegPoolTxCert _           -> Nothing -- contains StakePool key which cannot be a credential
       Ledger.RetirePoolTxCert _ _      -> Nothing -- contains StakePool key which cannot be a credential
-
       Ledger.MirTxCert _               -> Nothing
       Ledger.GenesisDelegTxCert{}      -> Nothing
 
   ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $
     case conwayCert of
       Ledger.RegPoolTxCert _                 -> Nothing -- contains StakePool key which cannot be a credential
       Ledger.RetirePoolTxCert _ _            -> Nothing -- contains StakePool key which cannot be a credential
-      Ledger.RegTxCert sCred                 -> Just sCred
+      Ledger.RegTxCert{}                     -> Nothing -- contains stake cred
       Ledger.UnRegTxCert sCred               -> Just sCred
-      Ledger.RegDepositTxCert sCred _        -> Just sCred
+      Ledger.RegDepositTxCert{}              -> Nothing -- contains stake cred
       Ledger.UnRegDepositTxCert sCred _      -> Just sCred
       Ledger.DelegTxCert sCred _             -> Just sCred
       Ledger.RegDepositDelegTxCert sCred _ _ -> Just sCred
@@ -499,6 +502,7 @@ selectStakeCredential = fmap fromShelleyStakeCredential . \case
       Ledger.UnRegDRepTxCert{}               -> Nothing
       Ledger.UpdateDRepTxCert{}              -> Nothing
 
+
 filterUnRegCreds
   :: Certificate era -> Maybe StakeCredential
 filterUnRegCreds = fmap fromShelleyStakeCredential . \case
@@ -523,7 +527,7 @@ filterUnRegCreds = fmap fromShelleyStakeCredential . \case
       Ledger.DelegTxCert _ _             -> Nothing
       Ledger.RegDepositDelegTxCert{}     -> Nothing
       Ledger.AuthCommitteeHotKeyTxCert{} -> Nothing
-      Ledger.ResignCommitteeColdTxCert _ _ -> Nothing
+      Ledger.ResignCommitteeColdTxCert{} -> Nothing
       Ledger.RegDRepTxCert{}             -> Nothing
       Ledger.UnRegDRepTxCert{}           -> Nothing
       Ledger.UpdateDRepTxCert{}          -> Nothing
@@ -544,7 +548,7 @@ filterUnRegDRepCreds = \case
       Ledger.DelegTxCert _ _             -> Nothing
       Ledger.RegDepositDelegTxCert{}     -> Nothing
       Ledger.AuthCommitteeHotKeyTxCert{} -> Nothing
-      Ledger.ResignCommitteeColdTxCert _ _ -> Nothing
+      Ledger.ResignCommitteeColdTxCert{} -> Nothing
       Ledger.RegDRepTxCert{}             -> Nothing
       Ledger.UnRegDRepTxCert cred _      -> Just cred
       Ledger.UpdateDRepTxCert{}          -> Nothing

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

@@ -1150,7 +1150,7 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent {
               [ (stakecred, ScriptWitness ctx <$> witness')
                 -- The certs are indexed in list order
               | (ix, cert) <- zip [0..] certs
-              , stakecred  <- maybeToList (selectStakeCredential cert)
+              , stakecred  <- maybeToList (selectStakeCredentialWitness cert)
               , ScriptWitness ctx witness
                            <- maybeToList (Map.lookup stakecred witnesses)
               , let witness' = f (ScriptWitnessIndexCertificate ix) witness

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

@@ -249,13 +249,17 @@ import qualified Data.Set as Set
 import           Data.String
 import           Data.Text (Text)
 import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
 import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
 import           Data.Word (Word16, Word32, Word64)
 import           Lens.Micro hiding (ix)
 import           Lens.Micro.Extras (view)
 import qualified Text.Parsec as Parsec
 import           Text.Parsec ((<?>))
 import qualified Text.Parsec.String as Parsec
+import           Text.Pretty.Simple (pShow)
+
+import           Debug.Trace
 
 -- | Indicates whether a script is expected to fail or pass validation.
 data ScriptValidity
@@ -3228,10 +3232,10 @@ collectTxBodyScriptWitnesses _ TxBodyContent {
                                txMintValue
                              } =
     concat
-      [ scriptWitnessesTxIns        txIns
-      , scriptWitnessesWithdrawals  txWithdrawals
-      , scriptWitnessesCertificates txCertificates
-      , scriptWitnessesMinting      txMintValue
+      [ trace' "txins" $ scriptWitnessesTxIns        txIns
+      , trace' "withs" $ scriptWitnessesWithdrawals  txWithdrawals
+      , trace' "certs" $ scriptWitnessesCertificates txCertificates
+      , trace' "mint" $ scriptWitnessesMinting      txMintValue
       ]
   where
     scriptWitnessesTxIns
@@ -3262,9 +3266,9 @@ collectTxBodyScriptWitnesses _ TxBodyContent {
     scriptWitnessesCertificates (TxCertificates _ certs (BuildTxWith witnesses)) =
         [ (ScriptWitnessIndexCertificate ix, AnyScriptWitness witness)
           -- The certs are indexed in list order
-        | (ix, cert) <- zip [0..] certs
+        | (ix, cert) <- zip [0..] (trace' "WWWCL" certs)
         , ScriptWitness _ witness <- maybeToList $ do
-                                       stakecred <- selectStakeCredential cert
+                                       stakecred <- selectStakeCredentialWitness cert
                                        Map.lookup stakecred witnesses
         ]
 

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

@@ -29,6 +29,7 @@ module Cardano.Api.Utils
 
     -- ** CLI option parsing
   , bounded
+  , trace'
   ) where
 
 import           Cardano.Api.Eras
@@ -53,6 +54,9 @@ import qualified Text.Parsec as Parsec
 import qualified Text.Parsec.String as Parsec
 import qualified Text.ParserCombinators.Parsec.Error as Parsec
 import qualified Text.Read as Read
+import Text.Pretty.Simple (pShow)
+import qualified Data.Text.Lazy as TL
+import Debug.Trace (traceWith)
 
 
 (?!) :: Maybe a -> e -> Either e a
@@ -140,3 +144,8 @@ modifyWith :: ()
   => (a -> a)
   -> (a -> a)
 modifyWith = id
+
+trace' :: String -> a -> a
+trace' _ = id
+-- trace' :: Show a => String -> a -> a
+-- trace' l = traceWith (\x -> "📜 " <> l <> ":\r\n" <> TL.unpack (pShow x))

cardano-api/src/Cardano/Api.hs

@@ -862,6 +862,7 @@ module Cardano.Api (
     makeGenesisKeyDelegationCertificate,
     MIRTarget (..),
     MIRPot(..),
+    selectStakeCredentialWitness,
 
     -- * Protocol parameter updates
     UpdateProposal(..),