{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Implementation of address derivation for 'Icarus' keys. This uses the Byron
-- derivation for addresses, but on top of the derivation scheme V2.

module Cardano.Wallet.Primitive.AddressDerivation.Icarus
    ( -- * Types
      IcarusKey(..)

    -- * Generation and derivation
    , generateKeyFromSeed
    , generateKeyFromHardwareLedger
    , unsafeGenerateKeyFromSeed
    , minSeedLengthBytes
    ) where

import Prelude

import Cardano.Crypto.Wallet
    ( DerivationScheme (..)
    , XPrv
    , XPub
    , deriveXPrv
    , deriveXPub
    , generateNew
    , toXPub
    , unXPrv
    , unXPub
    , xPrvChangePass
    , xprv
    )
import Cardano.Mnemonic
    ( SomeMnemonic (..), entropyToBytes, mnemonicToEntropy, mnemonicToText )
import Cardano.Wallet.Primitive.AddressDerivation
    ( BoundedAddressLength (..)
    , Depth (..)
    , DerivationType (..)
    , ErrMkKeyFingerprint (..)
    , HardDerivation (..)
    , Index (..)
    , KeyFingerprint (..)
    , MkKeyFingerprint (..)
    , NetworkDiscriminant (..)
    , PaymentAddress (..)
    , PersistPrivateKey (..)
    , PersistPublicKey (..)
    , RewardAccount (..)
    , SoftDerivation (..)
    , WalletKey (..)
    , fromHex
    , hex
    )
import Cardano.Wallet.Primitive.AddressDiscovery
    ( DiscoverTxs (..), GetPurpose (..), IsOurs (..), MaybeLight (..) )
import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
    ( SeqState, coinTypeAda, discoverSeq, purposeBIP44 )
import Cardano.Wallet.Primitive.Passphrase
    ( Passphrase (..), PassphraseHash (..), changePassphraseXPrv )
import Cardano.Wallet.Primitive.Types.Address
    ( Address (..) )
import Cardano.Wallet.Primitive.Types.ProtocolMagic
    ( ProtocolMagic (..), testnetMagic )
import Cardano.Wallet.Util
    ( invariant )
import Control.Arrow
    ( first, left )
import Control.DeepSeq
    ( NFData (..) )
import Control.Monad
    ( (<=<) )
import Crypto.Error
    ( eitherCryptoError )
import Crypto.Hash
    ( hash )
import Crypto.Hash.Algorithms
    ( SHA256 (..), SHA512 (..) )
import Crypto.MAC.HMAC
    ( HMAC, hmac )
import Data.Bifunctor
    ( bimap )
import Data.Bits
    ( clearBit, setBit, testBit )
import Data.ByteString
    ( ByteString )
import Data.Coerce
    ( coerce )
import Data.Function
    ( (&) )
import Data.Maybe
    ( fromMaybe )
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 Codec.CBOR.Write as CBOR
import qualified Crypto.ECC.Edwards25519 as Ed25519
import qualified Crypto.KDF.PBKDF2 as PBKDF2
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

-- | A cryptographic key for sequential-scheme address derivation, with
-- phantom-types to disambiguate key types.
--
-- @
-- let rootPrivateKey = IcarusKey 'RootK XPrv
-- let accountPubKey = IcarusKey 'AccountK XPub
-- let addressPubKey = IcarusKey 'AddressK XPub
-- @
newtype IcarusKey (depth :: Depth) key =
    IcarusKey { IcarusKey depth key -> key
getKey :: key }
    deriving stock ((forall x. IcarusKey depth key -> Rep (IcarusKey depth key) x)
-> (forall x. Rep (IcarusKey depth key) x -> IcarusKey depth key)
-> Generic (IcarusKey depth key)
forall x. Rep (IcarusKey depth key) x -> IcarusKey depth key
forall x. IcarusKey depth key -> Rep (IcarusKey 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 (IcarusKey depth key) x -> IcarusKey depth key
forall (depth :: Depth) key x.
IcarusKey depth key -> Rep (IcarusKey depth key) x
$cto :: forall (depth :: Depth) key x.
Rep (IcarusKey depth key) x -> IcarusKey depth key
$cfrom :: forall (depth :: Depth) key x.
IcarusKey depth key -> Rep (IcarusKey depth key) x
Generic, Int -> IcarusKey depth key -> ShowS
[IcarusKey depth key] -> ShowS
IcarusKey depth key -> String
(Int -> IcarusKey depth key -> ShowS)
-> (IcarusKey depth key -> String)
-> ([IcarusKey depth key] -> ShowS)
-> Show (IcarusKey depth key)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (depth :: Depth) key.
Show key =>
Int -> IcarusKey depth key -> ShowS
forall (depth :: Depth) key.
Show key =>
[IcarusKey depth key] -> ShowS
forall (depth :: Depth) key.
Show key =>
IcarusKey depth key -> String
showList :: [IcarusKey depth key] -> ShowS
$cshowList :: forall (depth :: Depth) key.
Show key =>
[IcarusKey depth key] -> ShowS
show :: IcarusKey depth key -> String
$cshow :: forall (depth :: Depth) key.
Show key =>
IcarusKey depth key -> String
showsPrec :: Int -> IcarusKey depth key -> ShowS
$cshowsPrec :: forall (depth :: Depth) key.
Show key =>
Int -> IcarusKey depth key -> ShowS
Show, IcarusKey depth key -> IcarusKey depth key -> Bool
(IcarusKey depth key -> IcarusKey depth key -> Bool)
-> (IcarusKey depth key -> IcarusKey depth key -> Bool)
-> Eq (IcarusKey depth key)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (depth :: Depth) key.
Eq key =>
IcarusKey depth key -> IcarusKey depth key -> Bool
/= :: IcarusKey depth key -> IcarusKey depth key -> Bool
$c/= :: forall (depth :: Depth) key.
Eq key =>
IcarusKey depth key -> IcarusKey depth key -> Bool
== :: IcarusKey depth key -> IcarusKey depth key -> Bool
$c== :: forall (depth :: Depth) key.
Eq key =>
IcarusKey depth key -> IcarusKey depth key -> Bool
Eq)

instance (NFData key) => NFData (IcarusKey depth key)

-- | The minimum seed length for 'generateKeyFromSeed' and 'unsafeGenerateKeyFromSeed'.
minSeedLengthBytes :: Int
minSeedLengthBytes :: Int
minSeedLengthBytes = Int
16

{-------------------------------------------------------------------------------
                               Key Generation
-------------------------------------------------------------------------------}

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

-- | Hardware Ledger devices generates keys from mnemonic using a different
-- approach (different from the rest of Cardano).
--
-- It is a combination of:
--
-- - [SLIP 0010](https://github.com/satoshilabs/slips/blob/master/slip-0010.md)
-- - [BIP 0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki)
-- - [BIP 0039](https://github.com/bitcoin/bips/blob/master/bip-0039.mediawiki)
-- - [RFC 8032](https://tools.ietf.org/html/rfc8032#section-5.1.5)
-- - What seems to be arbitrary changes from Ledger regarding the calculation of
--   the initial chain code and generation of the root private key.
generateKeyFromHardwareLedger
    :: SomeMnemonic
        -- ^ The root mnemonic
    -> Passphrase "encryption"
        -- ^ Master encryption passphrase
    -> IcarusKey 'RootK XPrv
generateKeyFromHardwareLedger :: SomeMnemonic -> Passphrase "encryption" -> IcarusKey 'RootK XPrv
generateKeyFromHardwareLedger (SomeMnemonic Mnemonic mw
mw) (Passphrase ScrubbedBytes
pwd) = Either String (IcarusKey 'RootK XPrv) -> IcarusKey 'RootK XPrv
forall a. Either String a -> a
unsafeFromRight (Either String (IcarusKey 'RootK XPrv) -> IcarusKey 'RootK XPrv)
-> Either String (IcarusKey 'RootK XPrv) -> IcarusKey 'RootK XPrv
forall a b. (a -> b) -> a -> b
$ do
    let seed :: ByteString
seed = ByteString -> ByteString
pbkdf2HmacSha512
            (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8
            (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
" "
            ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Mnemonic mw -> [Text]
forall (mw :: Nat). Mnemonic mw -> [Text]
mnemonicToText Mnemonic mw
mw

    -- NOTE
    -- SLIP-0010 refers to `iR` as the chain code. Here however, the chain code
    -- is obtained as a hash of the initial seed whereas iR is used to make part
    -- of the root private key itself.
    let cc :: ByteString
cc = ByteString -> ByteString
hmacSha256 ([Word8] -> ByteString
BS.pack [Word8
1] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
seed)
    let (ByteString
iL, ByteString
iR) = (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> ByteString
pruneBuffer ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
hashRepeatedly ByteString
seed
    ByteString
pA <- ByteString -> Either String ByteString
ed25519ScalarMult ByteString
iL

    XPrv
prv <- ShowS -> Either String XPrv -> Either String XPrv
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ShowS
forall a. Show a => a -> String
show (Either String XPrv -> Either String XPrv)
-> Either String XPrv -> Either String XPrv
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String XPrv
forall bin. ByteArrayAccess bin => bin -> Either String XPrv
xprv (ByteString -> Either String XPrv)
-> ByteString -> Either String XPrv
forall a b. (a -> b) -> a -> b
$ ByteString
iL ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
iR ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pA ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
cc
    IcarusKey 'RootK XPrv -> Either String (IcarusKey 'RootK XPrv)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IcarusKey 'RootK XPrv -> Either String (IcarusKey 'RootK XPrv))
-> IcarusKey 'RootK XPrv -> Either String (IcarusKey 'RootK XPrv)
forall a b. (a -> b) -> a -> b
$ XPrv -> IcarusKey 'RootK XPrv
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey (ByteString -> ScrubbedBytes -> XPrv -> XPrv
forall oldPassPhrase newPassPhrase.
(ByteArrayAccess oldPassPhrase, ByteArrayAccess newPassPhrase) =>
oldPassPhrase -> newPassPhrase -> XPrv -> XPrv
xPrvChangePass (ByteString
forall a. Monoid a => a
mempty :: ByteString) ScrubbedBytes
pwd XPrv
prv)
  where
    -- Errors yielded in the body of 'generateKeyFromHardwareLedger' are
    -- programmer errors (out-of-range byte buffer access or, invalid length for
    -- cryptographic operations). Therefore, we throw badly if we encounter any.
    unsafeFromRight :: Either String a -> a
    unsafeFromRight :: Either String a -> a
unsafeFromRight = (String -> a) -> (a -> a) -> Either String a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> a
forall a. HasCallStack => String -> a
error a -> a
forall a. a -> a
id

    -- This is the algorithm described in SLIP 0010 for master key generation
    -- with an extra step to discard _some_ of the potential private keys. Why
    -- this extra step remains a mystery as of today.
    --
    --      1. Generate a seed byte sequence S of 512 bits according to BIP-0039.
    --         (done in a previous step, passed as argument).
    --
    --      2. Calculate I = HMAC-SHA512(Key = "ed25519 seed", Data = S)
    --
    --      3. Split I into two 32-byte sequences, IL and IR.
    --
    -- extra *******************************************************************
    -- *                                                                       *
    -- *    3.5 If the third highest bit of the last byte of IL is not zero    *
    -- *        S = I and go back to step 2.                                   *
    -- *                                                                       *
    -- *************************************************************************
    --
    --      4. Use parse256(IL) as master secret key, and IR as master chain code.
    hashRepeatedly :: ByteString -> (ByteString, ByteString)
    hashRepeatedly :: ByteString -> (ByteString, ByteString)
hashRepeatedly ByteString
bytes = case Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 (ByteString -> ByteString
hmacSha512 ByteString
bytes) of
        (ByteString
iL, ByteString
iR) | ByteString -> Bool
isInvalidKey ByteString
iL -> ByteString -> (ByteString, ByteString)
hashRepeatedly (ByteString
iL ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
iR)
        (ByteString
iL, ByteString
iR) -> (ByteString
iL, ByteString
iR)
      where
        isInvalidKey :: ByteString -> Bool
isInvalidKey ByteString
k = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (ByteString
k ByteString -> Int -> Word8
`BS.index` Int
31) Int
5

    -- - Clear the lowest 3 bits of the first byte
    -- - Clear the highest bit of the last byte
    -- - Set the second highest bit of the last byte
    --
    -- As described in [RFC 8032 - 5.1.5](https://tools.ietf.org/html/rfc8032#section-5.1.5)
    pruneBuffer :: ByteString -> ByteString
    pruneBuffer :: ByteString -> ByteString
pruneBuffer ByteString
bytes =
        let
            (Word8
firstByte, ByteString
rest) = (Word8, ByteString)
-> Maybe (Word8, ByteString) -> (Word8, ByteString)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Word8, ByteString)
forall a. HasCallStack => String -> a
error String
"pruneBuffer: no first byte") (Maybe (Word8, ByteString) -> (Word8, ByteString))
-> Maybe (Word8, ByteString) -> (Word8, ByteString)
forall a b. (a -> b) -> a -> b
$
                ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bytes

            (ByteString
rest', Word8
lastByte) = (ByteString, Word8)
-> Maybe (ByteString, Word8) -> (ByteString, Word8)
forall a. a -> Maybe a -> a
fromMaybe (String -> (ByteString, Word8)
forall a. HasCallStack => String -> a
error String
"pruneBuffer: no last byte") (Maybe (ByteString, Word8) -> (ByteString, Word8))
-> Maybe (ByteString, Word8) -> (ByteString, Word8)
forall a b. (a -> b) -> a -> b
$
                ByteString -> Maybe (ByteString, Word8)
BS.unsnoc ByteString
rest

            firstPruned :: Word8
firstPruned = Word8
firstByte
                Word8 -> (Word8 -> Word8) -> Word8
forall a b. a -> (a -> b) -> b
& (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
0)
                Word8 -> (Word8 -> Word8) -> Word8
forall a b. a -> (a -> b) -> b
& (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
1)
                Word8 -> (Word8 -> Word8) -> Word8
forall a b. a -> (a -> b) -> b
& (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
2)

            lastPruned :: Word8
lastPruned = Word8
lastByte
                Word8 -> (Word8 -> Word8) -> Word8
forall a b. a -> (a -> b) -> b
& (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
6)
                Word8 -> (Word8 -> Word8) -> Word8
forall a b. a -> (a -> b) -> b
& (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
7)
        in
            (Word8
firstPruned Word8 -> ByteString -> ByteString
`BS.cons` ByteString -> Word8 -> ByteString
BS.snoc ByteString
rest' Word8
lastPruned)

    ed25519ScalarMult :: ByteString -> Either String ByteString
    ed25519ScalarMult :: ByteString -> Either String ByteString
ed25519ScalarMult ByteString
bytes = do
        Scalar
scalar <- (CryptoError -> String)
-> Either CryptoError Scalar -> Either String Scalar
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left CryptoError -> String
forall a. Show a => a -> String
show (Either CryptoError Scalar -> Either String Scalar)
-> Either CryptoError Scalar -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ CryptoFailable Scalar -> Either CryptoError Scalar
forall a. CryptoFailable a -> Either CryptoError a
eitherCryptoError (CryptoFailable Scalar -> Either CryptoError Scalar)
-> CryptoFailable Scalar -> Either CryptoError Scalar
forall a b. (a -> b) -> a -> b
$ ByteString -> CryptoFailable Scalar
forall bs. ByteArrayAccess bs => bs -> CryptoFailable Scalar
Ed25519.scalarDecodeLong ByteString
bytes
        ByteString -> Either String ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Point -> ByteString
forall bs. ByteArray bs => Point -> bs
Ed25519.pointEncode (Point -> ByteString) -> Point -> ByteString
forall a b. (a -> b) -> a -> b
$ Scalar -> Point
Ed25519.toPoint Scalar
scalar

    -- As described in [BIP 0039 - From Mnemonic to Seed](https://github.com/bitcoin/bips/blob/master/bip-0039.mediawiki#from-mnemonic-to-seed)
    pbkdf2HmacSha512 :: ByteString -> ByteString
    pbkdf2HmacSha512 :: ByteString -> ByteString
pbkdf2HmacSha512 ByteString
bytes = PRF ByteString
-> Parameters -> ByteString -> ByteString -> ByteString
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
2048 Int
64)
        ByteString
bytes
        (ByteString
"mnemonic" :: ByteString)

    hmacSha256 :: ByteString -> ByteString
    hmacSha256 :: ByteString -> ByteString
hmacSha256 =
        forall bout.
(ByteArrayAccess (HMAC SHA256), ByteArray bout) =>
HMAC SHA256 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert @(HMAC SHA256) (HMAC SHA256 -> ByteString)
-> (ByteString -> HMAC SHA256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac ByteString
salt

    -- As described in [SLIP 0010 - Master Key Generation](https://github.com/satoshilabs/slips/blob/master/slip-0010.md#master-key-generation)
    hmacSha512 :: ByteString -> ByteString
    hmacSha512 :: ByteString -> ByteString
hmacSha512 =
        forall bout.
(ByteArrayAccess (HMAC SHA512), ByteArray bout) =>
HMAC SHA512 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert @(HMAC SHA512) (HMAC SHA512 -> ByteString)
-> (ByteString -> HMAC SHA512) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> HMAC SHA512
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac ByteString
salt

    salt :: ByteString
    salt :: ByteString
salt = ByteString
"ed25519 seed"

-- | 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
    :: SomeMnemonic
        -- ^ The root mnemonic
    -> Passphrase "encryption"
        -- ^ Master encryption passphrase
    -> IcarusKey depth XPrv
unsafeGenerateKeyFromSeed :: SomeMnemonic -> Passphrase "encryption" -> IcarusKey depth XPrv
unsafeGenerateKeyFromSeed (SomeMnemonic Mnemonic mw
mw) (Passphrase ScrubbedBytes
pwd) =
    let
        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)
    in XPrv -> IcarusKey depth XPrv
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey (XPrv -> IcarusKey depth XPrv) -> XPrv -> IcarusKey depth XPrv
forall a b. (a -> b) -> a -> b
$ ScrubbedBytes -> ByteString -> ScrubbedBytes -> XPrv
forall keyPassPhrase generationPassPhrase seed.
(ByteArrayAccess keyPassPhrase,
 ByteArrayAccess generationPassPhrase, ByteArrayAccess seed) =>
seed -> generationPassPhrase -> keyPassPhrase -> XPrv
generateNew ScrubbedBytes
seed' (ByteString
forall a. Monoid a => a
mempty :: ByteString) ScrubbedBytes
pwd

{-------------------------------------------------------------------------------
                          Hard / Soft Key Derivation
-------------------------------------------------------------------------------}

instance HardDerivation IcarusKey where
    type AddressIndexDerivationType IcarusKey = 'Soft

    deriveAccountPrivateKey :: Passphrase "encryption"
-> IcarusKey 'RootK XPrv
-> Index 'Hardened 'AccountK
-> IcarusKey 'AccountK XPrv
deriveAccountPrivateKey
            (Passphrase ScrubbedBytes
pwd) (IcarusKey XPrv
rootXPrv) (Index Word32
accIx) =
        let
            purposeXPrv :: XPrv
purposeXPrv = -- lvl1 derivation; hardened derivation of purpose'
                DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 ScrubbedBytes
pwd XPrv
rootXPrv (Index 'Hardened 'PurposeK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'PurposeK
purposeBIP44)
            coinTypeXPrv :: XPrv
coinTypeXPrv = -- lvl2 derivation; hardened derivation of coin_type'
                DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 ScrubbedBytes
pwd XPrv
purposeXPrv (Index 'Hardened 'CoinTypeK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'CoinTypeK
coinTypeAda)
            acctXPrv :: XPrv
acctXPrv = -- lvl3 derivation; hardened derivation of account' index
                DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 ScrubbedBytes
pwd XPrv
coinTypeXPrv Word32
accIx
        in
            XPrv -> IcarusKey 'AccountK XPrv
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey XPrv
acctXPrv

    deriveAddressPrivateKey :: Passphrase "encryption"
-> IcarusKey 'AccountK XPrv
-> Role
-> Index (AddressIndexDerivationType IcarusKey) 'AddressK
-> IcarusKey 'AddressK XPrv
deriveAddressPrivateKey
            (Passphrase ScrubbedBytes
pwd) (IcarusKey XPrv
accXPrv) Role
role (Index Word32
addrIx) =
        let
            changeCode :: Word32
changeCode =
                Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Role -> Int
forall a. Enum a => a -> Int
fromEnum Role
role
            changeXPrv :: XPrv
changeXPrv = -- lvl4 derivation; soft derivation of change chain
                DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 ScrubbedBytes
pwd XPrv
accXPrv Word32
changeCode
            addrXPrv :: XPrv
addrXPrv = -- lvl5 derivation; soft derivation of address index
                DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 ScrubbedBytes
pwd XPrv
changeXPrv Word32
addrIx
        in
            XPrv -> IcarusKey 'AddressK XPrv
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey XPrv
addrXPrv

instance SoftDerivation IcarusKey where
    deriveAddressPublicKey :: IcarusKey 'AccountK XPub
-> Role -> Index 'Soft 'AddressK -> IcarusKey 'AddressK XPub
deriveAddressPublicKey (IcarusKey XPub
accXPub) Role
role (Index Word32
addrIx) =
        IcarusKey 'AddressK XPub
-> Maybe (IcarusKey 'AddressK XPub) -> IcarusKey 'AddressK XPub
forall a. a -> Maybe a -> a
fromMaybe IcarusKey 'AddressK XPub
errWrongIndex (Maybe (IcarusKey 'AddressK XPub) -> IcarusKey 'AddressK XPub)
-> Maybe (IcarusKey 'AddressK XPub) -> IcarusKey 'AddressK XPub
forall a b. (a -> b) -> a -> b
$ do
            let changeCode :: Word32
changeCode = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Role -> Int
forall a. Enum a => a -> Int
fromEnum Role
role
            XPub
changeXPub <- -- lvl4 derivation in bip44 is derivation of change chain
                DerivationScheme -> XPub -> Word32 -> Maybe XPub
deriveXPub DerivationScheme
DerivationScheme2 XPub
accXPub Word32
changeCode
            XPub
addrXPub <- -- lvl5 derivation in bip44 is derivation of address chain
                DerivationScheme -> XPub -> Word32 -> Maybe XPub
deriveXPub DerivationScheme
DerivationScheme2 XPub
changeXPub Word32
addrIx
            IcarusKey 'AddressK XPub -> Maybe (IcarusKey 'AddressK XPub)
forall (m :: * -> *) a. Monad m => a -> m a
return (IcarusKey 'AddressK XPub -> Maybe (IcarusKey 'AddressK XPub))
-> IcarusKey 'AddressK XPub -> Maybe (IcarusKey 'AddressK XPub)
forall a b. (a -> b) -> a -> b
$ XPub -> IcarusKey 'AddressK XPub
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey XPub
addrXPub
      where
        errWrongIndex :: IcarusKey 'AddressK XPub
errWrongIndex = String -> IcarusKey 'AddressK XPub
forall a. HasCallStack => String -> a
error (String -> IcarusKey 'AddressK XPub)
-> String -> IcarusKey 'AddressK XPub
forall a b. (a -> b) -> a -> b
$
            String
"deriveAddressPublicKey failed: was given an hardened (or too big) \
            \index for soft path derivation ( " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
addrIx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"). This is \
            \either a programmer error, or, we may have reached the maximum \
            \number of addresses for a given wallet."

{-------------------------------------------------------------------------------
                            WalletKey implementation
-------------------------------------------------------------------------------}

instance WalletKey IcarusKey where
    keyTypeDescriptor :: Proxy IcarusKey -> String
keyTypeDescriptor Proxy IcarusKey
_ = String
"ica"

    changePassphrase :: (PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user")
-> IcarusKey depth XPrv
-> IcarusKey depth XPrv
changePassphrase (PassphraseScheme, Passphrase "user")
old (PassphraseScheme, Passphrase "user")
new (IcarusKey XPrv
prv) =
        XPrv -> IcarusKey depth XPrv
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey (XPrv -> IcarusKey depth XPrv) -> XPrv -> IcarusKey depth XPrv
forall a b. (a -> b) -> a -> b
$ (PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user") -> XPrv -> XPrv
changePassphraseXPrv (PassphraseScheme, Passphrase "user")
old (PassphraseScheme, Passphrase "user")
new XPrv
prv

    publicKey :: IcarusKey depth XPrv -> IcarusKey depth XPub
publicKey (IcarusKey XPrv
prv) =
        XPub -> IcarusKey depth XPub
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey (HasCallStack => XPrv -> XPub
XPrv -> XPub
toXPub XPrv
prv)

    digest :: IcarusKey depth XPub -> Digest a
digest (IcarusKey XPub
prv) =
        ByteString -> Digest a
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash (XPub -> ByteString
unXPub XPub
prv)

    getRawKey :: IcarusKey depth raw -> raw
getRawKey =
        IcarusKey depth raw -> raw
forall (depth :: Depth) raw. IcarusKey depth raw -> raw
getKey

    liftRawKey :: raw -> IcarusKey depth raw
liftRawKey =
        raw -> IcarusKey depth raw
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey

{-------------------------------------------------------------------------------
                         Relationship Key / Address
-------------------------------------------------------------------------------}

instance GetPurpose IcarusKey where
    getPurpose :: Index 'Hardened 'PurposeK
getPurpose = Index 'Hardened 'PurposeK
purposeBIP44

instance PaymentAddress 'Mainnet IcarusKey where
    paymentAddress :: IcarusKey 'AddressK XPub -> Address
paymentAddress IcarusKey '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 (IcarusKey 'AddressK XPub -> XPub
forall (depth :: Depth) raw. IcarusKey depth raw -> raw
getKey IcarusKey 'AddressK XPub
k) []
    liftPaymentAddress :: KeyFingerprint "payment" IcarusKey -> Address
liftPaymentAddress (KeyFingerprint ByteString
bytes) =
        ByteString -> Address
Address ByteString
bytes

instance KnownNat pm => PaymentAddress ('Testnet pm) IcarusKey where
    paymentAddress :: IcarusKey 'AddressK XPub -> Address
paymentAddress IcarusKey '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 (IcarusKey 'AddressK XPub -> XPub
forall (depth :: Depth) raw. IcarusKey depth raw -> raw
getKey IcarusKey 'AddressK XPub
k)
            [ ProtocolMagic -> Encoding
CBOR.encodeProtocolMagicAttr (KnownNat pm => ProtocolMagic
forall (pm :: Nat). KnownNat pm => ProtocolMagic
testnetMagic @pm)
            ]
    liftPaymentAddress :: KeyFingerprint "payment" IcarusKey -> Address
liftPaymentAddress (KeyFingerprint ByteString
bytes) =
        ByteString -> Address
Address ByteString
bytes

instance MkKeyFingerprint IcarusKey Address where
    paymentKeyFingerprint :: Address
-> Either
     (ErrMkKeyFingerprint IcarusKey Address)
     (KeyFingerprint "payment" IcarusKey)
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" IcarusKey
-> Either
     (ErrMkKeyFingerprint IcarusKey Address)
     (KeyFingerprint "payment" IcarusKey)
forall a b. b -> Either a b
Right (KeyFingerprint "payment" IcarusKey
 -> Either
      (ErrMkKeyFingerprint IcarusKey Address)
      (KeyFingerprint "payment" IcarusKey))
-> KeyFingerprint "payment" IcarusKey
-> Either
     (ErrMkKeyFingerprint IcarusKey Address)
     (KeyFingerprint "payment" IcarusKey)
forall a b. (a -> b) -> a -> b
$ ByteString -> KeyFingerprint "payment" IcarusKey
forall k (s :: Symbol) (key :: k).
ByteString -> KeyFingerprint s key
KeyFingerprint ByteString
bytes
            Maybe ByteString
Nothing -> ErrMkKeyFingerprint IcarusKey Address
-> Either
     (ErrMkKeyFingerprint IcarusKey Address)
     (KeyFingerprint "payment" IcarusKey)
forall a b. a -> Either a b
Left (ErrMkKeyFingerprint IcarusKey Address
 -> Either
      (ErrMkKeyFingerprint IcarusKey Address)
      (KeyFingerprint "payment" IcarusKey))
-> ErrMkKeyFingerprint IcarusKey Address
-> Either
     (ErrMkKeyFingerprint IcarusKey Address)
     (KeyFingerprint "payment" IcarusKey)
forall a b. (a -> b) -> a -> b
$ Address -> Proxy IcarusKey -> ErrMkKeyFingerprint IcarusKey Address
forall k (key :: k) from.
from -> Proxy key -> ErrMkKeyFingerprint key from
ErrInvalidAddress Address
addr (Proxy IcarusKey
forall k (t :: k). Proxy t
Proxy @IcarusKey)

instance PaymentAddress n IcarusKey
    => MkKeyFingerprint IcarusKey (Proxy (n :: NetworkDiscriminant), IcarusKey 'AddressK XPub)
  where
    paymentKeyFingerprint :: (Proxy n, IcarusKey 'AddressK XPub)
-> Either
     (ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub))
     (KeyFingerprint "payment" IcarusKey)
paymentKeyFingerprint (Proxy n
proxy, IcarusKey 'AddressK XPub
k) =
        (ErrMkKeyFingerprint IcarusKey Address
 -> ErrMkKeyFingerprint
      IcarusKey (Proxy n, IcarusKey 'AddressK XPub))
-> (KeyFingerprint "payment" IcarusKey
    -> KeyFingerprint "payment" IcarusKey)
-> Either
     (ErrMkKeyFingerprint IcarusKey Address)
     (KeyFingerprint "payment" IcarusKey)
-> Either
     (ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub))
     (KeyFingerprint "payment" IcarusKey)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub)
-> ErrMkKeyFingerprint IcarusKey Address
-> ErrMkKeyFingerprint
     IcarusKey (Proxy n, IcarusKey 'AddressK XPub)
forall a b. a -> b -> a
const ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub)
err) KeyFingerprint "payment" IcarusKey
-> KeyFingerprint "payment" IcarusKey
coerce
        (Either
   (ErrMkKeyFingerprint IcarusKey Address)
   (KeyFingerprint "payment" IcarusKey)
 -> Either
      (ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub))
      (KeyFingerprint "payment" IcarusKey))
-> (IcarusKey 'AddressK XPub
    -> Either
         (ErrMkKeyFingerprint IcarusKey Address)
         (KeyFingerprint "payment" IcarusKey))
-> IcarusKey 'AddressK XPub
-> Either
     (ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub))
     (KeyFingerprint "payment" IcarusKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall from.
MkKeyFingerprint IcarusKey from =>
from
-> Either
     (ErrMkKeyFingerprint IcarusKey from)
     (KeyFingerprint "payment" IcarusKey)
forall (key :: Depth -> * -> *) from.
MkKeyFingerprint key from =>
from
-> Either
     (ErrMkKeyFingerprint key from) (KeyFingerprint "payment" key)
paymentKeyFingerprint @IcarusKey
        (Address
 -> Either
      (ErrMkKeyFingerprint IcarusKey Address)
      (KeyFingerprint "payment" IcarusKey))
-> (IcarusKey 'AddressK XPub -> Address)
-> IcarusKey 'AddressK XPub
-> Either
     (ErrMkKeyFingerprint IcarusKey Address)
     (KeyFingerprint "payment" IcarusKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (network :: NetworkDiscriminant) (key :: Depth -> * -> *).
PaymentAddress network key =>
key 'AddressK XPub -> Address
forall (key :: Depth -> * -> *).
PaymentAddress n key =>
key 'AddressK XPub -> Address
paymentAddress @n
        (IcarusKey 'AddressK XPub
 -> Either
      (ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub))
      (KeyFingerprint "payment" IcarusKey))
-> IcarusKey 'AddressK XPub
-> Either
     (ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub))
     (KeyFingerprint "payment" IcarusKey)
forall a b. (a -> b) -> a -> b
$ IcarusKey 'AddressK XPub
k
      where
        err :: ErrMkKeyFingerprint IcarusKey (Proxy n, IcarusKey 'AddressK XPub)
err = (Proxy n, IcarusKey 'AddressK XPub)
-> Proxy IcarusKey
-> ErrMkKeyFingerprint
     IcarusKey (Proxy n, IcarusKey 'AddressK XPub)
forall k (key :: k) from.
from -> Proxy key -> ErrMkKeyFingerprint key from
ErrInvalidAddress (Proxy n
proxy, IcarusKey 'AddressK XPub
k) Proxy IcarusKey
forall k (t :: k). Proxy t
Proxy

instance IsOurs (SeqState n IcarusKey) RewardAccount where
    isOurs :: RewardAccount
-> SeqState n IcarusKey
-> (Maybe (NonEmpty DerivationIndex), SeqState n IcarusKey)
isOurs RewardAccount
_account SeqState n IcarusKey
state = (Maybe (NonEmpty DerivationIndex)
forall a. Maybe a
Nothing, SeqState n IcarusKey
state)

instance PaymentAddress n IcarusKey => MaybeLight (SeqState n IcarusKey) where
    maybeDiscover :: Maybe (LightDiscoverTxs (SeqState n IcarusKey))
maybeDiscover = LightDiscoverTxs (SeqState n IcarusKey)
-> Maybe (LightDiscoverTxs (SeqState n IcarusKey))
forall a. a -> Maybe a
Just (LightDiscoverTxs (SeqState n IcarusKey)
 -> Maybe (LightDiscoverTxs (SeqState n IcarusKey)))
-> LightDiscoverTxs (SeqState n IcarusKey)
-> Maybe (LightDiscoverTxs (SeqState n IcarusKey))
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *).
 Monad m =>
 (Either Address RewardAccount -> m ChainEvents)
 -> SeqState n IcarusKey -> m (ChainEvents, SeqState n IcarusKey))
-> LightDiscoverTxs (SeqState n IcarusKey)
forall addr txs s.
(forall (m :: * -> *).
 Monad m =>
 (addr -> m txs) -> s -> m (txs, s))
-> DiscoverTxs addr txs s
DiscoverTxs forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *)
       (m :: * -> *).
(PaymentAddress n k, Monad m) =>
(Either Address RewardAccount -> m ChainEvents)
-> SeqState n k -> m (ChainEvents, SeqState n k)
forall (m :: * -> *).
Monad m =>
(Either Address RewardAccount -> m ChainEvents)
-> SeqState n IcarusKey -> m (ChainEvents, SeqState n IcarusKey)
discoverSeq

instance BoundedAddressLength IcarusKey where
    -- Matching 'paymentAddress' above.
    maxLengthAddressFor :: Proxy IcarusKey -> Address
maxLengthAddressFor Proxy IcarusKey
_ = 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
            [ ProtocolMagic -> Encoding
CBOR.encodeProtocolMagicAttr (Int32 -> ProtocolMagic
ProtocolMagic Int32
forall a. Bounded a => a
maxBound)
            ]
      where
        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

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

instance PersistPrivateKey (IcarusKey 'RootK) where
    serializeXPrv :: (IcarusKey 'RootK XPrv, PassphraseHash) -> (ByteString, ByteString)
serializeXPrv (IcarusKey 'RootK XPrv
k, PassphraseHash
h) =
        ( ByteString -> ByteString
forall bin. ByteArrayAccess bin => bin -> ByteString
hex (ByteString -> ByteString)
-> (IcarusKey 'RootK XPrv -> ByteString)
-> IcarusKey 'RootK XPrv
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPrv -> ByteString
unXPrv (XPrv -> ByteString)
-> (IcarusKey 'RootK XPrv -> XPrv)
-> IcarusKey 'RootK XPrv
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IcarusKey 'RootK XPrv -> XPrv
forall (depth :: Depth) raw. IcarusKey depth raw -> raw
getKey (IcarusKey 'RootK XPrv -> ByteString)
-> IcarusKey 'RootK XPrv -> ByteString
forall a b. (a -> b) -> a -> b
$ IcarusKey 'RootK XPrv
k
        , ScrubbedBytes -> ByteString
forall bin. ByteArrayAccess bin => bin -> 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) -> (IcarusKey 'RootK XPrv, PassphraseHash)
unsafeDeserializeXPrv (ByteString
k, ByteString
h) = (String -> (IcarusKey 'RootK XPrv, PassphraseHash))
-> ((IcarusKey 'RootK XPrv, PassphraseHash)
    -> (IcarusKey 'RootK XPrv, PassphraseHash))
-> Either String (IcarusKey 'RootK XPrv, PassphraseHash)
-> (IcarusKey 'RootK XPrv, PassphraseHash)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> (IcarusKey 'RootK XPrv, PassphraseHash)
forall p a. p -> a
err (IcarusKey 'RootK XPrv, PassphraseHash)
-> (IcarusKey 'RootK XPrv, PassphraseHash)
forall a. a -> a
id (Either String (IcarusKey 'RootK XPrv, PassphraseHash)
 -> (IcarusKey 'RootK XPrv, PassphraseHash))
-> Either String (IcarusKey 'RootK XPrv, PassphraseHash)
-> (IcarusKey 'RootK XPrv, PassphraseHash)
forall a b. (a -> b) -> a -> b
$ (,)
        (IcarusKey 'RootK XPrv
 -> PassphraseHash -> (IcarusKey 'RootK XPrv, PassphraseHash))
-> Either String (IcarusKey 'RootK XPrv)
-> Either
     String (PassphraseHash -> (IcarusKey 'RootK XPrv, PassphraseHash))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XPrv -> IcarusKey 'RootK XPrv)
-> Either String XPrv -> Either String (IcarusKey 'RootK XPrv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap XPrv -> IcarusKey 'RootK XPrv
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey (ByteString -> Either String XPrv
xprvFromText ByteString
k)
        Either
  String (PassphraseHash -> (IcarusKey 'RootK XPrv, PassphraseHash))
-> Either String PassphraseHash
-> Either String (IcarusKey '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
        xprvFromText :: ByteString -> Either String XPrv
xprvFromText = ByteString -> Either String XPrv
forall bin. ByteArrayAccess bin => bin -> Either String XPrv
xprv (ByteString -> Either String XPrv)
-> (ByteString -> Either String ByteString)
-> ByteString
-> Either String XPrv
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteArray ByteString => ByteString -> Either String ByteString
forall bout. ByteArray bout => ByteString -> Either String bout
fromHex @ByteString
        err :: p -> a
err p
_ = String -> a
forall a. HasCallStack => String -> a
error String
"unsafeDeserializeXPrv: unable to deserialize IcarusKey"

instance PersistPublicKey (IcarusKey depth) where
    serializeXPub :: IcarusKey depth XPub -> ByteString
serializeXPub =
        ByteString -> ByteString
forall bin. ByteArrayAccess bin => bin -> ByteString
hex (ByteString -> ByteString)
-> (IcarusKey depth XPub -> ByteString)
-> IcarusKey depth XPub
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPub -> ByteString
unXPub (XPub -> ByteString)
-> (IcarusKey depth XPub -> XPub)
-> IcarusKey depth XPub
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IcarusKey depth XPub -> XPub
forall (depth :: Depth) raw. IcarusKey depth raw -> raw
getKey

    unsafeDeserializeXPub :: ByteString -> IcarusKey depth XPub
unsafeDeserializeXPub =
        (String -> IcarusKey depth XPub)
-> (XPub -> IcarusKey depth XPub)
-> Either String XPub
-> IcarusKey depth XPub
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IcarusKey depth XPub
forall p a. p -> a
err XPub -> IcarusKey depth XPub
forall (depth :: Depth) key. key -> IcarusKey depth key
IcarusKey (Either String XPub -> IcarusKey depth XPub)
-> (ByteString -> Either String XPub)
-> ByteString
-> IcarusKey depth XPub
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String XPub
xpubFromText
      where
        xpubFromText :: ByteString -> Either String XPub
xpubFromText = ByteString -> Either String XPub
CC.xpub (ByteString -> Either String XPub)
-> (ByteString -> Either String ByteString)
-> ByteString
-> Either String XPub
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteArray ByteString => ByteString -> Either String ByteString
forall bout. ByteArray bout => ByteString -> Either String bout
fromHex @ByteString
        err :: p -> a
err p
_ = String -> a
forall a. HasCallStack => String -> a
error String
"unsafeDeserializeXPub: unable to deserialize IcarusKey"