Merge pull request #383 from input-output-hk/mgalazyn/fix/use-only-st…

…ake-creds-for-witnesses

Expose `stakeCredentialWitness` function, which returns only stake credentials for the certificates requiring witnessing: delegation and deregistration

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
@@ -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.RegTxCert _               -> Nothing -- contains stake cred
       Ledger.UnRegTxCert sCred         -> Just sCred
       Ledger.DelegStakeTxCert sCred _  -> 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

@@ -1146,7 +1146,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

@@ -263,6 +263,7 @@ import qualified Text.Parsec as Parsec
 import           Text.Parsec ((<?>))
 import qualified Text.Parsec.String as Parsec
 
+
 -- | Indicates whether a script is expected to fail or pass validation.
 data ScriptValidity
   = ScriptInvalid -- ^ Script is expected to fail validation.
@@ -1815,7 +1816,8 @@ createTransactionBody sbe bc =
           mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData
             & A.certsTxBodyL sbe            .~ certs
             & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc)
-            & ( appEndo $ mconcat
+            & appEndo
+                ( mconcat
                   [ setUpdateProposal
                   , setInvalidBefore
                   , setMint
@@ -1826,7 +1828,7 @@ createTransactionBody sbe bc =
                   , setCollateralReturn
                   , setTotalCollateral
                   ]
-              )
+                )
 
     -- TODO: NetworkId for hardware wallets. We don't always want this
     -- & L.networkIdTxBodyL .~ ...
@@ -3227,7 +3229,7 @@ collectTxBodyScriptWitnesses _ TxBodyContent {
           -- The certs are indexed in list order
         | (ix, cert) <- zip [0..] certs
         , ScriptWitness _ witness <- maybeToList $ do
-                                       stakecred <- selectStakeCredential cert
+                                       stakecred <- selectStakeCredentialWitness cert
                                        Map.lookup stakecred witnesses
         ]
 

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

@@ -140,3 +140,4 @@ modifyWith :: ()
   => (a -> a)
   -> (a -> a)
 modifyWith = id
+

cardano-api/src/Cardano/Api.hs

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