Remove parameterised type

Author: palas

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

@@ -559,10 +559,10 @@ genOperationalCertificateWithCounter
 genOperationalCertificateWithCounter = do
   kesVKey <- genVerificationKey AsKesKey
   stkPoolOrGenDelExtSign <-
-    Gen.either (StakePoolNormalKeyWrapper <$> genSigningKey AsStakePoolKey) (genSigningKey AsGenesisDelegateExtendedKey)
+    Gen.either (AnyStakePoolNormalSigningKey <$> genSigningKey AsStakePoolKey) (genSigningKey AsGenesisDelegateExtendedKey)
   kesP <- genKESPeriod
   c <- Gen.integral $ Range.linear 0 1000
-  let stakePoolVer = either (\x -> liftStakePoolKey x (const getVerificationKey)) (StakePoolNormalKeyWrapper . convert' . getVerificationKey) stkPoolOrGenDelExtSign
+  let stakePoolVer = either anyStakePoolSigningKeyToVerificationKey (AnyStakePoolNormalVerificationKey . convert' . getVerificationKey) stkPoolOrGenDelExtSign
       iCounter = OperationalCertificateIssueCounter c stakePoolVer
 
   case issueOperationalCertificate kesVKey stkPoolOrGenDelExtSign kesP iCounter of

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

@@ -9,9 +9,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 {-# 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.
@@ -43,13 +41,10 @@ module Cardano.Api.Internal.Keys.Shelley
   , VerificationKey (..)
   , SigningKey (..)
   , Hash (..)
-  , AnyStakePoolKeyWrapper (..)
-  , rewrapAnyStakePoolKey
-  , foldStakePoolKey
-  , liftStakePoolKey
-  , liftStakePoolKeyM
-  , unStakePoolAnyKeyHash
-  , castHashToNormal
+  , AnyStakePoolVerificationKey (..)
+  , anyStakePoolVerificationKeyHash
+  , AnyStakePoolSigningKey (..)
+  , anyStakePoolSigningKeyToVerificationKey
   )
 where
 
@@ -65,6 +60,7 @@ import Cardano.Api.Internal.SerialiseRaw
 import Cardano.Api.Internal.SerialiseTextEnvelope
 import Cardano.Api.Internal.SerialiseUsing
 
+import Cardano.Binary (DecoderError (DecoderErrorUnknownTag), cborError)
 import Cardano.Crypto.DSIGN.Class qualified as Crypto
 import Cardano.Crypto.Hash.Class qualified as Crypto
 import Cardano.Crypto.Seed qualified as Crypto
@@ -73,6 +69,8 @@ import Cardano.Ledger.Crypto (StandardCrypto)
 import Cardano.Ledger.Crypto qualified as Shelley (DSIGN)
 import Cardano.Ledger.Keys qualified as Shelley
 
+import Codec.CBOR.Decoding (decodeListLenOf)
+import Codec.CBOR.Encoding (encodeListLen)
 import Data.Aeson.Types
   ( ToJSONKey (..)
   , toJSONKeyText
@@ -84,6 +82,7 @@ import Data.ByteString qualified as BS
 import Data.Either.Combinators (maybeToRight)
 import Data.Maybe
 import Data.String (IsString (..))
+import Data.Word (Word8)
 
 --
 -- Shelley payment keys
@@ -1679,103 +1678,43 @@ instance CastSigningKeyRole GenesisUTxOKey PaymentKey where
 -- stake pool keys
 --
 
--- | Wrapper that handles both normal and extended StakePoolKeys and hides the type with an existential
-data AnyStakePoolKeyWrapper t
-  = forall x. StakePoolKey ~ x => StakePoolNormalKeyWrapper (t x)
-  | forall x. StakePoolExtendedKey ~ x => StakePoolExtendedKeyWrapper (t x)
-
-instance
-  (Eq (t StakePoolKey), Eq (t StakePoolExtendedKey))
-  => Eq (AnyStakePoolKeyWrapper t)
-  where
-  (==) :: AnyStakePoolKeyWrapper t -> AnyStakePoolKeyWrapper t -> Bool
-  (==) (StakePoolNormalKeyWrapper x) (StakePoolNormalKeyWrapper y) = x == y
-  (==) (StakePoolExtendedKeyWrapper x) (StakePoolExtendedKeyWrapper y) = x == y
-  (==) _ _ = False
-
-instance
-  (Ord (t StakePoolKey), Ord (t StakePoolExtendedKey))
-  => Ord (AnyStakePoolKeyWrapper t)
-  where
-  compare :: AnyStakePoolKeyWrapper t -> AnyStakePoolKeyWrapper t -> Ordering
-  compare (StakePoolNormalKeyWrapper x) (StakePoolNormalKeyWrapper y) = compare x y
-  compare (StakePoolExtendedKeyWrapper x) (StakePoolExtendedKeyWrapper y) = compare x y
-  compare (StakePoolNormalKeyWrapper _) (StakePoolExtendedKeyWrapper _) = LT
-  compare (StakePoolExtendedKeyWrapper _) (StakePoolNormalKeyWrapper _) = GT
-
-instance
-  (Show (t StakePoolKey), (Show (t StakePoolExtendedKey)))
-  => Show (AnyStakePoolKeyWrapper t)
-  where
-  show (StakePoolNormalKeyWrapper x) = show x
-  show (StakePoolExtendedKeyWrapper x) = show x
-
-instance ToCBOR (AnyStakePoolKeyWrapper VerificationKey) where
-  toCBOR (StakePoolNormalKeyWrapper x) = toCBOR x
-  toCBOR (StakePoolExtendedKeyWrapper x) = toCBOR x
-
-instance FromCBOR (AnyStakePoolKeyWrapper VerificationKey) where
-  fromCBOR = undefined -- FixMe: implement this
-
-rewrapAnyStakePoolKey
-  :: (forall x. t x -> f x)
-  -> AnyStakePoolKeyWrapper t
-  -> AnyStakePoolKeyWrapper f
-rewrapAnyStakePoolKey f x = liftStakePoolKey x (const f)
-
-foldStakePoolKey
-  :: AnyStakePoolKeyWrapper t
-  -> ( forall a
-        . ( Key a
-          , SerialiseAsBech32
-              (VerificationKey a)
-          , ToJSON (Hash a)
-          )
-       => AsType a -> t a -> f
-     )
-  -> f
-foldStakePoolKey (StakePoolNormalKeyWrapper x) f = f AsStakePoolKey x
-foldStakePoolKey (StakePoolExtendedKeyWrapper x) f = f AsStakePoolExtendedKey x
-
-liftStakePoolKey
-  :: AnyStakePoolKeyWrapper t
-  -> ( forall a
-        . ( Key a
-          , SerialiseAsBech32
-              (VerificationKey a)
-          , HasTypeProxy a
-          )
-       => AsType a -> t a -> f a
-     )
-  -> AnyStakePoolKeyWrapper f
-liftStakePoolKey (StakePoolNormalKeyWrapper x) f = StakePoolNormalKeyWrapper $ f AsStakePoolKey x
-liftStakePoolKey (StakePoolExtendedKeyWrapper x) f = StakePoolExtendedKeyWrapper $ f AsStakePoolExtendedKey x
-
-liftStakePoolKeyM
-  :: Applicative g
-  => AnyStakePoolKeyWrapper t
-  -> ( forall a
-        . ( Key a
-          , SerialiseAsBech32
-              (VerificationKey a)
-          , HasTypeProxy a
-          )
-       => AsType a -> t a -> g (f a)
-     )
-  -> g (AnyStakePoolKeyWrapper f)
-liftStakePoolKeyM (StakePoolNormalKeyWrapper x) f = do
-  StakePoolNormalKeyWrapper <$> f AsStakePoolKey x
-liftStakePoolKeyM (StakePoolExtendedKeyWrapper x) f = do
-  StakePoolExtendedKeyWrapper <$> f AsStakePoolExtendedKey x
-
-castHashToNormal :: AnyStakePoolKeyWrapper Hash -> Hash StakePoolKey
-castHashToNormal (StakePoolNormalKeyWrapper x) = x
-castHashToNormal (StakePoolExtendedKeyWrapper (StakePoolExtendedKeyHash x)) = StakePoolKeyHash x
-
-unStakePoolAnyKeyHash
-  :: AnyStakePoolKeyWrapper Hash -> Shelley.KeyHash Shelley.StakePool StandardCrypto
-unStakePoolAnyKeyHash (StakePoolNormalKeyWrapper (StakePoolKeyHash spkh)) = spkh
-unStakePoolAnyKeyHash (StakePoolExtendedKeyWrapper (StakePoolExtendedKeyHash spkh)) = spkh
+-- | Wrapper that handles both normal and extended StakePoolKeys VerificationKeys
+data AnyStakePoolVerificationKey
+  = AnyStakePoolNormalVerificationKey (VerificationKey StakePoolKey)
+  | AnyStakePoolExtendedVerificationKey (VerificationKey StakePoolExtendedKey)
+  deriving (Show, Eq)
+
+instance ToCBOR AnyStakePoolVerificationKey where
+  toCBOR (AnyStakePoolNormalVerificationKey vk) =
+    encodeListLen 2 <> toCBOR (0 :: Word8) <> toCBOR vk
+  toCBOR (AnyStakePoolExtendedVerificationKey vk) =
+    encodeListLen 2 <> toCBOR (1 :: Word8) <> toCBOR vk
+
+instance FromCBOR AnyStakePoolVerificationKey where
+  fromCBOR =
+    decodeListLenOf 2 >> do
+      tag <- fromCBOR
+      case tag of
+        0 -> AnyStakePoolNormalVerificationKey <$> fromCBOR
+        1 -> AnyStakePoolExtendedVerificationKey <$> fromCBOR
+        _ -> cborError $ DecoderErrorUnknownTag "AnyStakePoolVerificationKey" tag
+
+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
 

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

@@ -44,14 +44,14 @@ import Data.Word
 data OperationalCertificate
   = OperationalCertificate
       !(Shelley.OCert StandardCrypto)
-      !(AnyStakePoolKeyWrapper VerificationKey)
+      !AnyStakePoolVerificationKey
   deriving (Eq, Show)
   deriving anyclass SerialiseAsCBOR
 
 data OperationalCertificateIssueCounter
   = OperationalCertificateIssueCounter
   { opCertIssueCount :: !Word64
-  , opCertIssueColdKey :: !(AnyStakePoolKeyWrapper VerificationKey) -- For consistency checking
+  , opCertIssueColdKey :: !AnyStakePoolVerificationKey -- For consistency checking
   }
   deriving (Eq, Show)
   deriving anyclass SerialiseAsCBOR
@@ -95,8 +95,8 @@ data OperationalCertIssueError
     --
     -- Order: pool vkey expected, pool skey supplied
     OperationalCertKeyMismatch
-      (AnyStakePoolKeyWrapper VerificationKey)
-      (AnyStakePoolKeyWrapper VerificationKey)
+      AnyStakePoolVerificationKey
+      AnyStakePoolVerificationKey
   deriving Show
 
 instance Error OperationalCertIssueError where
@@ -108,7 +108,7 @@ instance Error OperationalCertIssueError where
 issueOperationalCertificate
   :: VerificationKey KesKey
   -> Either
-       (AnyStakePoolKeyWrapper SigningKey)
+       AnyStakePoolSigningKey
        (SigningKey GenesisDelegateExtendedKey)
   -- TODO: this may be better with a type that
   -- captured the three (four?) choices, stake pool
@@ -133,11 +133,11 @@ issueOperationalCertificate
           , OperationalCertificateIssueCounter (succ counter) poolVKey
           )
    where
-    poolVKey' :: AnyStakePoolKeyWrapper VerificationKey
+    poolVKey' :: AnyStakePoolVerificationKey
     poolVKey' =
       either
-        (\x -> liftStakePoolKey x (const getVerificationKey))
-        (StakePoolNormalKeyWrapper . convert . getVerificationKey)
+        anyStakePoolSigningKeyToVerificationKey
+        (AnyStakePoolNormalVerificationKey . convert . getVerificationKey)
         skey
      where
       convert
@@ -167,10 +167,10 @@ issueOperationalCertificate
      where
       skey' :: ShelleySigningKey
       skey' = case skey of
-        Left (StakePoolNormalKeyWrapper (StakePoolSigningKey poolSKey)) ->
+        Left (AnyStakePoolNormalSigningKey (StakePoolSigningKey poolSKey)) ->
           ShelleyNormalSigningKey poolSKey
         Left
-          ( StakePoolExtendedKeyWrapper
+          ( AnyStakePoolExtendedSigningKey
               (StakePoolExtendedSigningKey poolExtendedSKey)
             ) ->
             ShelleyExtendedSigningKey poolExtendedSKey

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

@@ -200,12 +200,10 @@ module Cardano.Api.Shelley
   , DRepMetadataReference (DRepMetadataReference)
 
     -- ** Stake pool operator's keys
-  , AnyStakePoolKeyWrapper (..)
-  , rewrapAnyStakePoolKey
-  , foldStakePoolKey
-  , liftStakePoolKey
-  , liftStakePoolKeyM
-  , castHashToNormal
+  , AnyStakePoolVerificationKey (..)
+  , anyStakePoolVerificationKeyHash
+  , AnyStakePoolSigningKey (..)
+  , anyStakePoolSigningKeyToVerificationKey
   , StakePoolExtendedKey
   , StakePoolKey
   , PoolId

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

@@ -215,8 +215,8 @@ test_OperationalCertIssueError =
     [
       ( "OperationalCertKeyMismatch"
       , OperationalCertKeyMismatch
-          (StakePoolNormalKeyWrapper stakePoolVerKey1)
-          (StakePoolNormalKeyWrapper stakePoolVerKey2)
+          (AnyStakePoolNormalVerificationKey stakePoolVerKey1)
+          (AnyStakePoolNormalVerificationKey stakePoolVerKey2)
       )
     ]