{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_HADDOCK prune #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0

module Cardano.Address.Style.Icarus
    ( -- $overview

      -- * Icarus
      Icarus
    , getKey
    , Role (..)
    , roleFromIndex
    , roleToIndex

      -- * Key Derivation
      -- $keyDerivation
    , genMasterKeyFromXPrv
    , genMasterKeyFromMnemonic
    , deriveAccountPrivateKey
    , deriveAddressPrivateKey
    , deriveAddressPublicKey

      -- * Addresses
      -- $addresses
    , AddressInfo (..)
    , eitherInspectAddress
    , inspectAddress
    , inspectIcarusAddress
    , paymentAddress
    , ErrInspectAddress
    , prettyErrInspectAddress

      -- * Network Discrimination
    , icarusMainnet
    , icarusStaging
    , icarusTestnet

      -- * Unsafe
    , liftXPrv
    , liftXPub

      -- Internals
    , unsafeGenerateKeyFromHardwareLedger
    , minSeedLengthBytes
    ) where

import Prelude

import Cardano.Address
    ( Address
    , AddressDiscrimination (..)
    , NetworkDiscriminant (..)
    , NetworkTag (..)
    , unAddress
    , unsafeMkAddress
    )
import Cardano.Address.Derivation
    ( Depth (..)
    , DerivationScheme (..)
    , DerivationType (..)
    , Index (..)
    , XPrv
    , XPub
    , deriveXPrv
    , deriveXPub
    , generateNew
    , indexFromWord32
    , unsafeMkIndex
    , xprvFromBytes
    )
import Cardano.Address.Internal
    ( DeserialiseFailure, WithErrorMessage (..) )
import Cardano.Address.Style.Byron
    ( byronMainnet, byronStaging, byronTestnet )
import Cardano.Mnemonic
    ( SomeMnemonic (..), entropyToBytes, mnemonicToEntropy, mnemonicToText )
import Codec.Binary.Encoding
    ( AbstractEncoding (..), encode )
import Control.DeepSeq
    ( NFData )
import Control.Exception
    ( Exception, displayException )
import Control.Exception.Base
    ( assert )
import Control.Monad.Catch
    ( MonadThrow, throwM )
import Crypto.Hash.Algorithms
    ( SHA256 (..), SHA512 (..) )
import Crypto.MAC.HMAC
    ( HMAC, hmac )
import Data.Aeson
    ( ToJSON (..), (.=) )
import Data.Bifunctor
    ( bimap, first )
import Data.Bits
    ( clearBit, setBit, testBit )
import Data.ByteArray
    ( ScrubbedBytes )
import Data.ByteString
    ( ByteString )
import Data.Function
    ( (&) )
import Data.Maybe
    ( fromMaybe )
import Data.Typeable
    ( Typeable )
import Data.Word
    ( Word32, Word8 )
import Fmt
    ( format )
import GHC.Generics
    ( Generic )

import qualified Cardano.Address as Internal
import qualified Cardano.Address.Derivation as Internal
import qualified Cardano.Codec.Cbor as CBOR
import qualified Codec.CBOR.Decoding as CBOR
import qualified Crypto.KDF.PBKDF2 as PBKDF2
import qualified Data.Aeson as Json
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

-- $overview
--
-- This module provides an implementation of:
--
-- - 'Cardano.Address.Derivation.GenMasterKey': for generating Icarus master keys from mnemonic sentences
-- - 'Cardano.Address.Derivation.HardDerivation': for hierarchical hard derivation of parent to child keys
-- - 'Cardano.Address.Derivation.SoftDerivation': for hierarchical soft derivation of parent to child keys
-- - 'Cardano.Address.PaymentAddress': for constructing addresses from a public key
--
-- We call 'Icarus' addresses the new format of Cardano addresses which came
-- after 'Cardano.Address.Style.Byron.Byron'. This is the format initially used in /Yoroi/
-- and now also used by /Daedalus/.

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

deriving instance (Functor (Icarus depth))
instance (NFData key) => NFData (Icarus depth key)

data Role
    = UTxOExternal
    | UTxOInternal
    deriving ((forall x. Role -> Rep Role x)
-> (forall x. Rep Role x -> Role) -> Generic Role
forall x. Rep Role x -> Role
forall x. Role -> Rep Role x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Role x -> Role
$cfrom :: forall x. Role -> Rep Role x
Generic, Typeable, Int -> Role -> ShowS
[Role] -> ShowS
Role -> String
(Int -> Role -> ShowS)
-> (Role -> String) -> ([Role] -> ShowS) -> Show Role
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Role] -> ShowS
$cshowList :: [Role] -> ShowS
show :: Role -> String
$cshow :: Role -> String
showsPrec :: Int -> Role -> ShowS
$cshowsPrec :: Int -> Role -> ShowS
Show, Role -> Role -> Bool
(Role -> Role -> Bool) -> (Role -> Role -> Bool) -> Eq Role
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Role -> Role -> Bool
$c/= :: Role -> Role -> Bool
== :: Role -> Role -> Bool
$c== :: Role -> Role -> Bool
Eq, Eq Role
Eq Role
-> (Role -> Role -> Ordering)
-> (Role -> Role -> Bool)
-> (Role -> Role -> Bool)
-> (Role -> Role -> Bool)
-> (Role -> Role -> Bool)
-> (Role -> Role -> Role)
-> (Role -> Role -> Role)
-> Ord Role
Role -> Role -> Bool
Role -> Role -> Ordering
Role -> Role -> Role
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Role -> Role -> Role
$cmin :: Role -> Role -> Role
max :: Role -> Role -> Role
$cmax :: Role -> Role -> Role
>= :: Role -> Role -> Bool
$c>= :: Role -> Role -> Bool
> :: Role -> Role -> Bool
$c> :: Role -> Role -> Bool
<= :: Role -> Role -> Bool
$c<= :: Role -> Role -> Bool
< :: Role -> Role -> Bool
$c< :: Role -> Role -> Bool
compare :: Role -> Role -> Ordering
$ccompare :: Role -> Role -> Ordering
$cp1Ord :: Eq Role
Ord, Role
Role -> Role -> Bounded Role
forall a. a -> a -> Bounded a
maxBound :: Role
$cmaxBound :: Role
minBound :: Role
$cminBound :: Role
Bounded)

instance NFData Role

roleFromIndex :: Index 'Soft depth -> Maybe Role
roleFromIndex :: Index 'Soft depth -> Maybe Role
roleFromIndex Index 'Soft depth
ix = case Index 'Soft depth -> Word32
forall (derivationType :: DerivationType) (depth :: Depth).
Index derivationType depth -> Word32
indexToWord32 Index 'Soft depth
ix of
    Word32
0 -> Role -> Maybe Role
forall a. a -> Maybe a
Just Role
UTxOExternal
    Word32
1 -> Role -> Maybe Role
forall a. a -> Maybe a
Just Role
UTxOInternal
    Word32
_ -> Maybe Role
forall a. Maybe a
Nothing

roleToIndex :: Role -> Index 'Soft depth
roleToIndex :: Role -> Index 'Soft depth
roleToIndex = Word32 -> Index 'Soft depth
forall (ty :: DerivationType) (depth :: Depth).
Word32 -> Index ty depth
unsafeMkIndex (Word32 -> Index 'Soft depth)
-> (Role -> Word32) -> Role -> Index 'Soft depth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Role
UTxOExternal -> Word32
0
    Role
UTxOInternal -> Word32
1

--
-- Key Derivation
--
-- $keyDerivation
--
-- === Generating a root key from 'SomeMnemonic'
-- > :set -XOverloadedStrings
-- > :set -XTypeApplications
-- > :set -XDataKinds
-- > import Cardano.Mnemonic ( mkSomeMnemonic )
-- >
-- > let (Right mw) = mkSomeMnemonic @'[15] ["network","empty","cause","mean","expire","private","finger","accident","session","problem","absurd","banner","stage","void","what"]
-- > let sndFactor = mempty -- Or alternatively, a second factor mnemonic transformed to bytes via someMnemonicToBytes
-- > let rootK = genMasterKeyFromMnemonic mw sndFactor :: Icarus 'RootK XPrv
--
-- === Deriving child keys
--
-- Let's consider the following 3rd, 4th and 5th derivation paths @0'\/0\/14@
--
-- > let Just accIx = indexFromWord32 0x80000000
-- > let acctK = deriveAccountPrivateKey rootK accIx
-- >
-- > let Just addIx = indexFromWord32 0x00000014
-- > let addrK = deriveAddressPrivateKey acctK UTxOExternal addIx

instance Internal.GenMasterKey Icarus where
    type SecondFactor Icarus = ScrubbedBytes

    genMasterKeyFromXPrv :: XPrv -> Icarus 'RootK XPrv
genMasterKeyFromXPrv = XPrv -> Icarus 'RootK XPrv
forall (depth :: Depth). XPrv -> Icarus depth XPrv
liftXPrv
    genMasterKeyFromMnemonic :: SomeMnemonic -> SecondFactor Icarus -> Icarus 'RootK XPrv
genMasterKeyFromMnemonic (SomeMnemonic Mnemonic mw
mw) SecondFactor Icarus
sndFactor =
        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
            seedValidated :: ScrubbedBytes
seedValidated = Bool -> ScrubbedBytes -> ScrubbedBytes
forall a. (?callStack::CallStack) => Bool -> a -> a
assert
                (ScrubbedBytes -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length ScrubbedBytes
seed 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
seed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255)
                ScrubbedBytes
seed
        in XPrv -> Icarus 'RootK XPrv
forall (depth :: Depth) key. key -> Icarus depth key
Icarus (XPrv -> Icarus 'RootK XPrv) -> XPrv -> Icarus 'RootK XPrv
forall a b. (a -> b) -> a -> b
$ ScrubbedBytes -> ScrubbedBytes -> XPrv
forall seed sndFactor.
(ByteArrayAccess seed, ByteArrayAccess sndFactor) =>
seed -> sndFactor -> XPrv
generateNew ScrubbedBytes
seedValidated ScrubbedBytes
SecondFactor Icarus
sndFactor

instance Internal.HardDerivation Icarus where
    type AccountIndexDerivationType Icarus = 'Hardened
    type AddressIndexDerivationType Icarus = 'Soft
    type WithRole Icarus = Role

    deriveAccountPrivateKey :: Icarus 'RootK XPrv
-> Index (AccountIndexDerivationType Icarus) 'AccountK
-> Icarus 'AccountK XPrv
deriveAccountPrivateKey (Icarus XPrv
rootXPrv) Index (AccountIndexDerivationType Icarus) 'AccountK
accIx =
        let
            Just Index 'Hardened depth
purposeIx =
                Word32 -> Maybe (Index 'Hardened depth)
forall ix (derivationType :: DerivationType) (depth :: Depth).
(ix ~ Index derivationType depth, Bounded ix) =>
Word32 -> Maybe ix
indexFromWord32 @(Index 'Hardened _) Word32
purposeIndex
            Just Index 'Hardened depth
coinTypeIx =
                Word32 -> Maybe (Index 'Hardened depth)
forall ix (derivationType :: DerivationType) (depth :: Depth).
(ix ~ Index derivationType depth, Bounded ix) =>
Word32 -> Maybe ix
indexFromWord32 @(Index 'Hardened _) Word32
coinTypeIndex
            purposeXPrv :: XPrv
purposeXPrv = -- lvl1 derivation; hardened derivation of purpose'
                DerivationScheme -> XPrv -> Index 'Hardened Any -> XPrv
forall (derivationType :: DerivationType) (depth :: Depth).
DerivationScheme -> XPrv -> Index derivationType depth -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 XPrv
rootXPrv Index 'Hardened Any
forall (depth :: Depth). Index 'Hardened depth
purposeIx
            coinTypeXPrv :: XPrv
coinTypeXPrv = -- lvl2 derivation; hardened derivation of coin_type'
                DerivationScheme -> XPrv -> Index 'Hardened Any -> XPrv
forall (derivationType :: DerivationType) (depth :: Depth).
DerivationScheme -> XPrv -> Index derivationType depth -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 XPrv
purposeXPrv Index 'Hardened Any
forall (depth :: Depth). Index 'Hardened depth
coinTypeIx
            acctXPrv :: XPrv
acctXPrv = -- lvl3 derivation; hardened derivation of account' index
                DerivationScheme -> XPrv -> Index 'Hardened 'AccountK -> XPrv
forall (derivationType :: DerivationType) (depth :: Depth).
DerivationScheme -> XPrv -> Index derivationType depth -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 XPrv
coinTypeXPrv Index (AccountIndexDerivationType Icarus) 'AccountK
Index 'Hardened 'AccountK
accIx
        in
            XPrv -> Icarus 'AccountK XPrv
forall (depth :: Depth) key. key -> Icarus depth key
Icarus XPrv
acctXPrv

    deriveAddressPrivateKey :: Icarus 'AccountK XPrv
-> WithRole Icarus
-> Index (AddressIndexDerivationType Icarus) 'PaymentK
-> Icarus 'PaymentK XPrv
deriveAddressPrivateKey (Icarus XPrv
accXPrv) WithRole Icarus
role Index (AddressIndexDerivationType Icarus) 'PaymentK
addrIx =
        let
            changeXPrv :: XPrv
changeXPrv = -- lvl4 derivation; soft derivation of change chain
                DerivationScheme -> XPrv -> Index 'Soft Any -> XPrv
forall (derivationType :: DerivationType) (depth :: Depth).
DerivationScheme -> XPrv -> Index derivationType depth -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 XPrv
accXPrv (Role -> Index 'Soft Any
forall (depth :: Depth). Role -> Index 'Soft depth
roleToIndex WithRole Icarus
Role
role)
            addrXPrv :: XPrv
addrXPrv = -- lvl5 derivation; soft derivation of address index
                DerivationScheme -> XPrv -> Index 'Soft 'PaymentK -> XPrv
forall (derivationType :: DerivationType) (depth :: Depth).
DerivationScheme -> XPrv -> Index derivationType depth -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 XPrv
changeXPrv Index (AddressIndexDerivationType Icarus) 'PaymentK
Index 'Soft 'PaymentK
addrIx
        in
            XPrv -> Icarus 'PaymentK XPrv
forall (depth :: Depth) key. key -> Icarus depth key
Icarus XPrv
addrXPrv

instance Internal.SoftDerivation Icarus where
    deriveAddressPublicKey :: Icarus 'AccountK XPub
-> WithRole Icarus
-> Index 'Soft 'PaymentK
-> Icarus 'PaymentK XPub
deriveAddressPublicKey (Icarus XPub
accXPub) WithRole Icarus
role Index 'Soft 'PaymentK
addrIx =
        Icarus 'PaymentK XPub
-> Maybe (Icarus 'PaymentK XPub) -> Icarus 'PaymentK XPub
forall a. a -> Maybe a -> a
fromMaybe Icarus 'PaymentK XPub
errWrongIndex (Maybe (Icarus 'PaymentK XPub) -> Icarus 'PaymentK XPub)
-> Maybe (Icarus 'PaymentK XPub) -> Icarus 'PaymentK XPub
forall a b. (a -> b) -> a -> b
$ do
            XPub
changeXPub <- -- lvl4 derivation in bip44 is derivation of change chain
                DerivationScheme -> XPub -> Index 'Soft Any -> Maybe XPub
forall (derivationType :: DerivationType) (depth :: Depth).
DerivationScheme
-> XPub -> Index derivationType depth -> Maybe XPub
deriveXPub DerivationScheme
DerivationScheme2 XPub
accXPub (Role -> Index 'Soft Any
forall (depth :: Depth). Role -> Index 'Soft depth
roleToIndex WithRole Icarus
Role
role)
            XPub
addrXPub <- -- lvl5 derivation in bip44 is derivation of address chain
                DerivationScheme -> XPub -> Index 'Soft 'PaymentK -> Maybe XPub
forall (derivationType :: DerivationType) (depth :: Depth).
DerivationScheme
-> XPub -> Index derivationType depth -> Maybe XPub
deriveXPub DerivationScheme
DerivationScheme2 XPub
changeXPub Index 'Soft 'PaymentK
addrIx
            Icarus 'PaymentK XPub -> Maybe (Icarus 'PaymentK XPub)
forall (m :: * -> *) a. Monad m => a -> m a
return (Icarus 'PaymentK XPub -> Maybe (Icarus 'PaymentK XPub))
-> Icarus 'PaymentK XPub -> Maybe (Icarus 'PaymentK XPub)
forall a b. (a -> b) -> a -> b
$ XPub -> Icarus 'PaymentK XPub
forall (depth :: Depth) key. key -> Icarus depth key
Icarus XPub
addrXPub
      where
        errWrongIndex :: Icarus 'PaymentK XPub
errWrongIndex = String -> Icarus 'PaymentK XPub
forall a. (?callStack::CallStack) => String -> a
error (String -> Icarus 'PaymentK XPub)
-> String -> Icarus 'PaymentK 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]
++ Index 'Soft 'PaymentK -> String
forall a. Show a => a -> String
show Index 'Soft 'PaymentK
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."

-- | Generate a root key from a corresponding mnemonic.
--
-- @since 1.0.0
genMasterKeyFromMnemonic
    :: SomeMnemonic
        -- ^ Some valid mnemonic sentence.
    -> ScrubbedBytes
        -- ^ An optional second-factor passphrase (or 'mempty')
    -> Icarus 'RootK XPrv
genMasterKeyFromMnemonic :: SomeMnemonic -> ScrubbedBytes -> Icarus 'RootK XPrv
genMasterKeyFromMnemonic =
    SomeMnemonic -> ScrubbedBytes -> Icarus 'RootK XPrv
forall (key :: Depth -> * -> *).
GenMasterKey key =>
SomeMnemonic -> SecondFactor key -> key 'RootK XPrv
Internal.genMasterKeyFromMnemonic

-- | Generate a root key from a corresponding root 'XPrv'
--
-- @since 1.0.0
genMasterKeyFromXPrv
    :: XPrv
    -> Icarus 'RootK XPrv
genMasterKeyFromXPrv :: XPrv -> Icarus 'RootK XPrv
genMasterKeyFromXPrv =
    XPrv -> Icarus 'RootK XPrv
forall (key :: Depth -> * -> *).
GenMasterKey key =>
XPrv -> key 'RootK XPrv
Internal.genMasterKeyFromXPrv

-- Re-export from 'Cardano.Address.Derivation' to have it documented specialized in Haddock.
--
-- | Derives an account private key from the given root private key.
--
-- @since 1.0.0
deriveAccountPrivateKey
    :: Icarus 'RootK XPrv
    -> Index 'Hardened 'AccountK
    -> Icarus 'AccountK XPrv
deriveAccountPrivateKey :: Icarus 'RootK XPrv
-> Index 'Hardened 'AccountK -> Icarus 'AccountK XPrv
deriveAccountPrivateKey =
    Icarus 'RootK XPrv
-> Index 'Hardened 'AccountK -> Icarus 'AccountK XPrv
forall (key :: Depth -> * -> *).
HardDerivation key =>
key 'RootK XPrv
-> Index (AccountIndexDerivationType key) 'AccountK
-> key 'AccountK XPrv
Internal.deriveAccountPrivateKey

-- Re-export from 'Cardano.Address.Derivation' to have it documented specialized in Haddock.
--
-- | Derives an address private key from the given account private key.
--
-- @since 1.0.0
deriveAddressPrivateKey
    :: Icarus 'AccountK XPrv
    -> Role
    -> Index 'Soft 'PaymentK
    -> Icarus 'PaymentK XPrv
deriveAddressPrivateKey :: Icarus 'AccountK XPrv
-> Role -> Index 'Soft 'PaymentK -> Icarus 'PaymentK XPrv
deriveAddressPrivateKey =
    Icarus 'AccountK XPrv
-> Role -> Index 'Soft 'PaymentK -> Icarus 'PaymentK XPrv
forall (key :: Depth -> * -> *).
HardDerivation key =>
key 'AccountK XPrv
-> WithRole key
-> Index (AddressIndexDerivationType key) 'PaymentK
-> key 'PaymentK XPrv
Internal.deriveAddressPrivateKey

-- Re-export from 'Cardano.Address.Derivation' to have it documented specialized in Haddock
--
-- | Derives an address public key from the given account public key.
--
-- @since 1.0.0
deriveAddressPublicKey
    :: Icarus 'AccountK XPub
    -> Role
    -> Index 'Soft 'PaymentK
    -> Icarus 'PaymentK XPub
deriveAddressPublicKey :: Icarus 'AccountK XPub
-> Role -> Index 'Soft 'PaymentK -> Icarus 'PaymentK XPub
deriveAddressPublicKey =
    Icarus 'AccountK XPub
-> Role -> Index 'Soft 'PaymentK -> Icarus 'PaymentK XPub
forall (key :: Depth -> * -> *).
SoftDerivation key =>
key 'AccountK XPub
-> WithRole key -> Index 'Soft 'PaymentK -> key 'PaymentK XPub
Internal.deriveAddressPublicKey

--
-- Addresses
--
-- $addresses
-- === Generating a 'PaymentAddress'
--
-- > import Cardano.Address ( bech32 )
-- > import Cardano.Address.Derivation ( toXPub(..) )
-- >
-- > bech32 $ paymentAddress icarusMainnet (toXPub <$> addrK)
-- > "addr1vxpfffuj3zkp5g7ct6h4va89caxx9ayq2gvkyfvww48sdncxsce5t"

-- | Possible errors from inspecting a Shelley address
--
-- @since 3.0.0
data ErrInspectAddress
    = UnexpectedDerivationPath
    | DeserialiseError DeserialiseFailure
    deriving ((forall x. ErrInspectAddress -> Rep ErrInspectAddress x)
-> (forall x. Rep ErrInspectAddress x -> ErrInspectAddress)
-> Generic ErrInspectAddress
forall x. Rep ErrInspectAddress x -> ErrInspectAddress
forall x. ErrInspectAddress -> Rep ErrInspectAddress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrInspectAddress x -> ErrInspectAddress
$cfrom :: forall x. ErrInspectAddress -> Rep ErrInspectAddress x
Generic, Int -> ErrInspectAddress -> ShowS
[ErrInspectAddress] -> ShowS
ErrInspectAddress -> String
(Int -> ErrInspectAddress -> ShowS)
-> (ErrInspectAddress -> String)
-> ([ErrInspectAddress] -> ShowS)
-> Show ErrInspectAddress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrInspectAddress] -> ShowS
$cshowList :: [ErrInspectAddress] -> ShowS
show :: ErrInspectAddress -> String
$cshow :: ErrInspectAddress -> String
showsPrec :: Int -> ErrInspectAddress -> ShowS
$cshowsPrec :: Int -> ErrInspectAddress -> ShowS
Show, ErrInspectAddress -> ErrInspectAddress -> Bool
(ErrInspectAddress -> ErrInspectAddress -> Bool)
-> (ErrInspectAddress -> ErrInspectAddress -> Bool)
-> Eq ErrInspectAddress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrInspectAddress -> ErrInspectAddress -> Bool
$c/= :: ErrInspectAddress -> ErrInspectAddress -> Bool
== :: ErrInspectAddress -> ErrInspectAddress -> Bool
$c== :: ErrInspectAddress -> ErrInspectAddress -> Bool
Eq)
    deriving [ErrInspectAddress] -> Encoding
[ErrInspectAddress] -> Value
ErrInspectAddress -> Encoding
ErrInspectAddress -> Value
(ErrInspectAddress -> Value)
-> (ErrInspectAddress -> Encoding)
-> ([ErrInspectAddress] -> Value)
-> ([ErrInspectAddress] -> Encoding)
-> ToJSON ErrInspectAddress
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ErrInspectAddress] -> Encoding
$ctoEncodingList :: [ErrInspectAddress] -> Encoding
toJSONList :: [ErrInspectAddress] -> Value
$ctoJSONList :: [ErrInspectAddress] -> Value
toEncoding :: ErrInspectAddress -> Encoding
$ctoEncoding :: ErrInspectAddress -> Encoding
toJSON :: ErrInspectAddress -> Value
$ctoJSON :: ErrInspectAddress -> Value
ToJSON via WithErrorMessage ErrInspectAddress

instance Exception ErrInspectAddress where
  displayException :: ErrInspectAddress -> String
displayException = ErrInspectAddress -> String
prettyErrInspectAddress

-- | Pretty-print an 'ErrInspectAddress'
--
-- @since 3.0.0
prettyErrInspectAddress :: ErrInspectAddress -> String
prettyErrInspectAddress :: ErrInspectAddress -> String
prettyErrInspectAddress = \case
    ErrInspectAddress
UnexpectedDerivationPath ->
        String
"Unexpected derivation path"
    DeserialiseError DeserialiseFailure
e ->
        Format -> ShowS
forall r. (?callStack::CallStack, FormatType r) => Format -> r
format Format
"Deserialisation error (was: {})" (DeserialiseFailure -> String
forall a. Show a => a -> String
show DeserialiseFailure
e)

-- Determines whether an 'Address' is an Icarus address.
--
-- Returns a JSON object with information about the address, or throws
-- 'ErrInspectAddress' if the address isn't an icarus address.
--
-- @since 2.0.0
inspectIcarusAddress :: MonadThrow m => Address -> m Json.Value
inspectIcarusAddress :: Address -> m Value
inspectIcarusAddress = Address -> m Value
forall (m :: * -> *). MonadThrow m => Address -> m Value
inspectAddress
{-# DEPRECATED inspectIcarusAddress "use qualified 'inspectAddress' instead." #-}

-- | Determines whether an 'Address' is an Icarus address.
--
-- Returns a JSON object with information about the address, or throws
-- 'ErrInspectAddress' if the address isn't an icarus address.
--
-- @since 2.0.0
inspectAddress :: MonadThrow m => Address -> m Json.Value
inspectAddress :: Address -> m Value
inspectAddress = (ErrInspectAddress -> m Value)
-> (AddressInfo -> m Value)
-> Either ErrInspectAddress AddressInfo
-> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrInspectAddress -> m Value
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value)
-> (AddressInfo -> Value) -> AddressInfo -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressInfo -> Value
forall a. ToJSON a => a -> Value
toJSON) (Either ErrInspectAddress AddressInfo -> m Value)
-> (Address -> Either ErrInspectAddress AddressInfo)
-> Address
-> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> Either ErrInspectAddress AddressInfo
eitherInspectAddress

-- | Determines whether an 'Address' is an Icarus address.
--
-- Returns either details about the 'Address', or 'ErrInspectAddress' if it's
-- not a valid icarus address.
--
-- @since 3.4.0
eitherInspectAddress :: Address -> Either ErrInspectAddress AddressInfo
eitherInspectAddress :: Address -> Either ErrInspectAddress AddressInfo
eitherInspectAddress Address
addr = do
    ByteString
payload <- (DeserialiseFailure -> ErrInspectAddress)
-> Either DeserialiseFailure ByteString
-> Either ErrInspectAddress ByteString
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DeserialiseFailure -> ErrInspectAddress
DeserialiseError (Either DeserialiseFailure ByteString
 -> Either ErrInspectAddress ByteString)
-> Either DeserialiseFailure ByteString
-> Either ErrInspectAddress ByteString
forall a b. (a -> b) -> a -> b
$
        (forall s. Decoder s ByteString)
-> ByteString -> Either DeserialiseFailure ByteString
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure a
CBOR.deserialiseCbor forall s. Decoder s ByteString
CBOR.decodeAddressPayload (ByteString -> Either DeserialiseFailure ByteString)
-> ByteString -> Either DeserialiseFailure ByteString
forall a b. (a -> b) -> a -> b
$
        Address -> ByteString
unAddress Address
addr
    Maybe NetworkTag
ntwrk <- (DeserialiseFailure -> ErrInspectAddress)
-> (Maybe Word32 -> Maybe NetworkTag)
-> Either DeserialiseFailure (Maybe Word32)
-> Either ErrInspectAddress (Maybe NetworkTag)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap DeserialiseFailure -> ErrInspectAddress
DeserialiseError ((Word32 -> NetworkTag) -> Maybe Word32 -> Maybe NetworkTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> NetworkTag
NetworkTag) (Either DeserialiseFailure (Maybe Word32)
 -> Either ErrInspectAddress (Maybe NetworkTag))
-> Either DeserialiseFailure (Maybe Word32)
-> Either ErrInspectAddress (Maybe NetworkTag)
forall a b. (a -> b) -> a -> b
$
        (forall s. Decoder s (Maybe Word32))
-> ByteString -> Either DeserialiseFailure (Maybe Word32)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure a
CBOR.deserialiseCbor forall s. Decoder s (Maybe Word32)
CBOR.decodeProtocolMagicAttr ByteString
payload
    (ByteString
root, [(Word8, ByteString)]
attrs) <- (DeserialiseFailure -> ErrInspectAddress)
-> Either DeserialiseFailure (ByteString, [(Word8, ByteString)])
-> Either ErrInspectAddress (ByteString, [(Word8, ByteString)])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DeserialiseFailure -> ErrInspectAddress
DeserialiseError (Either DeserialiseFailure (ByteString, [(Word8, ByteString)])
 -> Either ErrInspectAddress (ByteString, [(Word8, ByteString)]))
-> Either DeserialiseFailure (ByteString, [(Word8, ByteString)])
-> Either ErrInspectAddress (ByteString, [(Word8, ByteString)])
forall a b. (a -> b) -> a -> b
$
        (forall s. Decoder s (ByteString, [(Word8, ByteString)]))
-> ByteString
-> Either DeserialiseFailure (ByteString, [(Word8, ByteString)])
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure a
CBOR.deserialiseCbor forall s. Decoder s (ByteString, [(Word8, ByteString)])
decodePayload ByteString
payload
    if (Word8 -> [Word8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Word8
1 ([Word8] -> Bool) -> [Word8] -> Bool
forall a b. (a -> b) -> a -> b
$ (Word8, ByteString) -> Word8
forall a b. (a, b) -> a
fst ((Word8, ByteString) -> Word8) -> [(Word8, ByteString)] -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Word8, ByteString)]
attrs)
        then ErrInspectAddress -> Either ErrInspectAddress AddressInfo
forall a b. a -> Either a b
Left ErrInspectAddress
UnexpectedDerivationPath
        else AddressInfo -> Either ErrInspectAddress AddressInfo
forall a b. b -> Either a b
Right AddressInfo :: ByteString -> Maybe NetworkTag -> AddressInfo
AddressInfo
            { infoAddressRoot :: ByteString
infoAddressRoot = ByteString
root
            , infoNetworkTag :: Maybe NetworkTag
infoNetworkTag = Maybe NetworkTag
ntwrk
            }
  where
    decodePayload :: forall s. CBOR.Decoder s (ByteString, [(Word8, ByteString)])
    decodePayload :: Decoder s (ByteString, [(Word8, ByteString)])
decodePayload = do
        ()
_ <- Int -> Decoder s ()
forall s. Int -> Decoder s ()
CBOR.decodeListLenCanonicalOf Int
3
        ByteString
root <- Decoder s ByteString
forall s. Decoder s ByteString
CBOR.decodeBytes
        (ByteString
root,) ([(Word8, ByteString)] -> (ByteString, [(Word8, ByteString)]))
-> Decoder s [(Word8, ByteString)]
-> Decoder s (ByteString, [(Word8, ByteString)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [(Word8, ByteString)]
forall s. Decoder s [(Word8, ByteString)]
CBOR.decodeAllAttributes

-- | The result of 'eitherInspectAddress' for Icarus addresses.
--
-- @since 3.4.0
data AddressInfo = AddressInfo
    { AddressInfo -> ByteString
infoAddressRoot :: !ByteString
    , AddressInfo -> Maybe NetworkTag
infoNetworkTag :: !(Maybe NetworkTag)
    } deriving ((forall x. AddressInfo -> Rep AddressInfo x)
-> (forall x. Rep AddressInfo x -> AddressInfo)
-> Generic AddressInfo
forall x. Rep AddressInfo x -> AddressInfo
forall x. AddressInfo -> Rep AddressInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AddressInfo x -> AddressInfo
$cfrom :: forall x. AddressInfo -> Rep AddressInfo x
Generic, Int -> AddressInfo -> ShowS
[AddressInfo] -> ShowS
AddressInfo -> String
(Int -> AddressInfo -> ShowS)
-> (AddressInfo -> String)
-> ([AddressInfo] -> ShowS)
-> Show AddressInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddressInfo] -> ShowS
$cshowList :: [AddressInfo] -> ShowS
show :: AddressInfo -> String
$cshow :: AddressInfo -> String
showsPrec :: Int -> AddressInfo -> ShowS
$cshowsPrec :: Int -> AddressInfo -> ShowS
Show, AddressInfo -> AddressInfo -> Bool
(AddressInfo -> AddressInfo -> Bool)
-> (AddressInfo -> AddressInfo -> Bool) -> Eq AddressInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddressInfo -> AddressInfo -> Bool
$c/= :: AddressInfo -> AddressInfo -> Bool
== :: AddressInfo -> AddressInfo -> Bool
$c== :: AddressInfo -> AddressInfo -> Bool
Eq)

instance ToJSON AddressInfo where
    toJSON :: AddressInfo -> Value
toJSON AddressInfo{Maybe NetworkTag
ByteString
infoNetworkTag :: Maybe NetworkTag
infoAddressRoot :: ByteString
infoNetworkTag :: AddressInfo -> Maybe NetworkTag
infoAddressRoot :: AddressInfo -> ByteString
..} = [Pair] -> Value
Json.object
        [ Key
"network_tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value -> (NetworkTag -> Value) -> Maybe NetworkTag -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Json.Null NetworkTag -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe NetworkTag
infoNetworkTag
        , Key
"address_root" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
T.decodeUtf8 (Encoding -> ByteString -> ByteString
encode Encoding
forall a. AbstractEncoding a
EBase16 ByteString
infoAddressRoot)
        , Key
"address_type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word8 -> Value
forall a. ToJSON a => a -> Value
toJSON @Word8 Word8
8
        ]

instance Internal.PaymentAddress Icarus where
    paymentAddress :: NetworkDiscriminant Icarus -> Icarus 'PaymentK XPub -> Address
paymentAddress NetworkDiscriminant Icarus
discrimination Icarus 'PaymentK XPub
k = ByteString -> Address
unsafeMkAddress
        (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 (Icarus 'PaymentK XPub -> XPub
forall (depth :: Depth) key. Icarus depth key -> key
getKey Icarus 'PaymentK XPub
k) [Encoding]
attrs
      where
        NetworkTag Word32
magic = NetworkDiscriminant Icarus -> NetworkTag
forall (key :: Depth -> * -> *).
HasNetworkDiscriminant key =>
NetworkDiscriminant key -> NetworkTag
networkTag @Icarus NetworkDiscriminant Icarus
discrimination
        attrs :: [Encoding]
attrs = case NetworkDiscriminant Icarus -> AddressDiscrimination
forall (key :: Depth -> * -> *).
HasNetworkDiscriminant key =>
NetworkDiscriminant key -> AddressDiscrimination
addressDiscrimination @Icarus NetworkDiscriminant Icarus
discrimination of
            AddressDiscrimination
RequiresNetworkTag ->
                [ Word32 -> Encoding
CBOR.encodeProtocolMagicAttr Word32
magic
                ]
            AddressDiscrimination
RequiresNoTag ->
                []

-- Re-export from 'Cardano.Address' to have it documented specialized in Haddock.
--
-- | Convert a public key to a payment 'Address' valid for the given
-- network discrimination.
--
-- @since 1.0.0
paymentAddress
    :: NetworkDiscriminant Icarus
    -> Icarus 'PaymentK XPub
    -> Address
paymentAddress :: NetworkDiscriminant Icarus -> Icarus 'PaymentK XPub -> Address
paymentAddress =
    NetworkDiscriminant Icarus -> Icarus 'PaymentK XPub -> Address
forall (key :: Depth -> * -> *).
PaymentAddress key =>
NetworkDiscriminant key -> key 'PaymentK XPub -> Address
Internal.paymentAddress

--
-- Network Discrimination
--

instance HasNetworkDiscriminant Icarus where
    type NetworkDiscriminant Icarus = (AddressDiscrimination, NetworkTag)
    addressDiscrimination :: NetworkDiscriminant Icarus -> AddressDiscrimination
addressDiscrimination = NetworkDiscriminant Icarus -> AddressDiscrimination
forall a b. (a, b) -> a
fst
    networkTag :: NetworkDiscriminant Icarus -> NetworkTag
networkTag = NetworkDiscriminant Icarus -> NetworkTag
forall a b. (a, b) -> b
snd

-- | 'NetworkDiscriminant' for Cardano MainNet & 'Icarus'
--
-- @since 2.0.0
icarusMainnet :: NetworkDiscriminant Icarus
icarusMainnet :: NetworkDiscriminant Icarus
icarusMainnet = NetworkDiscriminant Byron
NetworkDiscriminant Icarus
byronMainnet

-- | 'NetworkDiscriminant' for Cardano Staging & 'Icarus'
--
-- @since 2.0.0
icarusStaging :: NetworkDiscriminant Icarus
icarusStaging :: NetworkDiscriminant Icarus
icarusStaging = NetworkDiscriminant Byron
NetworkDiscriminant Icarus
byronStaging

-- | 'NetworkDiscriminant' for Cardano TestNet & 'Icarus'
--
-- @since 2.0.0
icarusTestnet :: NetworkDiscriminant Icarus
icarusTestnet :: NetworkDiscriminant Icarus
icarusTestnet = NetworkDiscriminant Byron
NetworkDiscriminant Icarus
byronTestnet

--
-- Unsafe
--

-- | Unsafe backdoor for constructing an 'Icarus' key from a raw 'XPrv'. this is
-- unsafe because it lets the caller choose the actually derivation 'depth'.
--
-- This can be useful however when serializing / deserializing such a type, or to
-- speed up test code (and avoid having to do needless derivations from a master
-- key down to an address key for instance).
--
-- @since 1.0.0
liftXPrv :: XPrv -> Icarus depth XPrv
liftXPrv :: XPrv -> Icarus depth XPrv
liftXPrv = XPrv -> Icarus depth XPrv
forall (depth :: Depth) key. key -> Icarus depth key
Icarus

-- | Unsafe backdoor for constructing an 'Icarus' key from a raw 'XPub'. this is
-- unsafe because it lets the caller choose the actually derivation 'depth'.
--
-- This can be useful however when serializing / deserializing such a type, or to
-- speed up test code (and avoid having to do needless derivations from a master
-- key down to an address key for instance).
--
-- @since 2.0.0
liftXPub :: XPub -> Icarus depth XPub
liftXPub :: XPub -> Icarus depth XPub
liftXPub = XPub -> Icarus depth XPub
forall (depth :: Depth) key. key -> Icarus depth key
Icarus

--
-- Internal
--

-- Purpose is a constant set to 44' (or 0x8000002C) following the original
-- BIP-44 specification.
--
-- It indicates that the subtree of this node is used according to this
-- specification.
--
-- Hardened derivation is used at this level.
purposeIndex :: Word32
purposeIndex :: Word32
purposeIndex = Word32
0x8000002C

-- One master node (seed) can be used for unlimited number of independent
-- cryptocoins such as Bitcoin, Litecoin or Namecoin. However, sharing the
-- same space for various cryptocoins has some disadvantages.
--
-- This level creates a separate subtree for every cryptocoin, avoiding reusing
-- addresses across cryptocoins and improving privacy issues.
--
-- Coin type is a constant, set for each cryptocoin. For Cardano this constant
-- is set to 1815' (or 0x80000717). 1815 is the birthyear of our beloved Ada
-- Lovelace.
--
-- Hardened derivation is used at this level.
coinTypeIndex :: Word32
coinTypeIndex :: Word32
coinTypeIndex = Word32
0x80000717

-- The minimum seed length for 'generateKeyFromMnemonic' and 'unsafeGenerateKeyFromMnemonic'.
minSeedLengthBytes :: Int
minSeedLengthBytes :: Int
minSeedLengthBytes = Int
16

-- 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.
unsafeGenerateKeyFromHardwareLedger
    :: SomeMnemonic
        -- ^ The root mnemonic
    -> Icarus 'RootK XPrv
unsafeGenerateKeyFromHardwareLedger :: SomeMnemonic -> Icarus 'RootK XPrv
unsafeGenerateKeyFromHardwareLedger (SomeMnemonic Mnemonic mw
mw) = Either String (Icarus 'RootK XPrv) -> Icarus 'RootK XPrv
forall a. Either String a -> a
unsafeFromRight (Either String (Icarus 'RootK XPrv) -> Icarus 'RootK XPrv)
-> Either String (Icarus 'RootK XPrv) -> Icarus '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 (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
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

    XPrv
prv <- Either String XPrv
-> (XPrv -> Either String XPrv) -> Maybe XPrv -> Either String XPrv
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String XPrv
forall a b. a -> Either a b
Left String
"invalid xprv") XPrv -> Either String XPrv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe XPrv -> Either String XPrv)
-> Maybe XPrv -> Either String XPrv
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe XPrv
xprvFromBytes (ByteString -> Maybe XPrv) -> ByteString -> Maybe 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
cc
    Icarus 'RootK XPrv -> Either String (Icarus 'RootK XPrv)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Icarus 'RootK XPrv -> Either String (Icarus 'RootK XPrv))
-> Icarus 'RootK XPrv -> Either String (Icarus 'RootK XPrv)
forall a b. (a -> b) -> a -> b
$ XPrv -> Icarus 'RootK XPrv
forall (depth :: Depth) key. key -> Icarus depth key
Icarus XPrv
prv
  where
    -- Errors yielded in the body of 'unsafeGenerateKeyFromHardwareLedger' 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. (?callStack::CallStack) => 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. (?callStack::CallStack) => 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. (?callStack::CallStack) => 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)

    -- 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"