{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Implementation of address derivation for the random scheme, as
-- implemented by the legacy Cardano wallets.
--
-- For full documentation of the key derivation schemes,
-- see the "Cardano.Crypto.Wallet" module, and the implementation in
-- <https://github.com/input-output-hk/cardano-crypto/blob/4590efa638397e952a51a8994b5543e4ea3c1ecd/cbits/encrypted_sign.c cardano-crypto>.

module Cardano.Wallet.Primitive.AddressDerivation.Byron
    ( -- * Types
      ByronKey(..)
    , DerivationPathFrom

      -- * Generation
    , unsafeGenerateKeyFromSeed
    , generateKeyFromSeed
    , minSeedLengthBytes
    , unsafeMkByronKeyFromMasterKey
    , mkByronKeyFromMasterKey

      -- * Derivation
    , deriveAccountPrivateKey
    , deriveAddressPrivateKey

    ) where

import Prelude

import Cardano.Crypto.Wallet
    ( DerivationScheme (DerivationScheme1)
    , XPrv
    , XPub
    , deriveXPrv
    , generate
    , toXPub
    , unXPrv
    , unXPub
    , xprv
    )
import Cardano.Mnemonic
    ( SomeMnemonic (..), entropyToBytes, mnemonicToEntropy )
import Cardano.Wallet.Primitive.AddressDerivation
    ( BoundedAddressLength (..)
    , Depth (..)
    , DerivationType (..)
    , ErrMkKeyFingerprint (..)
    , Index (..)
    , KeyFingerprint (..)
    , MkKeyFingerprint (..)
    , NetworkDiscriminant (..)
    , PaymentAddress (..)
    , PersistPrivateKey (..)
    , WalletKey (..)
    , fromHex
    , hex
    )
import Cardano.Wallet.Primitive.Passphrase
    ( Passphrase (..)
    , PassphraseHash (..)
    , PassphraseScheme (..)
    , changePassphraseXPrv
    )
import Cardano.Wallet.Primitive.Types.Address
    ( Address (..) )
import Cardano.Wallet.Primitive.Types.ProtocolMagic
    ( ProtocolMagic (..), testnetMagic )
import Cardano.Wallet.Util
    ( invariant )
import Control.DeepSeq
    ( NFData )
import Crypto.Hash
    ( hash )
import Crypto.Hash.Algorithms
    ( SHA512 (..) )
import Crypto.Hash.Utils
    ( blake2b256 )
import Data.ByteArray
    ( ScrubbedBytes )
import Data.ByteString
    ( ByteString )
import Data.Kind
    ( Type )
import Data.Proxy
    ( Proxy (..) )
import GHC.Generics
    ( Generic )
import GHC.TypeLits
    ( KnownNat )

import qualified Cardano.Byron.Codec.Cbor as CBOR
import qualified Cardano.Crypto.Wallet as CC
import qualified Cardano.Wallet.Primitive.AddressDerivation as W
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Write as CBOR
import qualified Crypto.KDF.PBKDF2 as PBKDF2
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8

{-------------------------------------------------------------------------------
                                   Key Types
-------------------------------------------------------------------------------}

-- | Material for deriving HD random scheme keys, which can be used for making
-- addresses.
data ByronKey (depth :: Depth) key = ByronKey
    { ByronKey depth key -> key
getKey :: key
    -- ^ The raw private or public key.
    , ByronKey depth key -> DerivationPathFrom depth
derivationPath :: DerivationPathFrom depth
    -- ^ The address derivation indices for the level of this key.
    , ByronKey depth key -> Passphrase "addr-derivation-payload"
payloadPassphrase :: Passphrase "addr-derivation-payload"
    -- ^ Used for encryption of payload containing address derivation path.
    } deriving stock ((forall x. ByronKey depth key -> Rep (ByronKey depth key) x)
-> (forall x. Rep (ByronKey depth key) x -> ByronKey depth key)
-> Generic (ByronKey depth key)
forall x. Rep (ByronKey depth key) x -> ByronKey depth key
forall x. ByronKey depth key -> Rep (ByronKey depth key) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (depth :: Depth) key x.
Rep (ByronKey depth key) x -> ByronKey depth key
forall (depth :: Depth) key x.
ByronKey depth key -> Rep (ByronKey depth key) x
$cto :: forall (depth :: Depth) key x.
Rep (ByronKey depth key) x -> ByronKey depth key
$cfrom :: forall (depth :: Depth) key x.
ByronKey depth key -> Rep (ByronKey depth key) x
Generic)

instance (NFData key, NFData (DerivationPathFrom depth)) => NFData (ByronKey depth key)
deriving instance (Show key, Show (DerivationPathFrom depth)) => Show (ByronKey depth key)
deriving instance (Eq key, Eq (DerivationPathFrom depth)) => Eq (ByronKey depth key)

-- | The hierarchical derivation indices for a given level/depth.
type family DerivationPathFrom (depth :: Depth) :: Type where
    -- The root key is generated from the seed.
    DerivationPathFrom 'RootK =
        ()
    -- The account key is generated from the root key and account index.
    DerivationPathFrom 'AccountK =
        Index 'WholeDomain 'AccountK
    -- The address key is generated from the account key and address index.
    DerivationPathFrom 'AddressK =
        (Index 'WholeDomain 'AccountK, Index 'WholeDomain 'AddressK)

instance WalletKey ByronKey where
    changePassphrase :: (PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user")
-> ByronKey depth XPrv
-> ByronKey depth XPrv
changePassphrase = (PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user")
-> ByronKey depth XPrv
-> ByronKey depth XPrv
forall (depth :: Depth).
(PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user")
-> ByronKey depth XPrv
-> ByronKey depth XPrv
changePassphraseRnd
    -- Extract the public key part of a private key.
    publicKey :: ByronKey depth XPrv -> ByronKey depth XPub
publicKey = (XPrv -> XPub) -> ByronKey depth XPrv -> ByronKey depth XPub
forall key key' (depth :: Depth).
(key -> key') -> ByronKey depth key -> ByronKey depth key'
mapKey HasCallStack => XPrv -> XPub
XPrv -> XPub
toXPub
    -- Hash a public key to some other representation.
    digest :: ByronKey depth XPub -> Digest a
digest = ByteString -> Digest a
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash (ByteString -> Digest a)
-> (ByronKey depth XPub -> ByteString)
-> ByronKey depth XPub
-> Digest a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPub -> ByteString
unXPub (XPub -> ByteString)
-> (ByronKey depth XPub -> XPub)
-> ByronKey depth XPub
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByronKey depth XPub -> XPub
forall (depth :: Depth) raw. ByronKey depth raw -> raw
getKey
    getRawKey :: ByronKey depth raw -> raw
getRawKey = ByronKey depth raw -> raw
forall (depth :: Depth) raw. ByronKey depth raw -> raw
getKey
    liftRawKey :: raw -> ByronKey depth raw
liftRawKey = String -> raw -> ByronKey depth raw
forall a. HasCallStack => String -> a
error String
"not supported"
    keyTypeDescriptor :: Proxy ByronKey -> String
keyTypeDescriptor Proxy ByronKey
_ = String
"rnd"

instance KnownNat pm => PaymentAddress ('Testnet pm) ByronKey where
    paymentAddress :: ByronKey 'AddressK XPub -> Address
paymentAddress ByronKey 'AddressK XPub
k = ByteString -> Address
Address
        (ByteString -> Address) -> ByteString -> Address
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString
CBOR.toStrictByteString
        (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ XPub -> [Encoding] -> Encoding
CBOR.encodeAddress (ByronKey 'AddressK XPub -> XPub
forall (depth :: Depth) raw. ByronKey depth raw -> raw
getKey ByronKey 'AddressK XPub
k)
            [ Passphrase "addr-derivation-payload"
-> Index 'WholeDomain 'AccountK
-> Index 'WholeDomain 'AddressK
-> Encoding
CBOR.encodeDerivationPathAttr Passphrase "addr-derivation-payload"
pwd Index 'WholeDomain 'AccountK
acctIx Index 'WholeDomain 'AddressK
addrIx
            , ProtocolMagic -> Encoding
CBOR.encodeProtocolMagicAttr (KnownNat pm => ProtocolMagic
forall (pm :: Nat). KnownNat pm => ProtocolMagic
testnetMagic @pm)
            ]
      where
        (Index 'WholeDomain 'AccountK
acctIx, Index 'WholeDomain 'AddressK
addrIx) = ByronKey 'AddressK XPub -> DerivationPathFrom 'AddressK
forall (depth :: Depth) key.
ByronKey depth key -> DerivationPathFrom depth
derivationPath ByronKey 'AddressK XPub
k
        pwd :: Passphrase "addr-derivation-payload"
pwd = ByronKey 'AddressK XPub -> Passphrase "addr-derivation-payload"
forall (depth :: Depth) key.
ByronKey depth key -> Passphrase "addr-derivation-payload"
payloadPassphrase ByronKey 'AddressK XPub
k
    liftPaymentAddress :: KeyFingerprint "payment" ByronKey -> Address
liftPaymentAddress (KeyFingerprint ByteString
bytes) =
        ByteString -> Address
Address ByteString
bytes

instance PaymentAddress 'Mainnet ByronKey where
    paymentAddress :: ByronKey 'AddressK XPub -> Address
paymentAddress ByronKey 'AddressK XPub
k = ByteString -> Address
Address
        (ByteString -> Address) -> ByteString -> Address
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString
CBOR.toStrictByteString
        (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ XPub -> [Encoding] -> Encoding
CBOR.encodeAddress (ByronKey 'AddressK XPub -> XPub
forall (depth :: Depth) raw. ByronKey depth raw -> raw
getKey ByronKey 'AddressK XPub
k)
            [ Passphrase "addr-derivation-payload"
-> Index 'WholeDomain 'AccountK
-> Index 'WholeDomain 'AddressK
-> Encoding
CBOR.encodeDerivationPathAttr Passphrase "addr-derivation-payload"
pwd Index 'WholeDomain 'AccountK
acctIx Index 'WholeDomain 'AddressK
addrIx ]
      where
        (Index 'WholeDomain 'AccountK
acctIx, Index 'WholeDomain 'AddressK
addrIx) = ByronKey 'AddressK XPub -> DerivationPathFrom 'AddressK
forall (depth :: Depth) key.
ByronKey depth key -> DerivationPathFrom depth
derivationPath ByronKey 'AddressK XPub
k
        pwd :: Passphrase "addr-derivation-payload"
pwd = ByronKey 'AddressK XPub -> Passphrase "addr-derivation-payload"
forall (depth :: Depth) key.
ByronKey depth key -> Passphrase "addr-derivation-payload"
payloadPassphrase ByronKey 'AddressK XPub
k
    liftPaymentAddress :: KeyFingerprint "payment" ByronKey -> Address
liftPaymentAddress (KeyFingerprint ByteString
bytes) =
        ByteString -> Address
Address ByteString
bytes

instance MkKeyFingerprint ByronKey Address where
    paymentKeyFingerprint :: Address
-> Either
     (ErrMkKeyFingerprint ByronKey Address)
     (KeyFingerprint "payment" ByronKey)
paymentKeyFingerprint addr :: Address
addr@(Address ByteString
bytes) =
        case (forall s. Decoder s ByteString) -> ByteString -> Maybe ByteString
forall a. (forall s. Decoder s a) -> ByteString -> Maybe a
CBOR.deserialiseCbor forall s. Decoder s ByteString
CBOR.decodeAddressPayload ByteString
bytes of
            Just ByteString
_  -> KeyFingerprint "payment" ByronKey
-> Either
     (ErrMkKeyFingerprint ByronKey Address)
     (KeyFingerprint "payment" ByronKey)
forall a b. b -> Either a b
Right (KeyFingerprint "payment" ByronKey
 -> Either
      (ErrMkKeyFingerprint ByronKey Address)
      (KeyFingerprint "payment" ByronKey))
-> KeyFingerprint "payment" ByronKey
-> Either
     (ErrMkKeyFingerprint ByronKey Address)
     (KeyFingerprint "payment" ByronKey)
forall a b. (a -> b) -> a -> b
$ ByteString -> KeyFingerprint "payment" ByronKey
forall k (s :: Symbol) (key :: k).
ByteString -> KeyFingerprint s key
KeyFingerprint ByteString
bytes
            Maybe ByteString
Nothing -> ErrMkKeyFingerprint ByronKey Address
-> Either
     (ErrMkKeyFingerprint ByronKey Address)
     (KeyFingerprint "payment" ByronKey)
forall a b. a -> Either a b
Left (ErrMkKeyFingerprint ByronKey Address
 -> Either
      (ErrMkKeyFingerprint ByronKey Address)
      (KeyFingerprint "payment" ByronKey))
-> ErrMkKeyFingerprint ByronKey Address
-> Either
     (ErrMkKeyFingerprint ByronKey Address)
     (KeyFingerprint "payment" ByronKey)
forall a b. (a -> b) -> a -> b
$ Address -> Proxy ByronKey -> ErrMkKeyFingerprint ByronKey Address
forall k (key :: k) from.
from -> Proxy key -> ErrMkKeyFingerprint key from
ErrInvalidAddress Address
addr (Proxy ByronKey
forall k (t :: k). Proxy t
Proxy @ByronKey)

instance BoundedAddressLength ByronKey where
    -- Matching 'paymentAddress' above.
    maxLengthAddressFor :: Proxy ByronKey -> Address
maxLengthAddressFor Proxy ByronKey
_ = ByteString -> Address
Address
        (ByteString -> Address) -> ByteString -> Address
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString
CBOR.toStrictByteString
        (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ XPub -> [Encoding] -> Encoding
CBOR.encodeAddress XPub
xpub
            [ Passphrase "addr-derivation-payload"
-> Index 'WholeDomain 'AccountK
-> Index 'WholeDomain 'AddressK
-> Encoding
CBOR.encodeDerivationPathAttr Passphrase "addr-derivation-payload"
passphrase Index 'WholeDomain 'AccountK
forall a. Bounded a => a
maxBound Index 'WholeDomain 'AddressK
forall a. Bounded a => a
maxBound
            , ProtocolMagic -> Encoding
CBOR.encodeProtocolMagicAttr (Int32 -> ProtocolMagic
ProtocolMagic Int32
forall a. Bounded a => a
maxBound)
            ]
      where
        -- Must apparently always be 32 bytes:
        passphrase :: Passphrase "addr-derivation-payload"
        passphrase :: Passphrase "addr-derivation-payload"
passphrase = ScrubbedBytes -> Passphrase "addr-derivation-payload"
forall (purpose :: Symbol). ScrubbedBytes -> Passphrase purpose
Passphrase (ScrubbedBytes -> Passphrase "addr-derivation-payload")
-> ScrubbedBytes -> Passphrase "addr-derivation-payload"
forall a b. (a -> b) -> a -> b
$ ByteString -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ByteString -> ScrubbedBytes) -> ByteString -> ScrubbedBytes
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0

        xpub :: CC.XPub
        xpub :: XPub
xpub = HasCallStack => XPrv -> XPub
XPrv -> XPub
CC.toXPub (XPrv -> XPub) -> XPrv -> XPub
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> XPrv
forall passPhrase seed.
(ByteArrayAccess passPhrase, ByteArrayAccess seed) =>
seed -> passPhrase -> XPrv
CC.generate (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0) ByteString
xprvPass
          where
            xprvPass :: ByteString
xprvPass = ByteString
forall a. Monoid a => a
mempty :: BS.ByteString

{-------------------------------------------------------------------------------
                                 Key generation
-------------------------------------------------------------------------------}

-- | The amount of entropy carried by a BIP-39 12-word mnemonic is 16 bytes.
minSeedLengthBytes :: Int
minSeedLengthBytes :: Int
minSeedLengthBytes = Int
16

-- | Generate a root key from a corresponding seed.
-- The seed should be at least 16 bytes.
generateKeyFromSeed
    :: SomeMnemonic
    -> Passphrase "encryption"
    -> ByronKey 'RootK XPrv
generateKeyFromSeed :: SomeMnemonic -> Passphrase "encryption" -> ByronKey 'RootK XPrv
generateKeyFromSeed = DerivationPathFrom 'RootK
-> SomeMnemonic -> Passphrase "encryption" -> ByronKey 'RootK XPrv
forall (depth :: Depth).
DerivationPathFrom depth
-> SomeMnemonic -> Passphrase "encryption" -> ByronKey depth XPrv
unsafeGenerateKeyFromSeed ()

-- | Generate a new key from seed. Note that the @depth@ is left open so that
-- the caller gets to decide what type of key this is. This is mostly for
-- testing, in practice, seeds are used to represent root keys, and one should
-- use 'generateKeyFromSeed'.
unsafeGenerateKeyFromSeed
    :: DerivationPathFrom depth
    -> SomeMnemonic
    -> Passphrase "encryption"
    -> ByronKey depth XPrv
unsafeGenerateKeyFromSeed :: DerivationPathFrom depth
-> SomeMnemonic -> Passphrase "encryption" -> ByronKey depth XPrv
unsafeGenerateKeyFromSeed DerivationPathFrom depth
derivationPath (SomeMnemonic Mnemonic mw
mw) (Passphrase ScrubbedBytes
pwd) = ByronKey :: forall (depth :: Depth) key.
key
-> DerivationPathFrom depth
-> Passphrase "addr-derivation-payload"
-> ByronKey depth key
ByronKey
    { getKey :: XPrv
getKey = XPrv
masterKey
    , DerivationPathFrom depth
derivationPath :: DerivationPathFrom depth
derivationPath :: DerivationPathFrom depth
derivationPath
    , payloadPassphrase :: Passphrase "addr-derivation-payload"
payloadPassphrase = XPub -> Passphrase "addr-derivation-payload"
hdPassphrase (HasCallStack => XPrv -> XPub
XPrv -> XPub
toXPub XPrv
masterKey)
    }
  where
    masterKey :: XPrv
masterKey = ScrubbedBytes -> ScrubbedBytes -> XPrv
forall passPhrase seed.
(ByteArrayAccess passPhrase, ByteArrayAccess seed) =>
seed -> passPhrase -> XPrv
generate (ScrubbedBytes -> ScrubbedBytes
hashSeed ScrubbedBytes
seed') ScrubbedBytes
pwd
    seed :: ScrubbedBytes
seed  = Entropy (EntropySize mw) -> ScrubbedBytes
forall (n :: Nat). Entropy n -> ScrubbedBytes
entropyToBytes (Entropy (EntropySize mw) -> ScrubbedBytes)
-> Entropy (EntropySize mw) -> ScrubbedBytes
forall a b. (a -> b) -> a -> b
$ Mnemonic mw -> Entropy (EntropySize mw)
forall (mw :: Nat). Mnemonic mw -> Entropy (EntropySize mw)
mnemonicToEntropy Mnemonic mw
mw
    seed' :: ScrubbedBytes
seed' = String -> ScrubbedBytes -> (ScrubbedBytes -> Bool) -> ScrubbedBytes
forall a. HasCallStack => String -> a -> (a -> Bool) -> a
invariant
        (String
"seed length : " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ScrubbedBytes -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length ScrubbedBytes
seed)
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" in (Passphrase \"seed\") is not valid")
        ScrubbedBytes
seed
        (\ScrubbedBytes
s -> ScrubbedBytes -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length ScrubbedBytes
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minSeedLengthBytes Bool -> Bool -> Bool
&& ScrubbedBytes -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length ScrubbedBytes
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255)

-- | Hash the seed entropy (generated from mnemonic) used to initiate a HD
-- wallet. This increases the key length to 34 bytes, selectKey is greater than the
-- minimum for 'generate' (32 bytes).
--
-- Note that our current implementation deviates from BIP-39 because we use a
-- hash function (Blake2b) rather than key stretching with PBKDF2.
--
-- There are two methods of hashing the seed entropy, for different use cases.
--
-- 1. Normal random derivation wallet seeds. The seed entropy is hashed using
--    Blake2b_256, inside a double CBOR serialization sandwich.
--
-- 2. Seeds for redeeming paper wallets. The seed entropy is hashed using
--    Blake2b_256, without any serialization.
hashSeed :: ScrubbedBytes -> ScrubbedBytes
hashSeed :: ScrubbedBytes -> ScrubbedBytes
hashSeed = ByteString -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ByteString -> ScrubbedBytes)
-> (ScrubbedBytes -> ByteString) -> ScrubbedBytes -> ScrubbedBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
cbor (ByteString -> ByteString)
-> (ScrubbedBytes -> ByteString) -> ScrubbedBytes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
blake2b256 (ByteString -> ByteString)
-> (ScrubbedBytes -> ByteString) -> ScrubbedBytes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
cbor (ByteString -> ByteString)
-> (ScrubbedBytes -> ByteString) -> ScrubbedBytes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrubbedBytes -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
  where
    cbor :: ByteString -> ByteString
cbor = Encoding -> ByteString
CBOR.toStrictByteString (Encoding -> ByteString)
-> (ByteString -> Encoding) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Encoding
CBOR.encodeBytes

-- | Derive a symmetric key for encrypting and authenticating the address
-- derivation path. PBKDF2 encryption using HMAC with the hash algorithm SHA512
-- is employed.
hdPassphrase :: XPub -> Passphrase "addr-derivation-payload"
hdPassphrase :: XPub -> Passphrase "addr-derivation-payload"
hdPassphrase XPub
masterKey = ScrubbedBytes -> Passphrase "addr-derivation-payload"
forall (purpose :: Symbol). ScrubbedBytes -> Passphrase purpose
Passphrase (ScrubbedBytes -> Passphrase "addr-derivation-payload")
-> ScrubbedBytes -> Passphrase "addr-derivation-payload"
forall a b. (a -> b) -> a -> b
$
    PRF ByteString
-> Parameters -> ByteString -> ByteString -> ScrubbedBytes
forall password salt ba.
(ByteArrayAccess password, ByteArrayAccess salt, ByteArray ba) =>
PRF password -> Parameters -> password -> salt -> ba
PBKDF2.generate
    (SHA512 -> PRF ByteString
forall a password.
(HashAlgorithm a, ByteArrayAccess password) =>
a -> PRF password
PBKDF2.prfHMAC SHA512
SHA512)
    (Int -> Int -> Parameters
PBKDF2.Parameters Int
500 Int
32)
    (XPub -> ByteString
unXPub XPub
masterKey)
    (ByteString
"address-hashing" :: ByteString)

mkByronKeyFromMasterKey
    :: XPrv
    -> ByronKey 'RootK XPrv
mkByronKeyFromMasterKey :: XPrv -> ByronKey 'RootK XPrv
mkByronKeyFromMasterKey = DerivationPathFrom 'RootK -> XPrv -> ByronKey 'RootK XPrv
forall (depth :: Depth).
DerivationPathFrom depth -> XPrv -> ByronKey depth XPrv
unsafeMkByronKeyFromMasterKey ()

unsafeMkByronKeyFromMasterKey
    :: DerivationPathFrom depth
    -> XPrv
    -> ByronKey depth XPrv
unsafeMkByronKeyFromMasterKey :: DerivationPathFrom depth -> XPrv -> ByronKey depth XPrv
unsafeMkByronKeyFromMasterKey DerivationPathFrom depth
derivationPath XPrv
masterKey = ByronKey :: forall (depth :: Depth) key.
key
-> DerivationPathFrom depth
-> Passphrase "addr-derivation-payload"
-> ByronKey depth key
ByronKey
    { getKey :: XPrv
getKey = XPrv
masterKey
    , DerivationPathFrom depth
derivationPath :: DerivationPathFrom depth
derivationPath :: DerivationPathFrom depth
derivationPath
    , payloadPassphrase :: Passphrase "addr-derivation-payload"
payloadPassphrase = XPub -> Passphrase "addr-derivation-payload"
hdPassphrase (HasCallStack => XPrv -> XPub
XPrv -> XPub
toXPub XPrv
masterKey)
    }

{-------------------------------------------------------------------------------
                                   Passphrase
-------------------------------------------------------------------------------}

-- | Re-encrypt the private key using a different passphrase, and regenerate
-- the payload passphrase.
--
-- **Important**:
-- This function doesn't check that the old passphrase is correct! Caller is
-- expected to have already checked that. Using an incorrect passphrase here
-- will lead to very bad thing.
changePassphraseRnd
    :: (PassphraseScheme, Passphrase "user")
    -> (PassphraseScheme, Passphrase "user")
    -> ByronKey depth XPrv
    -> ByronKey depth XPrv
changePassphraseRnd :: (PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user")
-> ByronKey depth XPrv
-> ByronKey depth XPrv
changePassphraseRnd (PassphraseScheme, Passphrase "user")
old (PassphraseScheme, Passphrase "user")
new ByronKey depth XPrv
key = ByronKey :: forall (depth :: Depth) key.
key
-> DerivationPathFrom depth
-> Passphrase "addr-derivation-payload"
-> ByronKey depth key
ByronKey
    { getKey :: XPrv
getKey = XPrv
masterKey
    , derivationPath :: DerivationPathFrom depth
derivationPath = ByronKey depth XPrv -> DerivationPathFrom depth
forall (depth :: Depth) key.
ByronKey depth key -> DerivationPathFrom depth
derivationPath ByronKey depth XPrv
key
    , payloadPassphrase :: Passphrase "addr-derivation-payload"
payloadPassphrase = XPub -> Passphrase "addr-derivation-payload"
hdPassphrase (HasCallStack => XPrv -> XPub
XPrv -> XPub
toXPub XPrv
masterKey)
    }
  where
    masterKey :: XPrv
masterKey = (PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user") -> XPrv -> XPrv
changePassphraseXPrv (PassphraseScheme, Passphrase "user")
old (PassphraseScheme, Passphrase "user")
new (ByronKey depth XPrv -> XPrv
forall (depth :: Depth) raw. ByronKey depth raw -> raw
getKey ByronKey depth XPrv
key)

{-------------------------------------------------------------------------------
                                 HD derivation
-------------------------------------------------------------------------------}

-- TODO
-- This instance is unsound. It only exists because we need to derive the
-- reward account in the wallet engine when making transaction (in case there
-- are any withdrawals).
--
-- With 'ByronKey', withdrawals will always be `0`, and the result of this
-- function shouldn't be evaluated (relying on laziness here). If they do, then
-- we're doing something wrong.
instance W.HardDerivation ByronKey where
    type AddressIndexDerivationType ByronKey = 'WholeDomain

    deriveAccountPrivateKey :: Passphrase "encryption"
-> ByronKey 'RootK XPrv
-> Index 'Hardened 'AccountK
-> ByronKey 'AccountK XPrv
deriveAccountPrivateKey Passphrase "encryption"
_ ByronKey 'RootK XPrv
_ Index 'Hardened 'AccountK
_ = String -> ByronKey 'AccountK XPrv
forall a. HasCallStack => String -> a
error
        String
"unsound evaluation of 'deriveAccountPrivateKey' in the context of Byron key"

    deriveAddressPrivateKey :: Passphrase "encryption"
-> ByronKey 'AccountK XPrv
-> Role
-> Index (AddressIndexDerivationType ByronKey) 'AddressK
-> ByronKey 'AddressK XPrv
deriveAddressPrivateKey Passphrase "encryption"
_ ByronKey 'AccountK XPrv
_ Role
_ Index (AddressIndexDerivationType ByronKey) 'AddressK
_ = String -> ByronKey 'AddressK XPrv
forall a. HasCallStack => String -> a
error
        String
"unsound evaluation of 'deriveAddressPrivateKey' in the context of Byron key"

-- | Derives account private key from the given root private key, using
-- derivation scheme 1.
--
-- NOTE: The caller is expected to provide the corresponding passphrase (and to
-- have checked that the passphrase is valid). Providing a wrong passphrase will
-- not make the function fail but will instead, yield an incorrect new key that
-- doesn't belong to the wallet.
deriveAccountPrivateKey
    :: Passphrase "encryption"
    -> ByronKey 'RootK XPrv
    -> Index 'WholeDomain 'AccountK
    -> ByronKey 'AccountK XPrv
deriveAccountPrivateKey :: Passphrase "encryption"
-> ByronKey 'RootK XPrv
-> Index 'WholeDomain 'AccountK
-> ByronKey 'AccountK XPrv
deriveAccountPrivateKey (Passphrase ScrubbedBytes
pwd) ByronKey 'RootK XPrv
masterKey idx :: Index 'WholeDomain 'AccountK
idx@(Index Word32
accIx) = ByronKey :: forall (depth :: Depth) key.
key
-> DerivationPathFrom depth
-> Passphrase "addr-derivation-payload"
-> ByronKey depth key
ByronKey
    { getKey :: XPrv
getKey = DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme1 ScrubbedBytes
pwd (ByronKey 'RootK XPrv -> XPrv
forall (depth :: Depth) raw. ByronKey depth raw -> raw
getKey ByronKey 'RootK XPrv
masterKey) Word32
accIx
    , derivationPath :: DerivationPathFrom 'AccountK
derivationPath = Index 'WholeDomain 'AccountK
DerivationPathFrom 'AccountK
idx
    , payloadPassphrase :: Passphrase "addr-derivation-payload"
payloadPassphrase = ByronKey 'RootK XPrv -> Passphrase "addr-derivation-payload"
forall (depth :: Depth) key.
ByronKey depth key -> Passphrase "addr-derivation-payload"
payloadPassphrase ByronKey 'RootK XPrv
masterKey
    }

-- | Derives address private key from the given account private key, using
-- derivation scheme 1.
--
-- NOTE: The caller is expected to provide the corresponding passphrase (and to
-- have checked that the passphrase is valid). Providing a wrong passphrase will
-- not make the function fail but will instead, yield an incorrect new key that
-- doesn't belong to the wallet.
deriveAddressPrivateKey
    :: Passphrase "encryption"
    -> ByronKey 'AccountK XPrv
    -> Index 'WholeDomain 'AddressK
    -> ByronKey 'AddressK XPrv
deriveAddressPrivateKey :: Passphrase "encryption"
-> ByronKey 'AccountK XPrv
-> Index 'WholeDomain 'AddressK
-> ByronKey 'AddressK XPrv
deriveAddressPrivateKey (Passphrase ScrubbedBytes
pwd) ByronKey 'AccountK XPrv
accountKey idx :: Index 'WholeDomain 'AddressK
idx@(Index Word32
addrIx) = ByronKey :: forall (depth :: Depth) key.
key
-> DerivationPathFrom depth
-> Passphrase "addr-derivation-payload"
-> ByronKey depth key
ByronKey
    { getKey :: XPrv
getKey = DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme1 ScrubbedBytes
pwd (ByronKey 'AccountK XPrv -> XPrv
forall (depth :: Depth) raw. ByronKey depth raw -> raw
getKey ByronKey 'AccountK XPrv
accountKey) Word32
addrIx
    , derivationPath :: DerivationPathFrom 'AddressK
derivationPath = (ByronKey 'AccountK XPrv -> DerivationPathFrom 'AccountK
forall (depth :: Depth) key.
ByronKey depth key -> DerivationPathFrom depth
derivationPath ByronKey 'AccountK XPrv
accountKey, Index 'WholeDomain 'AddressK
idx)
    , payloadPassphrase :: Passphrase "addr-derivation-payload"
payloadPassphrase = ByronKey 'AccountK XPrv -> Passphrase "addr-derivation-payload"
forall (depth :: Depth) key.
ByronKey depth key -> Passphrase "addr-derivation-payload"
payloadPassphrase ByronKey 'AccountK XPrv
accountKey
    }

{-------------------------------------------------------------------------------
                          Storing and retrieving keys
-------------------------------------------------------------------------------}

instance PersistPrivateKey (ByronKey 'RootK) where
    serializeXPrv :: (ByronKey 'RootK XPrv, PassphraseHash) -> (ByteString, ByteString)
serializeXPrv ((ByronKey XPrv
k DerivationPathFrom 'RootK
_ (Passphrase ScrubbedBytes
p)), PassphraseHash
h) =
        ( ByteString -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
hex (XPrv -> ByteString
unXPrv XPrv
k) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ScrubbedBytes -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
hex ScrubbedBytes
p
        , ScrubbedBytes -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
hex (ScrubbedBytes -> ByteString)
-> (PassphraseHash -> ScrubbedBytes)
-> PassphraseHash
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassphraseHash -> ScrubbedBytes
getPassphraseHash (PassphraseHash -> ByteString) -> PassphraseHash -> ByteString
forall a b. (a -> b) -> a -> b
$ PassphraseHash
h
        )

    unsafeDeserializeXPrv :: (ByteString, ByteString) -> (ByronKey 'RootK XPrv, PassphraseHash)
unsafeDeserializeXPrv (ByteString
k, ByteString
h) = (String -> (ByronKey 'RootK XPrv, PassphraseHash))
-> ((ByronKey 'RootK XPrv, PassphraseHash)
    -> (ByronKey 'RootK XPrv, PassphraseHash))
-> Either String (ByronKey 'RootK XPrv, PassphraseHash)
-> (ByronKey 'RootK XPrv, PassphraseHash)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> (ByronKey 'RootK XPrv, PassphraseHash)
forall p a. p -> a
err (ByronKey 'RootK XPrv, PassphraseHash)
-> (ByronKey 'RootK XPrv, PassphraseHash)
forall a. a -> a
id (Either String (ByronKey 'RootK XPrv, PassphraseHash)
 -> (ByronKey 'RootK XPrv, PassphraseHash))
-> Either String (ByronKey 'RootK XPrv, PassphraseHash)
-> (ByronKey 'RootK XPrv, PassphraseHash)
forall a b. (a -> b) -> a -> b
$ (,)
        (ByronKey 'RootK XPrv
 -> PassphraseHash -> (ByronKey 'RootK XPrv, PassphraseHash))
-> Either String (ByronKey 'RootK XPrv)
-> Either
     String (PassphraseHash -> (ByronKey 'RootK XPrv, PassphraseHash))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((XPrv, Passphrase "addr-derivation-payload")
 -> ByronKey 'RootK XPrv)
-> Either String (XPrv, Passphrase "addr-derivation-payload")
-> Either String (ByronKey 'RootK XPrv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XPrv, Passphrase "addr-derivation-payload")
-> ByronKey 'RootK XPrv
forall (depth :: Depth) key.
(DerivationPathFrom depth ~ ()) =>
(key, Passphrase "addr-derivation-payload") -> ByronKey depth key
mkKey (ByteString
-> Either String (XPrv, Passphrase "addr-derivation-payload")
deserializeKey ByteString
k)
        Either
  String (PassphraseHash -> (ByronKey 'RootK XPrv, PassphraseHash))
-> Either String PassphraseHash
-> Either String (ByronKey 'RootK XPrv, PassphraseHash)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ScrubbedBytes -> PassphraseHash)
-> Either String ScrubbedBytes -> Either String PassphraseHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScrubbedBytes -> PassphraseHash
PassphraseHash (ByteString -> Either String ScrubbedBytes
forall bout. ByteArray bout => ByteString -> Either String bout
fromHex ByteString
h)
      where
        err :: p -> a
err p
_ = String -> a
forall a. HasCallStack => String -> a
error String
"unsafeDeserializeXPrv: unable to deserialize ByronKey"
        mkKey :: (key, Passphrase "addr-derivation-payload") -> ByronKey depth key
mkKey (key
key, Passphrase "addr-derivation-payload"
pwd) = key
-> DerivationPathFrom depth
-> Passphrase "addr-derivation-payload"
-> ByronKey depth key
forall (depth :: Depth) key.
key
-> DerivationPathFrom depth
-> Passphrase "addr-derivation-payload"
-> ByronKey depth key
ByronKey key
key () Passphrase "addr-derivation-payload"
pwd
        deserializeKey
            :: ByteString
            -> Either String
                ( XPrv
                , Passphrase "addr-derivation-payload"
                )
        deserializeKey :: ByteString
-> Either String (XPrv, Passphrase "addr-derivation-payload")
deserializeKey ByteString
b = case (ByteString -> Either String ByteString)
-> [ByteString] -> [Either String ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteArray ByteString => ByteString -> Either String ByteString
forall bout. ByteArray bout => ByteString -> Either String bout
fromHex @ByteString) (Char -> ByteString -> [ByteString]
B8.split Char
':' ByteString
b) of
            [Right ByteString
rawK, Right ByteString
p] ->
                case ByteString -> Either String XPrv
forall bin. ByteArrayAccess bin => bin -> Either String XPrv
xprv ByteString
rawK of
                    Right XPrv
k' -> (XPrv, Passphrase "addr-derivation-payload")
-> Either String (XPrv, Passphrase "addr-derivation-payload")
forall a b. b -> Either a b
Right (XPrv
k', ScrubbedBytes -> Passphrase "addr-derivation-payload"
forall (purpose :: Symbol). ScrubbedBytes -> Passphrase purpose
Passphrase (ByteString -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ByteString
p))
                    Left String
e -> String
-> Either String (XPrv, Passphrase "addr-derivation-payload")
forall a b. a -> Either a b
Left String
e
            [Either String ByteString]
_ ->
                String
-> Either String (XPrv, Passphrase "addr-derivation-payload")
forall a b. a -> Either a b
Left String
"Key input must be two hex strings separated by :"

{-------------------------------------------------------------------------------
                                     Utils
-------------------------------------------------------------------------------}

-- | Transform the wrapped key.
mapKey :: (key -> key') -> ByronKey depth key -> ByronKey depth key'
mapKey :: (key -> key') -> ByronKey depth key -> ByronKey depth key'
mapKey key -> key'
f ByronKey depth key
rnd = ByronKey depth key
rnd { getKey :: key'
getKey = key -> key'
f (ByronKey depth key -> key
forall (depth :: Depth) raw. ByronKey depth raw -> raw
getKey ByronKey depth key
rnd) }