{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (
  Credential (..),
  StakeReference (..),
 )
import Cardano.Ledger.Crypto
import Cardano.Ledger.Keys (
  DSignable,
  HasKeyRole,
  Hash,
  KeyHash (..),
  KeyRole (..),
  VKey (..),
  asWitness,
  hashKey,
  signedDSIGN,
 )
import Cardano.Ledger.Keys.WitVKey
import Cardano.Ledger.SafeHash (SafeHash, extractHash)
import Control.DeepSeq (NFData)
import Control.Exception (assert)
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 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.QuickCheck
import Test.QuickCheck.Hedgehog (hedgehog)

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

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

instance
  ( Crypto c
  , NFData (DSIGN.VerKeyDSIGN (DSIGN c))
  , NFData (DSIGN.SignKeyDSIGN (DSIGN c))
  ) =>
  NFData (KeyPair kd c)

instance Crypto c => NoThunks (KeyPair kd c)

instance HasKeyRole KeyPair

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

instance Crypto c => Uniform (KeyPair kd c) where
  uniformM :: forall g (m :: * -> *). StatefulGen g m => g -> m (KeyPair kd c)
uniformM g
g =
    forall (r :: KeyRole) c. Crypto c => ByteString -> KeyPair r c
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 c)))) g
g

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

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

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

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

-- | Create witnesses for transaction
mkWitnessesVKey ::
  forall c kr.
  ( Crypto c
  , DSignable c (Hash.Hash (HASH c) EraIndependentTxBody)
  ) =>
  SafeHash c EraIndependentTxBody ->
  [KeyPair kr c] ->
  Set (WitVKey 'Witness c)
mkWitnessesVKey :: forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey SafeHash c EraIndependentTxBody
safe [KeyPair kr c]
xs = forall a. Ord a => [a] -> Set a
Set.fromList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey SafeHash c EraIndependentTxBody
safe) [KeyPair kr c]
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 ::
  (Crypto c, DSignable c (Hash c EraIndependentTxBody)) =>
  SafeHash c EraIndependentTxBody ->
  Map (KeyHash kr c) (KeyPair kr c) ->
  Set (KeyHash kr c) ->
  Set (WitVKey 'Witness c)
makeWitnessesFromScriptKeys :: forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash c EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> Map (KeyHash kr c) (KeyPair kr c)
-> Set (KeyHash kr c)
-> Set (WitVKey 'Witness c)
makeWitnessesFromScriptKeys SafeHash c EraIndependentTxBody
txbodyHash Map (KeyHash kr c) (KeyPair kr c)
hashKeyMap Set (KeyHash kr c)
scriptHashes =
  let witKeys :: Map (KeyHash kr c) (KeyPair kr c)
witKeys = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (KeyHash kr c) (KeyPair kr c)
hashKeyMap Set (KeyHash kr c)
scriptHashes
   in forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey SafeHash c EraIndependentTxBody
txbodyHash (forall k a. Map k a -> [a]
Map.elems Map (KeyHash kr c) (KeyPair kr c)
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 StandardCrypto
    , SafeHash StandardCrypto EraIndependentTxBody -> WitVKey 'Witness StandardCrypto
    )
mkKeyHashWitFunPair :: forall (kr :: KeyRole).
Gen
  (KeyHash kr StandardCrypto,
   SafeHash StandardCrypto EraIndependentTxBody
   -> WitVKey 'Witness StandardCrypto)
mkKeyHashWitFunPair = do
  keyPair :: KeyPair kr StandardCrypto
keyPair@(KeyPair VKey kr StandardCrypto
vk SignKeyDSIGN (DSIGN StandardCrypto)
_) <- forall a. Arbitrary a => Gen a
arbitrary @(KeyPair kr StandardCrypto)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey VKey kr StandardCrypto
vk, \SafeHash StandardCrypto EraIndependentTxBody
safehash -> forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey SafeHash StandardCrypto EraIndependentTxBody
safehash KeyPair kr StandardCrypto
keyPair)

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

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

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

mkKeyPairWithSeed :: forall r c. Crypto c => BS.ByteString -> KeyPair r c
mkKeyPairWithSeed :: forall (r :: KeyRole) c. Crypto c => ByteString -> KeyPair r c
mkKeyPairWithSeed ByteString
inputSeed = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word
seedSize forall a. Eq a => a -> a -> Bool
== Word
32) forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c.
VKey kd c -> SignKeyDSIGN (DSIGN c) -> KeyPair kd c
KeyPair VKey r c
vk SignKeyDSIGN (DSIGN c)
sk
  where
    seedSize :: Word
seedSize = forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
DSIGN.seedSizeDSIGN (forall {k} (t :: k). Proxy t
Proxy @(DSIGN c))
    vk :: VKey r c
vk = forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
VKey (forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
DSIGN.deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
sk)
    sk :: SignKeyDSIGN (DSIGN c)
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