never executed always true always false
    1 {-# LANGUAGE DataKinds #-}
    2 {-# LANGUAGE DeriveFunctor #-}
    3 {-# LANGUAGE DeriveGeneric #-}
    4 {-# LANGUAGE DerivingVia #-}
    5 {-# LANGUAGE ExistentialQuantification #-}
    6 {-# LANGUAGE FlexibleContexts #-}
    7 {-# LANGUAGE GADTs #-}
    8 {-# LANGUAGE LambdaCase #-}
    9 {-# LANGUAGE OverloadedStrings #-}
   10 {-# LANGUAGE RecordWildCards #-}
   11 {-# LANGUAGE StandaloneDeriving #-}
   12 {-# LANGUAGE TupleSections #-}
   13 {-# LANGUAGE TypeApplications #-}
   14 {-# LANGUAGE TypeFamilies #-}
   15 
   16 {-# OPTIONS_HADDOCK prune #-}
   17 
   18 -- |
   19 -- Copyright: © 2018-2020 IOHK
   20 -- License: Apache-2.0
   21 
   22 module Cardano.Address.Style.Icarus
   23     ( -- $overview
   24 
   25       -- * Icarus
   26       Icarus
   27     , getKey
   28     , Role (..)
   29     , roleFromIndex
   30     , roleToIndex
   31 
   32       -- * Key Derivation
   33       -- $keyDerivation
   34     , genMasterKeyFromXPrv
   35     , genMasterKeyFromMnemonic
   36     , deriveAccountPrivateKey
   37     , deriveAddressPrivateKey
   38     , deriveAddressPublicKey
   39 
   40       -- * Addresses
   41       -- $addresses
   42     , AddressInfo (..)
   43     , eitherInspectAddress
   44     , inspectAddress
   45     , inspectIcarusAddress
   46     , paymentAddress
   47     , ErrInspectAddress
   48     , prettyErrInspectAddress
   49 
   50       -- * Network Discrimination
   51     , icarusMainnet
   52     , icarusStaging
   53     , icarusTestnet
   54     , icarusPreview
   55     , icarusPreprod
   56 
   57       -- * Unsafe
   58     , liftXPrv
   59     , liftXPub
   60 
   61       -- Internals
   62     , unsafeGenerateKeyFromHardwareLedger
   63     , minSeedLengthBytes
   64     ) where
   65 
   66 import Prelude
   67 
   68 import Cardano.Address
   69     ( Address
   70     , AddressDiscrimination (..)
   71     , NetworkDiscriminant (..)
   72     , NetworkTag (..)
   73     , unAddress
   74     , unsafeMkAddress
   75     )
   76 import Cardano.Address.Derivation
   77     ( Depth (..)
   78     , DerivationScheme (..)
   79     , DerivationType (..)
   80     , Index (..)
   81     , XPrv
   82     , XPub
   83     , deriveXPrv
   84     , deriveXPub
   85     , generateNew
   86     , indexFromWord32
   87     , unsafeMkIndex
   88     , xprvFromBytes
   89     )
   90 import Cardano.Address.Internal
   91     ( DeserialiseFailure, WithErrorMessage (..) )
   92 import Cardano.Address.Style.Byron
   93     ( byronMainnet, byronPreprod, byronPreview, byronStaging, byronTestnet )
   94 import Cardano.Mnemonic
   95     ( SomeMnemonic (..), entropyToBytes, mnemonicToEntropy, mnemonicToText )
   96 import Codec.Binary.Encoding
   97     ( AbstractEncoding (..), encode )
   98 import Control.DeepSeq
   99     ( NFData )
  100 import Control.Exception
  101     ( Exception, displayException )
  102 import Control.Exception.Base
  103     ( assert )
  104 import Control.Monad.Catch
  105     ( MonadThrow, throwM )
  106 import Crypto.Hash.Algorithms
  107     ( SHA256 (..), SHA512 (..) )
  108 import Crypto.MAC.HMAC
  109     ( HMAC, hmac )
  110 import Data.Aeson
  111     ( ToJSON (..), (.=) )
  112 import Data.Bifunctor
  113     ( bimap, first )
  114 import Data.Bits
  115     ( clearBit, setBit, testBit )
  116 import Data.ByteArray
  117     ( ScrubbedBytes )
  118 import Data.ByteString
  119     ( ByteString )
  120 import Data.Function
  121     ( (&) )
  122 import Data.Maybe
  123     ( fromMaybe )
  124 import Data.Typeable
  125     ( Typeable )
  126 import Data.Word
  127     ( Word32, Word8 )
  128 import Fmt
  129     ( format )
  130 import GHC.Generics
  131     ( Generic )
  132 
  133 import qualified Cardano.Address as Internal
  134 import qualified Cardano.Address.Derivation as Internal
  135 import qualified Cardano.Codec.Cbor as CBOR
  136 import qualified Codec.CBOR.Decoding as CBOR
  137 import qualified Crypto.KDF.PBKDF2 as PBKDF2
  138 import qualified Data.Aeson as Json
  139 import qualified Data.ByteArray as BA
  140 import qualified Data.ByteString as BS
  141 import qualified Data.Text as T
  142 import qualified Data.Text.Encoding as T
  143 
  144 -- $overview
  145 --
  146 -- This module provides an implementation of:
  147 --
  148 -- - 'Cardano.Address.Derivation.GenMasterKey': for generating Icarus master keys from mnemonic sentences
  149 -- - 'Cardano.Address.Derivation.HardDerivation': for hierarchical hard derivation of parent to child keys
  150 -- - 'Cardano.Address.Derivation.SoftDerivation': for hierarchical soft derivation of parent to child keys
  151 -- - 'Cardano.Address.PaymentAddress': for constructing addresses from a public key
  152 --
  153 -- We call 'Icarus' addresses the new format of Cardano addresses which came
  154 -- after 'Cardano.Address.Style.Byron.Byron'. This is the format initially used in /Yoroi/
  155 -- and now also used by /Daedalus/.
  156 
  157 -- | A cryptographic key for sequential-scheme address derivation, with
  158 -- phantom-types to disambiguate key types.
  159 --
  160 -- @
  161 -- let rootPrivateKey = Icarus 'RootK XPrv
  162 -- let accountPubKey  = Icarus 'AccountK XPub
  163 -- let addressPubKey  = Icarus 'PaymentK XPub
  164 -- @
  165 --
  166 -- @since 1.0.0
  167 newtype Icarus (depth :: Depth) key = Icarus
  168     { getKey :: key
  169         -- ^ Extract the raw 'XPrv' or 'XPub' wrapped by this type.
  170         --
  171         -- @since 1.0.0
  172     }
  173     deriving stock (Generic, Show, Eq)
  174 
  175 deriving instance (Functor (Icarus depth))
  176 instance (NFData key) => NFData (Icarus depth key)
  177 
  178 data Role
  179     = UTxOExternal
  180     | UTxOInternal
  181     deriving (Generic, Typeable, Show, Eq, Ord, Bounded)
  182 
  183 instance NFData Role
  184 
  185 roleFromIndex :: Index 'Soft depth -> Maybe Role
  186 roleFromIndex ix = case indexToWord32 ix of
  187     0 -> Just UTxOExternal
  188     1 -> Just UTxOInternal
  189     _ -> Nothing
  190 
  191 roleToIndex :: Role -> Index 'Soft depth
  192 roleToIndex = unsafeMkIndex . \case
  193     UTxOExternal -> 0
  194     UTxOInternal -> 1
  195 
  196 --
  197 -- Key Derivation
  198 --
  199 -- $keyDerivation
  200 --
  201 -- === Generating a root key from 'SomeMnemonic'
  202 -- > :set -XOverloadedStrings
  203 -- > :set -XTypeApplications
  204 -- > :set -XDataKinds
  205 -- > :set -XFlexibleContexts
  206 -- > import Cardano.Mnemonic ( mkSomeMnemonic )
  207 -- > import Cardano.Address ( base58 )
  208 -- > import Cardano.Address.Derivation ( toXPub )
  209 -- > import qualified Cardano.Address.Style.Icarus as Icarus
  210 -- >
  211 -- > let (Right mw) = mkSomeMnemonic @'[15] ["network","empty","cause","mean","expire","private","finger","accident","session","problem","absurd","banner","stage","void","what"]
  212 -- > let sndFactor = mempty -- Or alternatively, a second factor mnemonic transformed to bytes via someMnemonicToBytes
  213 -- > let rootK = Icarus.genMasterKeyFromMnemonic mw sndFactor :: Icarus 'RootK XPrv
  214 --
  215 -- === Deriving child keys
  216 --
  217 -- Let's consider the following 3rd, 4th and 5th derivation paths @0'\/0\/14@
  218 -- === accIx assumes values from 2147483648 (ie. 0x80000000) to 4294967295 (ie. 0xFFFFFFFF)
  219 -- === addIx assume values from 0 to 2147483647 (ie. 7FFFFFFF)
  220 -- > let Just accIx = indexFromWord32 0x80000000
  221 -- === this is the same as
  222 -- > let accIx = minBound @(Index 'Hardened 'AccountK)
  223 -- > let acctK = Icarus.deriveAccountPrivateKey rootK accIx
  224 -- >
  225 -- > let Just addIx = indexFromWord32 0x00000014
  226 -- > let addrK = Icarus.deriveAddressPrivateKey acctK Icarus.UTxOExternal addIx
  227 -- >
  228 -- > base58 $ Icarus.paymentAddress Icarus.icarusMainnet (toXPub <$> addrK)
  229 -- >"Ae2tdPwUPEZ8XpsjgQPH2cJdtohkYrxJ3i5y6mVsrkZZkdpdn6mnr4Rt6wG"
  230 
  231 instance Internal.GenMasterKey Icarus where
  232     type SecondFactor Icarus = ScrubbedBytes
  233 
  234     genMasterKeyFromXPrv = liftXPrv
  235     genMasterKeyFromMnemonic (SomeMnemonic mw) sndFactor =
  236         let
  237             seed  = entropyToBytes $ mnemonicToEntropy mw
  238             seedValidated = assert
  239                 (BA.length seed >= minSeedLengthBytes && BA.length seed <= 255)
  240                 seed
  241         in Icarus $ generateNew seedValidated sndFactor
  242 
  243 instance Internal.HardDerivation Icarus where
  244     type AccountIndexDerivationType Icarus = 'Hardened
  245     type AddressIndexDerivationType Icarus = 'Soft
  246     type WithRole Icarus = Role
  247 
  248     deriveAccountPrivateKey (Icarus rootXPrv) accIx =
  249         let
  250             Just purposeIx =
  251                 indexFromWord32 @(Index 'Hardened _) purposeIndex
  252             Just coinTypeIx =
  253                 indexFromWord32 @(Index 'Hardened _) coinTypeIndex
  254             purposeXPrv = -- lvl1 derivation; hardened derivation of purpose'
  255                 deriveXPrv DerivationScheme2 rootXPrv purposeIx
  256             coinTypeXPrv = -- lvl2 derivation; hardened derivation of coin_type'
  257                 deriveXPrv DerivationScheme2 purposeXPrv coinTypeIx
  258             acctXPrv = -- lvl3 derivation; hardened derivation of account' index
  259                 deriveXPrv DerivationScheme2 coinTypeXPrv accIx
  260         in
  261             Icarus acctXPrv
  262 
  263     deriveAddressPrivateKey (Icarus accXPrv) role addrIx =
  264         let
  265             changeXPrv = -- lvl4 derivation; soft derivation of change chain
  266                 deriveXPrv DerivationScheme2 accXPrv (roleToIndex role)
  267             addrXPrv = -- lvl5 derivation; soft derivation of address index
  268                 deriveXPrv DerivationScheme2 changeXPrv addrIx
  269         in
  270             Icarus addrXPrv
  271 
  272 instance Internal.SoftDerivation Icarus where
  273     deriveAddressPublicKey (Icarus accXPub) role addrIx =
  274         fromMaybe errWrongIndex $ do
  275             changeXPub <- -- lvl4 derivation in bip44 is derivation of change chain
  276                 deriveXPub DerivationScheme2 accXPub (roleToIndex role)
  277             addrXPub <- -- lvl5 derivation in bip44 is derivation of address chain
  278                 deriveXPub DerivationScheme2 changeXPub addrIx
  279             return $ Icarus addrXPub
  280       where
  281         errWrongIndex = error $
  282             "deriveAddressPublicKey failed: was given an hardened (or too big) \
  283             \index for soft path derivation ( " ++ show addrIx ++ "). This is \
  284             \either a programmer error, or, we may have reached the maximum \
  285             \number of addresses for a given wallet."
  286 
  287 -- | Generate a root key from a corresponding mnemonic.
  288 --
  289 -- @since 1.0.0
  290 genMasterKeyFromMnemonic
  291     :: SomeMnemonic
  292         -- ^ Some valid mnemonic sentence.
  293     -> ScrubbedBytes
  294         -- ^ An optional second-factor passphrase (or 'mempty')
  295     -> Icarus 'RootK XPrv
  296 genMasterKeyFromMnemonic =
  297     Internal.genMasterKeyFromMnemonic
  298 
  299 -- | Generate a root key from a corresponding root 'XPrv'
  300 --
  301 -- @since 1.0.0
  302 genMasterKeyFromXPrv
  303     :: XPrv
  304     -> Icarus 'RootK XPrv
  305 genMasterKeyFromXPrv =
  306     Internal.genMasterKeyFromXPrv
  307 
  308 -- Re-export from 'Cardano.Address.Derivation' to have it documented specialized in Haddock.
  309 --
  310 -- | Derives an account private key from the given root private key.
  311 --
  312 -- @since 1.0.0
  313 deriveAccountPrivateKey
  314     :: Icarus 'RootK XPrv
  315     -> Index 'Hardened 'AccountK
  316     -> Icarus 'AccountK XPrv
  317 deriveAccountPrivateKey =
  318     Internal.deriveAccountPrivateKey
  319 
  320 -- Re-export from 'Cardano.Address.Derivation' to have it documented specialized in Haddock.
  321 --
  322 -- | Derives an address private key from the given account private key.
  323 --
  324 -- @since 1.0.0
  325 deriveAddressPrivateKey
  326     :: Icarus 'AccountK XPrv
  327     -> Role
  328     -> Index 'Soft 'PaymentK
  329     -> Icarus 'PaymentK XPrv
  330 deriveAddressPrivateKey =
  331     Internal.deriveAddressPrivateKey
  332 
  333 -- Re-export from 'Cardano.Address.Derivation' to have it documented specialized in Haddock
  334 --
  335 -- | Derives an address public key from the given account public key.
  336 --
  337 -- @since 1.0.0
  338 deriveAddressPublicKey
  339     :: Icarus 'AccountK XPub
  340     -> Role
  341     -> Index 'Soft 'PaymentK
  342     -> Icarus 'PaymentK XPub
  343 deriveAddressPublicKey =
  344     Internal.deriveAddressPublicKey
  345 
  346 --
  347 -- Addresses
  348 --
  349 -- $addresses
  350 -- === Generating a 'PaymentAddress'
  351 --
  352 -- | Possible errors from inspecting a Shelley address
  353 --
  354 -- @since 3.0.0
  355 data ErrInspectAddress
  356     = UnexpectedDerivationPath
  357     | DeserialiseError DeserialiseFailure
  358     deriving (Generic, Show, Eq)
  359     deriving ToJSON via WithErrorMessage ErrInspectAddress
  360 
  361 instance Exception ErrInspectAddress where
  362   displayException = prettyErrInspectAddress
  363 
  364 -- | Pretty-print an 'ErrInspectAddress'
  365 --
  366 -- @since 3.0.0
  367 prettyErrInspectAddress :: ErrInspectAddress -> String
  368 prettyErrInspectAddress = \case
  369     UnexpectedDerivationPath ->
  370         "Unexpected derivation path"
  371     DeserialiseError e ->
  372         format "Deserialisation error (was: {})" (show e)
  373 
  374 -- Determines whether an 'Address' is an Icarus address.
  375 --
  376 -- Returns a JSON object with information about the address, or throws
  377 -- 'ErrInspectAddress' if the address isn't an icarus address.
  378 --
  379 -- @since 2.0.0
  380 inspectIcarusAddress :: MonadThrow m => Address -> m Json.Value
  381 inspectIcarusAddress = inspectAddress
  382 {-# DEPRECATED inspectIcarusAddress "use qualified 'inspectAddress' instead." #-}
  383 
  384 -- | Determines whether an 'Address' is an Icarus address.
  385 --
  386 -- Returns a JSON object with information about the address, or throws
  387 -- 'ErrInspectAddress' if the address isn't an icarus address.
  388 -- λ> :set -XOverloadedStrings
  389 -- λ> :set -XTypeApplications
  390 -- λ> :set -XDataKinds
  391 -- λ> :set -XFlexibleContexts
  392 -- λ> import Cardano.Mnemonic ( mkSomeMnemonic )
  393 -- λ> import qualified Cardano.Address.Style.Icarus as Icarus
  394 -- λ> import Cardano.Address.Derivation ( toXPub )
  395 -- λ> import Cardano.Address ( base58 )
  396 -- λ> let (Right mw) = mkSomeMnemonic @'[12] ["moon","fox","ostrich","quick","cactus","raven","wasp","intact","first","ring","crumble","error"]
  397 -- λ> let sndFactor = mempty
  398 -- λ> let rootK = Icarus.genMasterKeyFromMnemonic mw sndFactor :: Icarus 'RootK XPrv
  399 -- λ> let Just accIx = indexFromWord32 0x80000000
  400 -- λ> let acctK = Icarus.deriveAccountPrivateKey rootK accIx
  401 -- λ> let Just addIx = indexFromWord32 0x00000014
  402 -- λ> let addrK = Icarus.deriveAddressPrivateKey acctK Icarus.UTxOExternal addIx
  403 -- λ> (toXPub <$> addrK)
  404 -- Icarus {getKey = XPub {xpubPublicKey = "\223\148\230\206\187\135\253\SO\151\216\183\210]}s:\151\134\174q\173\207\184\202\EM\176\170\220\216\235\&1\243", xpubChaincode = ChainCode "\\\160\196\&8~\208\165\241\138\SOH\222\ETX*\150&\214\185\196 \153\DC2\167\165\243\155\136\228\255\229~d\253"}}
  405 -- λ> base58 $ Icarus.paymentAddress icarusMainnet (toXPub <$> addrK)
  406 -- "Ae2tdPwUPEYyzBcNXkFWKywMiZ9eSd96dQxhBQd371foiH16Y7gFgLBj9G5"
  407 --
  408 -- λ> import Cardano.Codec.Cbor
  409 -- λ> import Crypto.Hash.Algorithms (Blake2b_224, SHA3_256)
  410 -- λ> import Crypto.Hash (hash)
  411 -- λ> let blake2b224 = hash @_ @Blake2b_224
  412 -- λ> let sha3256 = hash @_ @SHA3_256
  413 -- λ> import qualified Codec.CBOR.Encoding as CBOR
  414 -- λ> let encodeXPub = CBOR.encodeBytes (xpubToBytes . Icarus.getKey $ icarusAddrKPub)
  415 -- λ> let encodeSpendingData = CBOR.encodeListLen 2 <> CBOR.encodeWord8 0 <> encodeXPub
  416 -- λ> let encodeAttrs = CBOR.encodeMapLen 0
  417 -- λ> import qualified Data.ByteArray as BA
  418 -- λ> let rootAddr = BA.convert $ blake2b224 $ sha3256 $ CBOR.toStrictByteString $ mempty <> CBOR.encodeListLen 3 <> CBOR.encodeWord8 0 <> encodeSpendingData <> encodeAttrs
  419 -- λ> encode EBase16 rootAddr
  420 -- "1fdde02c9e087474aa7ab0a46ae2f6d316a92cd0fa2d4e8b1c2eebdf"
  421 --
  422 -- $ echo Ae2tdPwUPEYyzBcNXkFWKywMiZ9eSd96dQxhBQd371foiH16Y7gFgLBj9G5 | cardano-address address inspect
  423 -- {
  424 --    "stake_reference": "none",
  425 --    "address_style": "Icarus",
  426 --    "address_root": "1fdde02c9e087474aa7ab0a46ae2f6d316a92cd0fa2d4e8b1c2eebdf",
  427 --    "network_tag": null,
  428 --    "address_type": 8
  429 --}
  430 -- @since 2.0.0
  431 inspectAddress :: MonadThrow m => Address -> m Json.Value
  432 inspectAddress = either throwM (pure . toJSON) . eitherInspectAddress
  433 
  434 -- | Determines whether an 'Address' is an Icarus address.
  435 --
  436 -- Returns either details about the 'Address', or 'ErrInspectAddress' if it's
  437 -- not a valid icarus address.
  438 --
  439 -- @since 3.4.0
  440 eitherInspectAddress :: Address -> Either ErrInspectAddress AddressInfo
  441 eitherInspectAddress addr = do
  442     payload <- first DeserialiseError $
  443         CBOR.deserialiseCbor CBOR.decodeAddressPayload $
  444         unAddress addr
  445     ntwrk <- bimap DeserialiseError (fmap NetworkTag) $
  446         CBOR.deserialiseCbor CBOR.decodeProtocolMagicAttr payload
  447     (root, attrs) <- first DeserialiseError $
  448         CBOR.deserialiseCbor decodePayload payload
  449     if (elem 1 $ fst <$> attrs)
  450         then Left UnexpectedDerivationPath
  451         else Right AddressInfo
  452             { infoAddressRoot = root
  453             , infoNetworkTag = ntwrk
  454             }
  455   where
  456     decodePayload :: forall s. CBOR.Decoder s (ByteString, [(Word8, ByteString)])
  457     decodePayload = do
  458         _ <- CBOR.decodeListLenCanonicalOf 3
  459         root <- CBOR.decodeBytes
  460         (root,) <$> CBOR.decodeAllAttributes
  461 
  462 -- | The result of 'eitherInspectAddress' for Icarus addresses.
  463 --
  464 -- @since 3.4.0
  465 data AddressInfo = AddressInfo
  466     { infoAddressRoot :: !ByteString
  467     , infoNetworkTag :: !(Maybe NetworkTag)
  468     } deriving (Generic, Show, Eq)
  469 
  470 instance ToJSON AddressInfo where
  471     toJSON AddressInfo{..} = Json.object
  472         [ "network_tag" .= maybe Json.Null toJSON infoNetworkTag
  473         , "address_root" .= T.decodeUtf8 (encode EBase16 infoAddressRoot)
  474         , "address_type" .= toJSON @Word8 8
  475         ]
  476 
  477 instance Internal.PaymentAddress Icarus where
  478     paymentAddress discrimination k = unsafeMkAddress
  479         $ CBOR.toStrictByteString
  480         $ CBOR.encodeAddress (getKey k) attrs
  481       where
  482         NetworkTag magic = networkTag @Icarus discrimination
  483         attrs = case addressDiscrimination @Icarus discrimination of
  484             RequiresNetworkTag ->
  485                 [ CBOR.encodeProtocolMagicAttr magic
  486                 ]
  487             RequiresNoTag ->
  488                 []
  489 
  490 -- Re-export from 'Cardano.Address' to have it documented specialized in Haddock.
  491 --
  492 -- | Convert a public key to a payment 'Address' valid for the given
  493 -- network discrimination.
  494 --
  495 -- @since 1.0.0
  496 paymentAddress
  497     :: NetworkDiscriminant Icarus
  498     -> Icarus 'PaymentK XPub
  499     -> Address
  500 paymentAddress =
  501     Internal.paymentAddress
  502 
  503 --
  504 -- Network Discrimination
  505 --
  506 
  507 instance HasNetworkDiscriminant Icarus where
  508     type NetworkDiscriminant Icarus = (AddressDiscrimination, NetworkTag)
  509     addressDiscrimination = fst
  510     networkTag = snd
  511 
  512 -- | 'NetworkDiscriminant' for Cardano MainNet & 'Icarus'
  513 --
  514 -- @since 2.0.0
  515 icarusMainnet :: NetworkDiscriminant Icarus
  516 icarusMainnet = byronMainnet
  517 
  518 -- | 'NetworkDiscriminant' for Cardano Staging & 'Icarus'
  519 --
  520 -- @since 2.0.0
  521 icarusStaging :: NetworkDiscriminant Icarus
  522 icarusStaging = byronStaging
  523 
  524 -- | 'NetworkDiscriminant' for Cardano Testnet & 'Icarus'
  525 --
  526 -- @since 2.0.0
  527 icarusTestnet :: NetworkDiscriminant Icarus
  528 icarusTestnet = byronTestnet
  529 
  530 -- | 'NetworkDiscriminant' for Cardano Preprod & 'Icarus'
  531 --
  532 -- @since 3.13.0
  533 icarusPreprod :: NetworkDiscriminant Icarus
  534 icarusPreprod = byronPreprod
  535 
  536 -- | 'NetworkDiscriminant' for Cardano Preview & 'Icarus'
  537 --
  538 -- @since 3.13.0
  539 icarusPreview :: NetworkDiscriminant Icarus
  540 icarusPreview = byronPreview
  541 
  542 --
  543 -- Unsafe
  544 --
  545 
  546 -- | Unsafe backdoor for constructing an 'Icarus' key from a raw 'XPrv'. this is
  547 -- unsafe because it lets the caller choose the actually derivation 'depth'.
  548 --
  549 -- This can be useful however when serializing / deserializing such a type, or to
  550 -- speed up test code (and avoid having to do needless derivations from a master
  551 -- key down to an address key for instance).
  552 --
  553 -- @since 1.0.0
  554 liftXPrv :: XPrv -> Icarus depth XPrv
  555 liftXPrv = Icarus
  556 
  557 -- | Unsafe backdoor for constructing an 'Icarus' key from a raw 'XPub'. this is
  558 -- unsafe because it lets the caller choose the actually derivation 'depth'.
  559 --
  560 -- This can be useful however when serializing / deserializing such a type, or to
  561 -- speed up test code (and avoid having to do needless derivations from a master
  562 -- key down to an address key for instance).
  563 --
  564 -- @since 2.0.0
  565 liftXPub :: XPub -> Icarus depth XPub
  566 liftXPub = Icarus
  567 
  568 --
  569 -- Internal
  570 --
  571 
  572 -- Purpose is a constant set to 44' (or 0x8000002C) following the original
  573 -- BIP-44 specification.
  574 --
  575 -- It indicates that the subtree of this node is used according to this
  576 -- specification.
  577 --
  578 -- Hardened derivation is used at this level.
  579 purposeIndex :: Word32
  580 purposeIndex = 0x8000002C
  581 
  582 -- One master node (seed) can be used for unlimited number of independent
  583 -- cryptocoins such as Bitcoin, Litecoin or Namecoin. However, sharing the
  584 -- same space for various cryptocoins has some disadvantages.
  585 --
  586 -- This level creates a separate subtree for every cryptocoin, avoiding reusing
  587 -- addresses across cryptocoins and improving privacy issues.
  588 --
  589 -- Coin type is a constant, set for each cryptocoin. For Cardano this constant
  590 -- is set to 1815' (or 0x80000717). 1815 is the birthyear of our beloved Ada
  591 -- Lovelace.
  592 --
  593 -- Hardened derivation is used at this level.
  594 coinTypeIndex :: Word32
  595 coinTypeIndex = 0x80000717
  596 
  597 -- The minimum seed length for 'generateKeyFromMnemonic' and 'unsafeGenerateKeyFromMnemonic'.
  598 minSeedLengthBytes :: Int
  599 minSeedLengthBytes = 16
  600 
  601 -- Hardware Ledger devices generates keys from mnemonic using a different
  602 -- approach (different from the rest of Cardano).
  603 --
  604 -- It is a combination of:
  605 --
  606 -- - [SLIP 0010](https://github.com/satoshilabs/slips/blob/master/slip-0010.md)
  607 -- - [BIP 0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki)
  608 -- - [BIP 0039](https://github.com/bitcoin/bips/blob/master/bip-0039.mediawiki)
  609 -- - [RFC 8032](https://tools.ietf.org/html/rfc8032#section-5.1.5)
  610 -- - What seems to be arbitrary changes from Ledger regarding the calculation of
  611 --   the initial chain code and generation of the root private key.
  612 unsafeGenerateKeyFromHardwareLedger
  613     :: SomeMnemonic
  614         -- ^ The root mnemonic
  615     -> Icarus 'RootK XPrv
  616 unsafeGenerateKeyFromHardwareLedger (SomeMnemonic mw) = unsafeFromRight $ do
  617     let seed = pbkdf2HmacSha512
  618             $ T.encodeUtf8
  619             $ T.intercalate " "
  620             $ mnemonicToText mw
  621 
  622     -- NOTE
  623     -- SLIP-0010 refers to `iR` as the chain code. Here however, the chain code
  624     -- is obtained as a hash of the initial seed whereas iR is used to make part
  625     -- of the root private key itself.
  626     let cc = hmacSha256 (BS.pack [1] <> seed)
  627     let (iL, iR) = first pruneBuffer $ hashRepeatedly seed
  628 
  629     prv <- maybe (Left "invalid xprv") pure $ xprvFromBytes $ iL <> iR <> cc
  630     pure $ Icarus prv
  631   where
  632     -- Errors yielded in the body of 'unsafeGenerateKeyFromHardwareLedger' are
  633     -- programmer errors (out-of-range byte buffer access or, invalid length for
  634     -- cryptographic operations). Therefore, we throw badly if we encounter any.
  635     unsafeFromRight :: Either String a -> a
  636     unsafeFromRight = either error id
  637 
  638     -- This is the algorithm described in SLIP 0010 for master key generation
  639     -- with an extra step to discard _some_ of the potential private keys. Why
  640     -- this extra step remains a mystery as of today.
  641     --
  642     --      1. Generate a seed byte sequence S of 512 bits according to BIP-0039.
  643     --         (done in a previous step, passed as argument).
  644     --
  645     --      2. Calculate I = HMAC-SHA512(Key = "ed25519 seed", Data = S)
  646     --
  647     --      3. Split I into two 32-byte sequences, IL and IR.
  648     --
  649     -- extra *******************************************************************
  650     -- *                                                                       *
  651     -- *    3.5 If the third highest bit of the last byte of IL is not zero    *
  652     -- *        S = I and go back to step 2.                                   *
  653     -- *                                                                       *
  654     -- *************************************************************************
  655     --
  656     --      4. Use parse256(IL) as master secret key, and IR as master chain code.
  657     hashRepeatedly :: ByteString -> (ByteString, ByteString)
  658     hashRepeatedly bytes = case BS.splitAt 32 (hmacSha512 bytes) of
  659         (iL, iR) | isInvalidKey iL -> hashRepeatedly (iL <> iR)
  660         (iL, iR) -> (iL, iR)
  661       where
  662         isInvalidKey k = testBit (k `BS.index` 31) 5
  663 
  664     -- - Clear the lowest 3 bits of the first byte
  665     -- - Clear the highest bit of the last byte
  666     -- - Set the second highest bit of the last byte
  667     --
  668     -- As described in [RFC 8032 - 5.1.5](https://tools.ietf.org/html/rfc8032#section-5.1.5)
  669     pruneBuffer :: ByteString -> ByteString
  670     pruneBuffer bytes =
  671         let
  672             (firstByte, rest) = fromMaybe (error "pruneBuffer: no first byte") $
  673                 BS.uncons bytes
  674 
  675             (rest', lastByte) = fromMaybe (error "pruneBuffer: no last byte") $
  676                 BS.unsnoc rest
  677 
  678             firstPruned = firstByte
  679                 & (`clearBit` 0)
  680                 & (`clearBit` 1)
  681                 & (`clearBit` 2)
  682 
  683             lastPruned = lastByte
  684                 & (`setBit` 6)
  685                 & (`clearBit` 7)
  686         in
  687             (firstPruned `BS.cons` BS.snoc rest' lastPruned)
  688 
  689     -- As described in [BIP 0039 - From Mnemonic to Seed](https://github.com/bitcoin/bips/blob/master/bip-0039.mediawiki#from-mnemonic-to-seed)
  690     pbkdf2HmacSha512 :: ByteString -> ByteString
  691     pbkdf2HmacSha512 bytes = PBKDF2.generate
  692         (PBKDF2.prfHMAC SHA512)
  693         (PBKDF2.Parameters 2048 64)
  694         bytes
  695         ("mnemonic" :: ByteString)
  696 
  697     hmacSha256 :: ByteString -> ByteString
  698     hmacSha256 =
  699         BA.convert @(HMAC SHA256) . hmac salt
  700 
  701     -- As described in [SLIP 0010 - Master Key Generation](https://github.com/satoshilabs/slips/blob/master/slip-0010.md#master-key-generation)
  702     hmacSha512 :: ByteString -> ByteString
  703     hmacSha512 =
  704         BA.convert @(HMAC SHA512) . hmac salt
  705 
  706     salt :: ByteString
  707     salt = "ed25519 seed"