Use ledger keys' roles casting with explicit whitelist, instead of co…

…erceKeyRole

cardano-api/cardano-api.cabal

@@ -102,6 +102,7 @@ library internal
                         Cardano.Api.Keys.Read
                         Cardano.Api.Keys.Shelley
                         Cardano.Api.Ledger.Lens
+                        Cardano.Api.Ledger.Keys
                         Cardano.Api.LedgerEvent
                         Cardano.Api.LedgerState
                         Cardano.Api.Modes

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

@@ -10,7 +10,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 -- | Certificates embedded in transactions
 --
@@ -82,6 +81,7 @@ import           Cardano.Api.Governance.Actions.VotingProcedure
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Praos
 import           Cardano.Api.Keys.Shelley
+import           Cardano.Api.Ledger.Keys (castLedgerKey)
 import           Cardano.Api.ReexposeLedger (EraCrypto, StandardCrypto)
 import qualified Cardano.Api.ReexposeLedger as Ledger
 import           Cardano.Api.SerialiseCBOR
@@ -475,18 +475,18 @@ selectStakeCredential = fmap fromShelleyStakeCredential . \case
       Ledger.UnRegTxCert sCred         -> Just sCred
       Ledger.DelegStakeTxCert sCred _  -> Just sCred
       Ledger.RegPoolTxCert poolParams  ->
-        Just . Ledger.coerceKeyRole . Ledger.KeyHashObj $ Ledger.ppId poolParams
+        Just . castLedgerKey . Ledger.KeyHashObj $ Ledger.ppId poolParams
       Ledger.RetirePoolTxCert poolId _ ->
-        Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj poolId
+        Just . castLedgerKey $ Ledger.KeyHashObj poolId
       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
+        Just . castLedgerKey . Ledger.KeyHashObj $ Ledger.ppId poolParams
       Ledger.RetirePoolTxCert kh _           ->
-        Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj kh
+        Just . castLedgerKey $ Ledger.KeyHashObj kh
       Ledger.RegTxCert sCred                 -> Just sCred
       Ledger.UnRegTxCert sCred               -> Just sCred
       Ledger.RegDepositTxCert sCred _        -> Just sCred

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

@@ -22,6 +22,7 @@ import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Governance.Actions.ProposalProcedure
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Shelley
+import           Cardano.Api.Ledger.Keys
 import qualified Cardano.Api.ReexposeLedger as Ledger
 import           Cardano.Api.Script
 import           Cardano.Api.SerialiseCBOR
@@ -32,7 +33,7 @@ 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           Cardano.Ledger.Keys (KeyRole (DRepRole))
 
 import           Data.ByteString.Lazy (ByteString)
 import qualified Data.Map as Map
@@ -104,7 +105,7 @@ toVoterRole :: ()
 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.
+      Ledger.CommitteeVoter $ castLedgerKey cred
     VoterDRep (VotingCredential cred) ->
       Ledger.DRepVoter cred
     VoterSpo (StakePoolKeyHash kh) ->
@@ -117,7 +118,7 @@ fromVoterRole :: ()
 fromVoterRole eon =
   conwayEraOnwardsConstraints eon $ \case
     Ledger.CommitteeVoter cred ->
-      VoterCommittee (VotingCredential (coerceKeyRole cred))    -- TODO: Conway era - We shouldn't be using coerceKeyRole.
+      VoterCommittee (VotingCredential (castLedgerKey cred))
     Ledger.DRepVoter cred ->
       VoterDRep (VotingCredential cred)
     Ledger.StakePoolVoter kh ->

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/Ledger/Keys.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Cardano.Api.Ledger.Keys where
+
+import qualified Cardano.Api.ReexposeLedger as L
+
+import           Cardano.Ledger.Keys (HasKeyRole (..))
+import qualified Cardano.Ledger.Keys as Shelley
+
+-- | Allows casting of the ledger keys between different roles. In comparison to the 'coerceKeyRole', this
+-- class requires explicit listing of the key types we allow casting of. This prevents from accidental
+-- casting of a new key role when ledger interface changes.
+class CastLedgerKey keyType keyRoleA keyRoleB where
+  castLedgerKey :: keyType keyRoleA c -> keyType keyRoleB c
+  default castLedgerKey :: HasKeyRole keyType => keyType keyRoleA c -> keyType keyRoleB c
+  castLedgerKey = coerceKeyRole
+
+instance CastLedgerKey L.Credential L.StakePool L.Staking
+instance CastLedgerKey L.Credential L.Staking L.StakePool
+
+instance CastLedgerKey L.Credential L.DRepRole L.HotCommitteeRole
+instance CastLedgerKey L.Credential L.HotCommitteeRole L.DRepRole
+
+instance CastLedgerKey Shelley.VKey L.Payment L.Witness
+instance CastLedgerKey Shelley.VKey L.Witness L.Payment
+
+instance CastLedgerKey Shelley.KeyHash L.Payment L.Witness
+instance CastLedgerKey Shelley.KeyHash L.Witness L.Payment

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

@@ -332,3 +332,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 (DRep (..), EraCrypto, PParams (..), PoolCe
 import           Cardano.Ledger.Credential (Credential (..))
 import           Cardano.Ledger.Crypto (Crypto, StandardCrypto)
 import           Cardano.Ledger.DRepDistr (DRepState, 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

@@ -117,6 +117,7 @@ import           Cardano.Api.Error
 import           Cardano.Api.Hash
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Shelley
+import           Cardano.Api.Ledger.Keys
 import           Cardano.Api.ScriptData
 import           Cardano.Api.SerialiseCBOR
 import           Cardano.Api.SerialiseJSON
@@ -135,7 +136,6 @@ import           Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import qualified Cardano.Ledger.Binary as Binary (decCBOR, decodeFullAnnotator)
 import           Cardano.Ledger.Core (Era (EraCrypto))
 import qualified Cardano.Ledger.Core as Ledger
-import qualified Cardano.Ledger.Keys as Shelley
 import qualified Cardano.Ledger.Shelley.Scripts as Shelley
 import           Cardano.Slotting.Slot (SlotNo)
 import           Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
@@ -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 (castLedgerKey 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
@@ -1211,7 +1211,7 @@ fromShelleyMultiSig = go
   where
     go (Shelley.RequireSignature kh)
                                 = RequireSignature
-                                    (PaymentKeyHash (Shelley.coerceKeyRole kh))
+                                    (PaymentKeyHash (castLedgerKey kh))
     go (Shelley.RequireAllOf s) = RequireAllOf (map go s)
     go (Shelley.RequireAnyOf s) = RequireAnyOf (map go s)
     go (Shelley.RequireMOf m s) = RequireMOf m (map go s)
@@ -1226,7 +1226,7 @@ toAllegraTimelock = go
   where
     go :: SimpleScript -> Timelock.Timelock era
     go (RequireSignature (PaymentKeyHash kh))
-                        = Timelock.RequireSignature (Shelley.coerceKeyRole kh)
+                        = Timelock.RequireSignature (castLedgerKey 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))
@@ -1241,7 +1241,7 @@ fromAllegraTimelock :: (Era era, EraCrypto era ~ StandardCrypto)
 fromAllegraTimelock = go
   where
     go (Timelock.RequireSignature kh) = RequireSignature
-                                          (PaymentKeyHash (Shelley.coerceKeyRole kh))
+                                          (PaymentKeyHash (castLedgerKey kh))
     go (Timelock.RequireTimeExpire t) = RequireTimeBefore t
     go (Timelock.RequireTimeStart  t) = RequireTimeAfter t
     go (Timelock.RequireAllOf      s) = RequireAllOf (map go (toList s))

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

@@ -59,6 +59,7 @@ import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Byron
 import           Cardano.Api.Keys.Class
 import           Cardano.Api.Keys.Shelley
+import           Cardano.Api.Ledger.Keys
 import           Cardano.Api.NetworkId
 import           Cardano.Api.SerialiseCBOR
 import           Cardano.Api.SerialiseTextEnvelope
@@ -793,16 +794,16 @@ getShelleyKeyWitnessVerificationKey
   :: ShelleySigningKey
   -> Shelley.VKey Shelley.Witness StandardCrypto
 getShelleyKeyWitnessVerificationKey (ShelleyNormalSigningKey sk) =
-      (Shelley.coerceKeyRole :: Shelley.VKey Shelley.Payment StandardCrypto
-                             -> Shelley.VKey Shelley.Witness StandardCrypto)
+      (castLedgerKey     :: 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)
+      (castLedgerKey :: 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

@@ -169,6 +169,7 @@ import           Cardano.Api.Hash
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Byron
 import           Cardano.Api.Keys.Shelley
+import           Cardano.Api.Ledger.Keys
 import qualified Cardano.Api.Ledger.Lens as L
 import           Cardano.Api.NetworkId
 import           Cardano.Api.ProtocolParameters
@@ -2458,7 +2459,7 @@ fromLedgerTxExtraKeyWitnesses sbe body =
         then TxExtraKeyWitnessesNone
         else
           TxExtraKeyWitnesses w
-            [ PaymentKeyHash (Shelley.coerceKeyRole keyhash)
+            [ PaymentKeyHash (castLedgerKey keyhash)
             | keyhash <- Set.toList $ body ^. L.reqSignerHashesTxBodyL
             ]
     )
@@ -2667,12 +2668,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
+                                   [ castLedgerKey kh
                                    | PaymentKeyHash kh <- khs ]
 
 convScripts