Merge pull request #781 from IntersectMBO/add-pool-operator-extended-key-support

Add pool operator extended key support

Author: palas

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

@@ -197,8 +197,6 @@ 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
@@ -572,10 +570,13 @@ genOperationalCertificateWithCounter
 genOperationalCertificateWithCounter = do
   kesVKey <- genVerificationKey AsKesKey
   stkPoolOrGenDelExtSign <-
-    Gen.either (genSigningKey AsStakePoolKey) (genSigningKey AsGenesisDelegateExtendedKey)
+    Gen.either (Gen.choice [ AnyStakePoolNormalSigningKey <$> genSigningKey AsStakePoolKey
+                           , AnyStakePoolExtendedSigningKey <$> genSigningKey AsStakePoolExtendedKey
+                           ])
+               (genSigningKey AsGenesisDelegateExtendedKey)
   kesP <- genKESPeriod
   c <- Gen.integral $ Range.linear 0 1000
-  let stakePoolVer = either getVerificationKey (convert' . getVerificationKey) stkPoolOrGenDelExtSign
+  let stakePoolVer = either castAnyStakePoolSigningKeyToNormalVerificationKey (convert' . getVerificationKey) stkPoolOrGenDelExtSign
       iCounter = OperationalCertificateIssueCounter c stakePoolVer
 
   case issueOperationalCertificate kesVKey stkPoolOrGenDelExtSign kesP iCounter of
@@ -584,6 +585,15 @@ genOperationalCertificateWithCounter = do
     Left err -> error $ docToString $ prettyError err
     Right pair -> return pair
  where
+  castAnyStakePoolSigningKeyToNormalVerificationKey
+    :: AnyStakePoolSigningKey
+    -> VerificationKey StakePoolKey
+  castAnyStakePoolSigningKeyToNormalVerificationKey anyStakePoolSKey =
+    case anyStakePoolSigningKeyToVerificationKey anyStakePoolSKey of
+      AnyStakePoolNormalVerificationKey normalStakePoolVKey -> normalStakePoolVKey
+      AnyStakePoolExtendedVerificationKey extendedStakePoolVKey ->
+        castVerificationKey extendedStakePoolVKey
+
   convert'
     :: VerificationKey GenesisDelegateExtendedKey
     -> VerificationKey StakePoolKey

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

@@ -1,12 +1,16 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 -- The Shelley ledger uses promoted data kinds which we have to use, but we do
 -- not export any from this API. We also use them unticked as nature intended.
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
@@ -37,6 +41,10 @@ module Cardano.Api.Internal.Keys.Shelley
   , VerificationKey (..)
   , SigningKey (..)
   , Hash (..)
+  , AnyStakePoolVerificationKey (..)
+  , anyStakePoolVerificationKeyHash
+  , AnyStakePoolSigningKey (..)
+  , anyStakePoolSigningKeyToVerificationKey
   )
 where
 
@@ -60,7 +68,11 @@ import Cardano.Crypto.Wallet qualified as Crypto.HD
 import Cardano.Ledger.Keys (DSIGN)
 import Cardano.Ledger.Keys qualified as Shelley
 
-import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText, withText)
+import Data.Aeson.Types
+  ( ToJSONKey (..)
+  , toJSONKeyText
+  , withText
+  )
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
@@ -1658,6 +1670,29 @@ instance CastSigningKeyRole GenesisUTxOKey PaymentKey where
 -- stake pool keys
 --
 
+-- | Wrapper that handles both normal and extended StakePoolKeys VerificationKeys
+data AnyStakePoolVerificationKey
+  = AnyStakePoolNormalVerificationKey (VerificationKey StakePoolKey)
+  | AnyStakePoolExtendedVerificationKey (VerificationKey StakePoolExtendedKey)
+  deriving (Show, Eq)
+
+anyStakePoolVerificationKeyHash :: AnyStakePoolVerificationKey -> Hash StakePoolKey
+anyStakePoolVerificationKeyHash (AnyStakePoolNormalVerificationKey vk) = verificationKeyHash vk
+anyStakePoolVerificationKeyHash (AnyStakePoolExtendedVerificationKey vk) =
+  let StakePoolExtendedKeyHash hash = verificationKeyHash vk in StakePoolKeyHash hash
+
+-- | Wrapper that handles both normal and extended StakePoolKeys SigningKeys
+data AnyStakePoolSigningKey
+  = AnyStakePoolNormalSigningKey (SigningKey StakePoolKey)
+  | AnyStakePoolExtendedSigningKey (SigningKey StakePoolExtendedKey)
+  deriving Show
+
+anyStakePoolSigningKeyToVerificationKey :: AnyStakePoolSigningKey -> AnyStakePoolVerificationKey
+anyStakePoolSigningKeyToVerificationKey (AnyStakePoolNormalSigningKey sk) =
+  AnyStakePoolNormalVerificationKey (getVerificationKey sk)
+anyStakePoolSigningKeyToVerificationKey (AnyStakePoolExtendedSigningKey vk) =
+  AnyStakePoolExtendedVerificationKey (getVerificationKey vk)
+
 data StakePoolKey
 
 instance HasTypeProxy StakePoolKey where
@@ -1892,6 +1927,10 @@ instance SerialiseAsRawBytes (Hash StakePoolExtendedKey) where
       (SerialiseAsRawBytesError "Unable to deserialise Hash StakePoolExtendedKey")
       (StakePoolExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs)
 
+instance SerialiseAsBech32 (Hash StakePoolExtendedKey) where
+  bech32PrefixFor _ = "pool_xvkh"
+  bech32PrefixesPermitted _ = ["pool_xvkh"]
+
 instance HasTextEnvelope (VerificationKey StakePoolExtendedKey) where
   textEnvelopeType _ = "StakePoolExtendedVerificationKey_ed25519_bip32"
 
@@ -1906,6 +1945,24 @@ instance SerialiseAsBech32 (SigningKey StakePoolExtendedKey) where
   bech32PrefixFor _ = "pool_xsk"
   bech32PrefixesPermitted _ = ["pool_xsk"]
 
+instance ToJSON (Hash StakePoolExtendedKey) where
+  toJSON = toJSON . serialiseToBech32
+
+instance ToJSONKey (Hash StakePoolExtendedKey) where
+  toJSONKey = toJSONKeyText serialiseToBech32
+
+instance FromJSON (Hash StakePoolExtendedKey) where
+  parseJSON = withText "PoolId" $ \str ->
+    case deserialiseFromBech32 (AsHash AsStakePoolExtendedKey) str of
+      Left err ->
+        fail $
+          docToString $
+            mconcat
+              [ "Error deserialising Hash StakePoolKey: " <> pretty str
+              , " Error: " <> prettyError err
+              ]
+      Right h -> pure h
+
 instance CastVerificationKeyRole StakePoolExtendedKey StakePoolKey where
   castVerificationKey (StakePoolExtendedVerificationKey vk) =
     StakePoolVerificationKey

cardano-api/src/Cardano/Api/Internal/OperationalCertificate.hs

@@ -109,7 +109,7 @@ instance Error OperationalCertIssueError where
 issueOperationalCertificate
   :: VerificationKey KesKey
   -> Either
-       (SigningKey StakePoolKey)
+       AnyStakePoolSigningKey
        (SigningKey GenesisDelegateExtendedKey)
   -- TODO: this may be better with a type that
   -- captured the three (four?) choices, stake pool
@@ -134,8 +134,21 @@ issueOperationalCertificate
           , OperationalCertificateIssueCounter (succ counter) poolVKey
           )
    where
+    castAnyStakePoolSigningKeyToNormalVerificationKey
+      :: AnyStakePoolSigningKey
+      -> VerificationKey StakePoolKey
+    castAnyStakePoolSigningKeyToNormalVerificationKey anyStakePoolSKey =
+      case anyStakePoolSigningKeyToVerificationKey anyStakePoolSKey of
+        AnyStakePoolNormalVerificationKey normalStakePoolVKey -> normalStakePoolVKey
+        AnyStakePoolExtendedVerificationKey extendedStakePoolVKey ->
+          castVerificationKey extendedStakePoolVKey
+
     poolVKey' :: VerificationKey StakePoolKey
-    poolVKey' = either getVerificationKey (convert . getVerificationKey) skey
+    poolVKey' =
+      either
+        castAnyStakePoolSigningKeyToNormalVerificationKey
+        (convert . getVerificationKey)
+        skey
      where
       convert
         :: VerificationKey GenesisDelegateExtendedKey
@@ -164,8 +177,13 @@ issueOperationalCertificate
      where
       skey' :: ShelleySigningKey
       skey' = case skey of
-        Left (StakePoolSigningKey poolSKey) ->
+        Left (AnyStakePoolNormalSigningKey (StakePoolSigningKey poolSKey)) ->
           ShelleyNormalSigningKey poolSKey
+        Left
+          ( AnyStakePoolExtendedSigningKey
+              (StakePoolExtendedSigningKey poolExtendedSKey)
+            ) ->
+            ShelleyExtendedSigningKey poolExtendedSKey
         Right (GenesisDelegateExtendedSigningKey delegSKey) ->
           ShelleyExtendedSigningKey delegSKey
 

cardano-api/src/Cardano/Api/Internal/Tx/Sign.hs

@@ -790,6 +790,7 @@ data ShelleyWitnessSigningKey
   | WitnessStakeKey (SigningKey StakeKey)
   | WitnessStakeExtendedKey (SigningKey StakeExtendedKey)
   | WitnessStakePoolKey (SigningKey StakePoolKey)
+  | WitnessStakePoolExtendedKey (SigningKey StakePoolExtendedKey)
   | WitnessGenesisKey (SigningKey GenesisKey)
   | WitnessGenesisExtendedKey (SigningKey GenesisExtendedKey)
   | WitnessGenesisDelegateKey (SigningKey GenesisDelegateKey)
@@ -1163,6 +1164,7 @@ toShelleySigningKey key = case key of
   -- The cases for extended keys
   WitnessPaymentExtendedKey (PaymentExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk
   WitnessStakeExtendedKey (StakeExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk
+  WitnessStakePoolExtendedKey (StakePoolExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk
   WitnessGenesisExtendedKey (GenesisExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk
   WitnessGenesisDelegateExtendedKey (GenesisDelegateExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk
   WitnessCommitteeColdExtendedKey (CommitteeColdExtendedSigningKey sk) -> ShelleyExtendedSigningKey sk

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

@@ -199,6 +199,10 @@ module Cardano.Api.Shelley
   , DRepMetadataReference (DRepMetadataReference)
 
     -- ** Stake pool operator's keys
+  , AnyStakePoolVerificationKey (..)
+  , anyStakePoolVerificationKeyHash
+  , AnyStakePoolSigningKey (..)
+  , anyStakePoolSigningKeyToVerificationKey
   , StakePoolExtendedKey
   , StakePoolKey
   , PoolId

cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs

@@ -211,7 +211,12 @@ test_OperationalCertIssueError =
   testAllErrorMessages_
     "Cardano.Api.OperationalCertificate"
     "OperationalCertIssueError"
-    [ ("OperationalCertKeyMismatch", OperationalCertKeyMismatch stakePoolVerKey1 stakePoolVerKey2)
+    [
+      ( "OperationalCertKeyMismatch"
+      , OperationalCertKeyMismatch
+          stakePoolVerKey1
+          stakePoolVerKey2
+      )
     ]
 
 test_ProtocolParametersError :: TestTree