{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Core.KeyPair (
  mkAddr,
  mkScriptAddr,
  mkCred,
  KeyPair (..),
  KeyPairs,
  mkWitnessVKey,
  mkWitnessesVKey,
  makeWitnessesFromScriptKeys,
  mkKeyHashWitFunPair,
  mkVKeyRewardAccount,
  mkKeyPair,
  mkKeyPairWithSeed,
  mkKeyHash,
  ByronKeyPair (..),
  mkBootKeyPairWithSeed,
  genByronVKeyAddr,
  genByronAddrFromVKey,
)
where

import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Crypto.DSIGN as DSIGN
import Cardano.Crypto.Hash (hashToBytes)
import qualified Cardano.Crypto.Hash as Hash
import Cardano.Crypto.Seed (mkSeedFromBytes)
import qualified Cardano.Crypto.Signing as Byron (
  SigningKey,
  VerificationKey (..),
  deterministicKeyGen,
 )
import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes (Network (Testnet))
import Cardano.Ledger.Binary (EncCBOR (encCBOR))
import Cardano.Ledger.Binary.Coders (Encode (..), encode, (!>))
import qualified Cardano.Ledger.Binary.Coders as Coders
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (
  Credential (..),
  StakeReference (..),
 )
import Cardano.Ledger.Keys (
  DSIGN,
  HasKeyRole,
  VKey (..),
  asWitness,
  signedDSIGN,
 )
import Cardano.Ledger.Keys.WitVKey
import Control.DeepSeq (NFData)
import qualified Data.ByteString as BS
import Data.Coerce (coerce)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.TreeDiff as Tree (Expr (..))
import Data.Typeable
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import System.Random.Stateful
import qualified Test.Cardano.Chain.Common.Gen as Byron
import qualified Test.Cardano.Crypto.Gen as Byron
import Test.Cardano.Ledger.Binary.Random (QC (..))
import Test.Cardano.Ledger.Common (ToExpr (..))
import Test.Cardano.Ledger.TreeDiff ()
import Test.QuickCheck
import Test.QuickCheck.Hedgehog (hedgehog)

data KeyPair (kd :: KeyRole) = KeyPair
  { forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey :: !(VKey kd)
  , forall (kd :: KeyRole). KeyPair kd -> SignKeyDSIGN DSIGN
sKey :: !(DSIGN.SignKeyDSIGN DSIGN)
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (kd :: KeyRole) x. Rep (KeyPair kd) x -> KeyPair kd
forall (kd :: KeyRole) x. KeyPair kd -> Rep (KeyPair kd) x
$cto :: forall (kd :: KeyRole) x. Rep (KeyPair kd) x -> KeyPair kd
$cfrom :: forall (kd :: KeyRole) x. KeyPair kd -> Rep (KeyPair kd) x
Generic, Int -> KeyPair kd -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (kd :: KeyRole). Int -> KeyPair kd -> ShowS
forall (kd :: KeyRole). [KeyPair kd] -> ShowS
forall (kd :: KeyRole). KeyPair kd -> String
showList :: [KeyPair kd] -> ShowS
$cshowList :: forall (kd :: KeyRole). [KeyPair kd] -> ShowS
show :: KeyPair kd -> String
$cshow :: forall (kd :: KeyRole). KeyPair kd -> String
showsPrec :: Int -> KeyPair kd -> ShowS
$cshowsPrec :: forall (kd :: KeyRole). Int -> KeyPair kd -> ShowS
Show)

-- | Representation of a list of pairs of key pairs, e.g., pay and stake keys
type KeyPairs = [(KeyPair 'Payment, KeyPair 'Staking)]

instance NFData (KeyPair kd)

instance NoThunks (KeyPair kd)

instance HasKeyRole KeyPair

instance Arbitrary (KeyPair kd) where
  arbitrary :: Gen (KeyPair kd)
arbitrary = forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM QC
QC

instance Uniform (KeyPair kd) where
  uniformM :: forall g (m :: * -> *). StatefulGen g m => g -> m (KeyPair kd)
uniformM g
g =
    forall (r :: KeyRole). ByteString -> KeyPair r
mkKeyPairWithSeed
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall g (m :: * -> *). StatefulGen g m => Int -> g -> m ByteString
uniformByteStringM (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
DSIGN.seedSizeDSIGN (forall {k} (t :: k). Proxy t
Proxy @DSIGN))) g
g

instance Typeable r => EncCBOR (KeyPair r) where
  encCBOR :: KeyPair r -> Encoding
encCBOR (KeyPair VKey r
x SignKeyDSIGN DSIGN
y) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Encode ('Closed 'Dense) t
Coders.Rec forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To VKey r
x forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To SignKeyDSIGN DSIGN
y

deriving instance Typeable r => Eq (KeyPair r)

instance ToExpr (KeyPair r) where
  toExpr :: KeyPair r -> Expr
toExpr (KeyPair VKey r
x SignKeyDSIGN DSIGN
y) = String -> [Expr] -> Expr
Tree.App String
"KeyPair" [forall a. ToExpr a => a -> Expr
toExpr VKey r
x, String -> [Expr] -> Expr
Tree.App (forall a. Int -> [a] -> [a]
take Int
10 (forall a. Show a => a -> String
show SignKeyDSIGN DSIGN
y)) []]

mkAddr :: (KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr :: (KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr (KeyPair 'Payment
payKey, KeyPair 'Staking
stakeKey) = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred KeyPair 'Payment
payKey) (StakeCredential -> StakeReference
StakeRefBase forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred KeyPair 'Staking
stakeKey)

mkScriptAddr :: ScriptHash -> KeyPair 'Staking -> Addr
mkScriptAddr :: ScriptHash -> KeyPair 'Staking -> Addr
mkScriptAddr ScriptHash
scriptHash KeyPair 'Staking
stakeKey =
  Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash) (StakeCredential -> StakeReference
StakeRefBase forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred KeyPair 'Staking
stakeKey)

mkCred :: KeyPair kr -> Credential kr
mkCred :: forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred KeyPair kr
k = forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair kr
k

-- | Create a witness for transaction
mkWitnessVKey ::
  SafeHash EraIndependentTxBody ->
  KeyPair kr ->
  WitVKey 'Witness
mkWitnessVKey :: forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey SafeHash EraIndependentTxBody
safe KeyPair kr
keys =
  forall (kr :: KeyRole).
Typeable kr =>
VKey kr
-> SignedDSIGN DSIGN (Hash Blake2b_256 EraIndependentTxBody)
-> WitVKey kr
WitVKey (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair kr
keys) (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a.
Signable DSIGN a =>
SignKeyDSIGN DSIGN -> a -> SignedDSIGN DSIGN a
signedDSIGN (forall (kd :: KeyRole). KeyPair kd -> SignKeyDSIGN DSIGN
sKey KeyPair kr
keys) (forall i. SafeHash i -> Hash Blake2b_256 i
extractHash SafeHash EraIndependentTxBody
safe))

-- | Create witnesses for transaction
mkWitnessesVKey ::
  SafeHash EraIndependentTxBody ->
  [KeyPair kr] ->
  Set (WitVKey 'Witness)
mkWitnessesVKey :: forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey SafeHash EraIndependentTxBody
safe [KeyPair kr]
xs = forall a. Ord a => [a] -> Set a
Set.fromList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey SafeHash EraIndependentTxBody
safe) [KeyPair kr]
xs)

-- | From a list of key pairs and a set of key hashes required for a multi-sig
-- scripts, return the set of required keys.
makeWitnessesFromScriptKeys ::
  SafeHash EraIndependentTxBody ->
  Map (KeyHash kr) (KeyPair kr) ->
  Set (KeyHash kr) ->
  Set (WitVKey 'Witness)
makeWitnessesFromScriptKeys :: forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> Map (KeyHash kr) (KeyPair kr)
-> Set (KeyHash kr)
-> Set (WitVKey 'Witness)
makeWitnessesFromScriptKeys SafeHash EraIndependentTxBody
txbodyHash Map (KeyHash kr) (KeyPair kr)
hashKeyMap Set (KeyHash kr)
scriptHashes =
  let witKeys :: Map (KeyHash kr) (KeyPair kr)
witKeys = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (KeyHash kr) (KeyPair kr)
hashKeyMap Set (KeyHash kr)
scriptHashes
   in forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey SafeHash EraIndependentTxBody
txbodyHash (forall k a. Map k a -> [a]
Map.elems Map (KeyHash kr) (KeyPair kr)
witKeys)

-- | When wrting a test which needs a KeyHash, and you will also later need a witness
--   for that function, use 'keyHashWitFunPair'. Since one cannot make a witness until
--   one has SafeHash of the TxBody that the KeyHash is embedded. The second part of the
--   pair is a (SafeHash to WitVKey) function. Use it something like this
--   do (key,witfun) <- keyHashWitFunPair
--      txbody <- ... key ...
--      let safehash = hashAnnotated txbody
--          tx = ... txbody ... (witfun safehash) ...
mkKeyHashWitFunPair ::
  forall kr.
  Gen (KeyHash kr, SafeHash EraIndependentTxBody -> WitVKey 'Witness)
mkKeyHashWitFunPair :: forall (kr :: KeyRole).
Gen (KeyHash kr, SafeHash EraIndependentTxBody -> WitVKey 'Witness)
mkKeyHashWitFunPair = do
  keyPair :: KeyPair kr
keyPair@(KeyPair VKey kr
vk SignKeyDSIGN DSIGN
_) <- forall a. Arbitrary a => Gen a
arbitrary @(KeyPair kr)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey kr
vk, \SafeHash EraIndependentTxBody
safeHash -> forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey SafeHash EraIndependentTxBody
safeHash KeyPair kr
keyPair)

mkVKeyRewardAccount ::
  Network ->
  KeyPair 'Staking ->
  RewardAccount
mkVKeyRewardAccount :: Network -> KeyPair 'Staking -> RewardAccount
mkVKeyRewardAccount Network
network KeyPair 'Staking
keys = Network -> StakeCredential -> RewardAccount
RewardAccount Network
network forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Staking
keys)

mkKeyHash :: Int -> KeyHash kd
mkKeyHash :: forall (kd :: KeyRole). Int -> KeyHash kd
mkKeyHash = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: KeyRole). Int -> KeyPair r
mkKeyPair

mkKeyPair :: Int -> KeyPair r
mkKeyPair :: forall (r :: KeyRole). Int -> KeyPair r
mkKeyPair = forall (r :: KeyRole). ByteString -> KeyPair r
mkKeyPairWithSeed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToCBOR a => a -> ByteString
Plain.serialize'

mkKeyPairWithSeed :: BS.ByteString -> KeyPair r
mkKeyPairWithSeed :: forall (r :: KeyRole). ByteString -> KeyPair r
mkKeyPairWithSeed ByteString
inputSeed = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair VKey r
vk SignKeyDSIGN DSIGN
sk
  where
    vk :: VKey r
vk = forall (kd :: KeyRole). VerKeyDSIGN DSIGN -> VKey kd
VKey (forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
DSIGN.deriveVerKeyDSIGN SignKeyDSIGN DSIGN
sk)
    sk :: SignKeyDSIGN DSIGN
sk = forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
DSIGN.genKeyDSIGN forall a b. (a -> b) -> a -> b
$ ByteString -> Seed
mkSeedFromBytes forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
ensure32ByteSeed ByteString
inputSeed

data ByronKeyPair = ByronKeyPair
  { ByronKeyPair -> VerificationKey
bkpVerificationKey :: !Byron.VerificationKey
  , ByronKeyPair -> SigningKey
bkpSigningKey :: !Byron.SigningKey
  }
  deriving (forall x. Rep ByronKeyPair x -> ByronKeyPair
forall x. ByronKeyPair -> Rep ByronKeyPair x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ByronKeyPair x -> ByronKeyPair
$cfrom :: forall x. ByronKeyPair -> Rep ByronKeyPair x
Generic, Int -> ByronKeyPair -> ShowS
[ByronKeyPair] -> ShowS
ByronKeyPair -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ByronKeyPair] -> ShowS
$cshowList :: [ByronKeyPair] -> ShowS
show :: ByronKeyPair -> String
$cshow :: ByronKeyPair -> String
showsPrec :: Int -> ByronKeyPair -> ShowS
$cshowsPrec :: Int -> ByronKeyPair -> ShowS
Show)

instance Arbitrary ByronKeyPair where
  arbitrary :: Gen ByronKeyPair
arbitrary = forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM QC
QC

instance Uniform ByronKeyPair where
  uniformM :: forall g (m :: * -> *). StatefulGen g m => g -> m ByronKeyPair
uniformM g
g = ByteString -> ByronKeyPair
mkBootKeyPairWithSeed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall g (m :: * -> *). StatefulGen g m => Int -> g -> m ByteString
uniformByteStringM Int
32 g
g

mkBootKeyPairWithSeed :: BS.ByteString -> ByronKeyPair
mkBootKeyPairWithSeed :: ByteString -> ByronKeyPair
mkBootKeyPairWithSeed = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry VerificationKey -> SigningKey -> ByronKeyPair
ByronKeyPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (VerificationKey, SigningKey)
Byron.deterministicKeyGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
ensure32ByteSeed

ensure32ByteSeed :: BS.ByteString -> BS.ByteString
ensure32ByteSeed :: ByteString -> ByteString
ensure32ByteSeed ByteString
inputSeed
  | ByteString -> Int
BS.length ByteString
inputSeed forall a. Eq a => a -> a -> Bool
/= Int
seedSize =
      forall h a. Hash h a -> ByteString
hashToBytes forall a b. (a -> b) -> a -> b
$ forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith @Hash.Blake2b_256 forall a. a -> a
id ByteString
inputSeed
  | Bool
otherwise = ByteString
inputSeed
  where
    seedSize :: Int
seedSize = Int
32

genByronVKeyAddr :: Gen (Byron.VerificationKey, Byron.Address)
genByronVKeyAddr :: Gen (VerificationKey, Address)
genByronVKeyAddr = do
  VerificationKey
vkey <- forall a. Gen a -> Gen a
hedgehog Gen VerificationKey
Byron.genVerificationKey
  Address
addr <- VerificationKey -> Gen Address
genByronAddrFromVKey VerificationKey
vkey
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationKey
vkey, Address
addr)

genByronAddrFromVKey :: Byron.VerificationKey -> Gen Byron.Address
genByronAddrFromVKey :: VerificationKey -> Gen Address
genByronAddrFromVKey VerificationKey
vkey =
  AddrSpendingData -> AddrAttributes -> Address
Byron.makeAddress (VerificationKey -> AddrSpendingData
Byron.VerKeyASD VerificationKey
vkey) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen a
hedgehog Gen AddrAttributes
Byron.genAddrAttributes