Merge pull request #341 from input-output-hk/mgalazyn/fix/remove-keys…

…-coercing

Remove uses of `coerceKeyRole`, use `asWitness` / `fromWitness` when key role conversion is required

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

@@ -523,7 +523,6 @@ makeShelleyAddressInEra sbe nw pc scr =
 --
 
 data StakeAddress where
-
      StakeAddress
        :: Shelley.Network
        -> Shelley.StakeCredential StandardCrypto

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

@@ -10,7 +10,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 -- | Certificates embedded in transactions
 --
@@ -383,7 +382,7 @@ makeMIRCertificate (MirCertificateRequirements atMostEra mirPot mirTarget) =
 data DRepRegistrationRequirements era where
   DRepRegistrationRequirements
     :: ConwayEraOnwards era
-    -> VotingCredential era
+    -> (Ledger.Credential Ledger.DRepRole (EraCrypto (ShelleyLedgerEra era)))
     -> Lovelace
     -> DRepRegistrationRequirements era
 
@@ -392,7 +391,7 @@ makeDrepRegistrationCertificate :: ()
   => DRepRegistrationRequirements era
   -> Maybe (Ledger.Anchor (EraCrypto (ShelleyLedgerEra era)))
   -> Certificate era
-makeDrepRegistrationCertificate (DRepRegistrationRequirements conwayOnwards (VotingCredential vcred) deposit) anchor =
+makeDrepRegistrationCertificate (DRepRegistrationRequirements conwayOnwards vcred deposit) anchor =
   ConwayCertificate conwayOnwards
     . Ledger.ConwayTxCertGov
     $ Ledger.ConwayRegDRep
@@ -437,14 +436,14 @@ makeCommitteeColdkeyResignationCertificate (CommitteeColdkeyResignationRequireme
 data DRepUnregistrationRequirements era where
   DRepUnregistrationRequirements
     :: ConwayEraOnwards era
-    -> VotingCredential era
+    -> (Ledger.Credential Ledger.DRepRole (EraCrypto (ShelleyLedgerEra era)))
     -> Lovelace
     -> DRepUnregistrationRequirements era
 
 makeDrepUnregistrationCertificate :: ()
   => DRepUnregistrationRequirements era
   -> Certificate era
-makeDrepUnregistrationCertificate (DRepUnregistrationRequirements conwayOnwards (VotingCredential vcred) deposit) =
+makeDrepUnregistrationCertificate (DRepUnregistrationRequirements conwayOnwards vcred deposit) =
   ConwayCertificate conwayOnwards
     . Ledger.ConwayTxCertGov
     . Ledger.ConwayUnRegDRep vcred
@@ -476,19 +475,18 @@ selectStakeCredential = fmap fromShelleyStakeCredential . \case
       Ledger.RegTxCert sCred           -> Just sCred
       Ledger.UnRegTxCert sCred         -> Just sCred
       Ledger.DelegStakeTxCert sCred _  -> Just sCred
-      Ledger.RegPoolTxCert poolParams  ->
-        Just . Ledger.coerceKeyRole . Ledger.KeyHashObj $ Ledger.ppId poolParams
-      Ledger.RetirePoolTxCert poolId _ ->
-        Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj poolId
+      -- 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 poolParams        ->
-        Just . Ledger.coerceKeyRole . Ledger.KeyHashObj $ Ledger.ppId poolParams
-      Ledger.RetirePoolTxCert kh _           ->
-        Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj kh
+      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.UnRegTxCert sCred               -> Just sCred
       Ledger.RegDepositTxCert sCred _        -> Just sCred

cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs

@@ -21,20 +21,15 @@ import           Cardano.Api.Eon.ConwayEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Governance.Actions.ProposalProcedure
 import           Cardano.Api.HasTypeProxy
-import           Cardano.Api.Keys.Shelley
 import qualified Cardano.Api.ReexposeLedger as Ledger
-import           Cardano.Api.Script
 import           Cardano.Api.SerialiseCBOR
 import           Cardano.Api.SerialiseTextEnvelope
 
 import qualified Cardano.Binary as CBOR
 import qualified Cardano.Ledger.Api as L
-import qualified Cardano.Ledger.Binary.Plain as Plain
 import           Cardano.Ledger.Core (EraCrypto)
 import qualified Cardano.Ledger.Core as L
-import           Cardano.Ledger.Keys (HasKeyRole (..), KeyRole (DRepRole))
 
-import           Data.ByteString.Lazy (ByteString)
 import qualified Data.Map as Map
 import           Data.Text (Text)
 import qualified Data.Text.Encoding as Text
@@ -55,125 +50,30 @@ instance IsShelleyBasedEra era => FromCBOR (GovernanceActionId era) where
     !v <- shelleyBasedEraConstraints (shelleyBasedEra @era) $ Ledger.fromEraCBOR @(ShelleyLedgerEra era)
     return $ GovernanceActionId v
 
-
--- TODO: Conway era -
--- These should be the different keys corresponding to the Constitutional Committee and DReps.
--- We can then derive the StakeCredentials from them.
-data Voter era
-  = VoterCommittee (VotingCredential era) -- ^ Constitutional committee
-  | VoterDRep (VotingCredential era) -- ^ Delegated representative
-  | VoterSpo (Hash StakePoolKey) -- ^ Stake pool operator
+newtype Voter era = Voter (Ledger.Voter (L.EraCrypto (ShelleyLedgerEra era)))
   deriving (Show, Eq, Ord)
 
 instance IsShelleyBasedEra era => ToCBOR (Voter era) where
-  toCBOR = \case
-    VoterCommittee v ->
-      CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> toCBOR v
-    VoterDRep v ->
-      CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> toCBOR v
-    VoterSpo v ->
-      CBOR.encodeListLen 2 <> CBOR.encodeWord 2 <> toCBOR v
+  toCBOR (Voter v) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ Ledger.toEraCBOR @(ShelleyLedgerEra era) v
 
 instance IsShelleyBasedEra era => FromCBOR (Voter era) where
   fromCBOR = do
-    CBOR.decodeListLenOf 2
-    t <- CBOR.decodeWord
-    case t of
-      0 -> do
-        !x <- fromCBOR
-        return $ VoterCommittee x
-      1 -> do
-        !x <- fromCBOR
-        return $ VoterDRep x
-      2 -> do
-        !x <- fromCBOR
-        return $ VoterSpo x
-      _ ->
-        CBOR.cborError $ CBOR.DecoderErrorUnknownTag "Voter era" (fromIntegral t)
+    !v <- shelleyBasedEraConstraints (shelleyBasedEra @era) $ Ledger.fromEraCBOR @(ShelleyLedgerEra era)
+    pure $ Voter v
+
 
 data Vote
   = No
   | Yes
   | Abstain
   deriving (Show, Eq)
 
-toVoterRole :: ()
-  => ConwayEraOnwards era
-  -> Voter era
-  -> Ledger.Voter (L.EraCrypto (ShelleyLedgerEra era))
-toVoterRole eon =
-  conwayEraOnwardsConstraints eon $ \case
-    VoterCommittee (VotingCredential cred) ->
-      Ledger.CommitteeVoter $ coerceKeyRole cred -- TODO: Conway era - Alexey realllllyyy doesn't like this. We need to fix it.
-    VoterDRep (VotingCredential cred) ->
-      Ledger.DRepVoter cred
-    VoterSpo (StakePoolKeyHash kh) ->
-      Ledger.StakePoolVoter kh
-
-fromVoterRole :: ()
-  => ConwayEraOnwards era
-  -> Ledger.Voter (L.EraCrypto (ShelleyLedgerEra era))
-  -> Voter era
-fromVoterRole eon =
-  conwayEraOnwardsConstraints eon $ \case
-    Ledger.CommitteeVoter cred ->
-      VoterCommittee (VotingCredential (coerceKeyRole cred))    -- TODO: Conway era - We shouldn't be using coerceKeyRole.
-    Ledger.DRepVoter cred ->
-      VoterDRep (VotingCredential cred)
-    Ledger.StakePoolVoter kh ->
-      VoterSpo (StakePoolKeyHash kh)
-
 toVote :: Vote -> Ledger.Vote
 toVote = \case
   No -> Ledger.VoteNo
   Yes -> Ledger.VoteYes
   Abstain -> Ledger.Abstain
 
-toVotingCredential :: ()
-  => ConwayEraOnwards era
-  -> StakeCredential
-  -> Either Plain.DecoderError (VotingCredential era)
-toVotingCredential sbe (StakeCredentialByKey (StakeKeyHash kh)) = do
-  let cbor = Plain.serialize $ Ledger.KeyHashObj kh
-  eraDecodeVotingCredential sbe cbor
-
-toVotingCredential _sbe (StakeCredentialByScript (ScriptHash _sh)) =
-  error "toVotingCredential: script stake credentials not implemented yet"
-  -- TODO: Conway era
-  -- let cbor = Plain.serialize $ Ledger.ScriptHashObj sh
-  -- eraDecodeVotingCredential sbe cbor
-
--- TODO: Conway era
--- This is a hack. data StakeCredential in cardano-api is not parameterized by era, it defaults to StandardCrypto.
--- However VotingProcedure is parameterized on era. We need to also parameterize StakeCredential on era.
-eraDecodeVotingCredential :: ()
-  => ConwayEraOnwards era
-  -> ByteString
-  -> Either Plain.DecoderError (VotingCredential era)
-eraDecodeVotingCredential eon bs =
-  conwayEraOnwardsConstraints eon $
-    case Plain.decodeFull bs of
-      Left e -> Left e
-      Right x -> Right $ VotingCredential x
-
-newtype VotingCredential era = VotingCredential
-  { unVotingCredential :: Ledger.Credential 'DRepRole (EraCrypto (ShelleyLedgerEra era))
-  }
-
-deriving instance Show (VotingCredential crypto)
-deriving instance Eq (VotingCredential crypto)
-deriving instance Ord (VotingCredential crypto)
-
-instance IsShelleyBasedEra era => ToCBOR (VotingCredential era) where
-  toCBOR = \case
-    VotingCredential v ->
-      shelleyBasedEraConstraints (shelleyBasedEra @era) $ CBOR.toCBOR v
-
-instance IsShelleyBasedEra era => FromCBOR (VotingCredential era) where
-  fromCBOR = do
-    v <- shelleyBasedEraConstraints (shelleyBasedEra @era) CBOR.fromCBOR
-    return $ VotingCredential v
-
 createVotingProcedure :: ()
   => ConwayEraOnwards era
   -> Vote

cardano-api/internal/Cardano/Api/Keys/Class.hs

@@ -98,7 +98,6 @@ instance HasTypeProxy a => HasTypeProxy (SigningKey a) where
 
 -- | Some key roles share the same representation and it is sometimes
 -- legitimate to change the role of a key.
---
 class CastVerificationKeyRole keyroleA keyroleB where
 
     -- | Change the role of a 'VerificationKey', if the representation permits.

cardano-api/internal/Cardano/Api/Keys/Shelley.hs

@@ -1735,7 +1735,3 @@ instance CastVerificationKeyRole DRepExtendedKey DRepKey where
         impossible =
           error "castVerificationKey (DRep): byron and shelley key sizes do not match!"
 
---
--- Committee keys
---
-

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

@@ -333,3 +333,4 @@ instance Semigroup (Ledger.ConwayPParams StrictMaybe era) where
     , Ledger.cppDRepDeposit = lastMappendWith Ledger.cppDRepDeposit p1 p2
     , Ledger.cppDRepActivity = lastMappendWith Ledger.cppDRepActivity p1 p2
     }
+

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

@@ -9,7 +9,7 @@ module Cardano.Api.ReexposeLedger
   , ShelleyEraTxCert(..)
   , GenesisDelegCert(..)
   , PoolParams (..)
-  , HasKeyRole(..)
+  , HasKeyRole
   , MIRPot(..)
   , MIRTarget(..)
   , MIRCert(..)
@@ -129,7 +129,7 @@ import           Cardano.Ledger.Core (EraCrypto, PParams (..), PoolCert (..), fr
 import           Cardano.Ledger.Credential (Credential (..))
 import           Cardano.Ledger.Crypto (Crypto, StandardCrypto)
 import           Cardano.Ledger.DRep (DRep (..), drepAnchorL, drepDepositL, drepExpiryL)
-import           Cardano.Ledger.Keys (HasKeyRole (..), KeyHash (..), KeyRole (..))
+import           Cardano.Ledger.Keys (HasKeyRole, KeyHash (..), KeyRole (..))
 import           Cardano.Ledger.PoolParams (PoolMetadata (..), PoolParams (..), StakePoolRelay (..))
 import           Cardano.Ledger.Shelley.TxCert (EraTxCert (..), GenesisDelegCert (..), MIRCert (..),
                    MIRPot (..), MIRTarget (..), ShelleyDelegCert (..), ShelleyEraTxCert (..),

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

@@ -1197,7 +1197,7 @@ toShelleyMultiSig = go
   where
     go :: SimpleScript -> Either MultiSigError (Shelley.MultiSig era)
     go (RequireSignature (PaymentKeyHash kh)) =
-      return $ Shelley.RequireSignature (Shelley.coerceKeyRole kh)
+      return $ Shelley.RequireSignature (Shelley.asWitness kh)
     go (RequireAllOf s) = mapM go s <&> Shelley.RequireAllOf
     go (RequireAnyOf s) = mapM go s <&> Shelley.RequireAnyOf
     go (RequireMOf m s) = mapM go s <&> Shelley.RequireMOf m
@@ -1226,7 +1226,7 @@ toAllegraTimelock = go
   where
     go :: SimpleScript -> Timelock.Timelock era
     go (RequireSignature (PaymentKeyHash kh))
-                        = Timelock.RequireSignature (Shelley.coerceKeyRole kh)
+                        = Timelock.RequireSignature (Shelley.asWitness kh)
     go (RequireAllOf s) = Timelock.RequireAllOf (Seq.fromList (map go s))
     go (RequireAnyOf s) = Timelock.RequireAnyOf (Seq.fromList (map go s))
     go (RequireMOf m s) = Timelock.RequireMOf m (Seq.fromList (map go s))

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

@@ -791,16 +791,16 @@ getShelleyKeyWitnessVerificationKey
   :: ShelleySigningKey
   -> Shelley.VKey Shelley.Witness StandardCrypto
 getShelleyKeyWitnessVerificationKey (ShelleyNormalSigningKey sk) =
-      (Shelley.coerceKeyRole :: Shelley.VKey Shelley.Payment StandardCrypto
-                             -> Shelley.VKey Shelley.Witness StandardCrypto)
+      (Shelley.asWitness :: Shelley.VKey Shelley.Payment StandardCrypto
+                         -> Shelley.VKey Shelley.Witness StandardCrypto)
     . (\(PaymentVerificationKey vk) -> vk)
     . getVerificationKey
     . PaymentSigningKey
     $ sk
 
 getShelleyKeyWitnessVerificationKey (ShelleyExtendedSigningKey sk) =
-      (Shelley.coerceKeyRole :: Shelley.VKey Shelley.Payment StandardCrypto
-                             -> Shelley.VKey Shelley.Witness StandardCrypto)
+      (Shelley.asWitness :: Shelley.VKey Shelley.Payment StandardCrypto
+                         -> Shelley.VKey Shelley.Witness StandardCrypto)
     . (\(PaymentVerificationKey vk) -> vk)
     . (castVerificationKey :: VerificationKey PaymentExtendedKey
                            -> VerificationKey PaymentKey)

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

@@ -2586,12 +2586,12 @@ convMintValue txMintValue =
       case toMaryValue v of
         MaryValue _ ma -> ma
 
-convExtraKeyWitnesses :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash r' StandardCrypto)
+convExtraKeyWitnesses :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash Shelley.Witness StandardCrypto)
 convExtraKeyWitnesses txExtraKeyWits =
   case txExtraKeyWits of
     TxExtraKeyWitnessesNone   -> Set.empty
     TxExtraKeyWitnesses _ khs -> Set.fromList
-                                   [ Shelley.coerceKeyRole kh
+                                   [ Shelley.asWitness kh
                                    | PaymentKeyHash kh <- khs ]
 
 convScripts

cardano-api/src/Cardano/Api/Shelley.hs

@@ -254,12 +254,10 @@ module Cardano.Api.Shelley
     GovernancePollAnswer(..),
     GovernancePollError(..),
     Vote(..),
-    VotingCredential(..),
     Voter(..),
     createProposalProcedure,
     createVotingProcedure,
     renderGovernancePollError,
-    toVotingCredential,
     fromProposalProcedure,
     hashGovernancePoll,
     verifyPollAnswer,