{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module: Crypto.HDKey.BIP32
-- Copyright: (c) 2025 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- [BIP32](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki)
-- hierarchical deterministic wallets and extended keys, with support for
-- serialization and parsing.

module Crypto.HDKey.BIP32 (
  -- * Hierarchical deterministic keys
    HDKey(..)
  , master

  -- * Extended keys
  , Extended(..)
  , XPub
  , xpub_key
  , xpub_cod
  , XPrv
  , xprv_key
  , xprv_cod
  , X
  , ckd_pub
  , ckd_priv
  , n

  -- * Child derivation via path
  , derive
  , derive_partial

  -- * Serialization
  , xpub
  , xprv
  , tpub
  , tprv

  -- * Parsing
  , parse

  -- * Child key derivation functions
  , derive_child_pub
  , derive_child_priv
  ) where

import Control.Monad (guard)
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Crypto.Hash.SHA512 as SHA512
import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
import qualified Crypto.Curve.Secp256k1 as Secp256k1
import Data.Bits ((.<<.), (.>>.), (.|.), (.&.))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Base58Check as B58C
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Internal as BI
import Data.Word (Word8, Word32)
import GHC.Generics

-- utilities ------------------------------------------------------------------

fi :: (Integral a, Num b) => a -> b
fi :: forall a b. (Integral a, Num b) => a -> b
fi = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE fi #-}

-- big-endian bytestring encoding
unroll :: Integer -> BS.ByteString
unroll :: Integer -> ByteString
unroll Integer
i = case Integer
i of
    Integer
0 -> Word8 -> ByteString
BS.singleton Word8
0
    Integer
_ -> ByteString -> ByteString
BS.reverse (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Integer -> Maybe (Word8, Integer)) -> Integer -> ByteString
forall a. (a -> Maybe (Word8, a)) -> a -> ByteString
BS.unfoldr Integer -> Maybe (Word8, Integer)
forall {b} {a}. (Integral b, Num a, Bits b) => b -> Maybe (a, b)
coalg Integer
i
  where
    coalg :: b -> Maybe (a, b)
coalg b
0 = Maybe (a, b)
forall a. Maybe a
Nothing
    coalg b
m = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (b -> a
forall a b. (Integral a, Num b) => a -> b
fi b
m, b
m b -> Int -> b
forall a. Bits a => a -> Int -> a
.>>. Int
8)

-- parse 32 bytes to a 256-bit integer
parse256 :: BS.ByteString -> Integer
parse256 :: ByteString -> Integer
parse256 bs :: ByteString
bs@(BI.PS ForeignPtr Word8
_ Int
_ Int
l)
    | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32   = (Integer -> Word8 -> Integer) -> Integer -> ByteString -> Integer
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Integer -> Word8 -> Integer
forall {a} {a}. (Integral a, Bits a, Num a) => a -> a -> a
alg Integer
0 ByteString
bs
    | Bool
otherwise = [Char] -> Integer
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip32 (parse256): internal error"
  where
    alg :: a -> a -> a
alg !a
a (a -> a
forall a b. (Integral a, Num b) => a -> b
fi -> !a
b) = (a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
.<<. Int
8) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
b

-- serialize a 256-bit integer to 32 bytes, left-padding with zeros if
-- necessary. the size of the integer is not checked.
ser256 :: Integer -> BS.ByteString
ser256 :: Integer -> ByteString
ser256 (Integer -> ByteString
unroll -> u :: ByteString
u@(BI.PS ForeignPtr Word8
_ Int
_ Int
l))
  | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
32 = Int -> Word8 -> ByteString
BS.replicate (Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Word8
0 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
u
  | Bool
otherwise = ByteString
u

-- serialize a 32-bit word, MSB first
ser32 :: Word32 -> BS.ByteString
ser32 :: Word32 -> ByteString
ser32 Word32
w =
  let !mask :: Word8
mask = Word8
0b00000000_00000000_00000000_11111111
      !w0 :: Word8
w0 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fi (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
.>>. Int
24) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask
      !w1 :: Word8
w1 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fi (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
.>>. Int
16) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask
      !w2 :: Word8
w2 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fi (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
.>>. Int
08) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask
      !w3 :: Word8
w3 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fi Word32
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask
  in  Word8 -> ByteString -> ByteString
BS.cons Word8
w0 (Word8 -> ByteString -> ByteString
BS.cons Word8
w1 (Word8 -> ByteString -> ByteString
BS.cons Word8
w2 (Word8 -> ByteString
BS.singleton Word8
w3)))

-- extended keys --------------------------------------------------------------

-- | An extended public key.
newtype XPub = XPub (X Secp256k1.Projective)
  deriving (XPub -> XPub -> Bool
(XPub -> XPub -> Bool) -> (XPub -> XPub -> Bool) -> Eq XPub
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XPub -> XPub -> Bool
== :: XPub -> XPub -> Bool
$c/= :: XPub -> XPub -> Bool
/= :: XPub -> XPub -> Bool
Eq, Int -> XPub -> ShowS
[XPub] -> ShowS
XPub -> [Char]
(Int -> XPub -> ShowS)
-> (XPub -> [Char]) -> ([XPub] -> ShowS) -> Show XPub
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XPub -> ShowS
showsPrec :: Int -> XPub -> ShowS
$cshow :: XPub -> [Char]
show :: XPub -> [Char]
$cshowList :: [XPub] -> ShowS
showList :: [XPub] -> ShowS
Show, (forall x. XPub -> Rep XPub x)
-> (forall x. Rep XPub x -> XPub) -> Generic XPub
forall x. Rep XPub x -> XPub
forall x. XPub -> Rep XPub x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XPub -> Rep XPub x
from :: forall x. XPub -> Rep XPub x
$cto :: forall x. Rep XPub x -> XPub
to :: forall x. Rep XPub x -> XPub
Generic)

-- | Read the raw public key from an 'XPub'.
xpub_key :: XPub -> Secp256k1.Projective
xpub_key :: XPub -> Projective
xpub_key (XPub (X Projective
pub ByteString
_)) = Projective
pub

-- | Read the raw chain code from an 'XPub'.
xpub_cod :: XPub -> BS.ByteString
xpub_cod :: XPub -> ByteString
xpub_cod (XPub (X Projective
_ ByteString
cod)) = ByteString
cod

-- | An extended private key.
newtype XPrv = XPrv (X Integer)
  deriving (XPrv -> XPrv -> Bool
(XPrv -> XPrv -> Bool) -> (XPrv -> XPrv -> Bool) -> Eq XPrv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XPrv -> XPrv -> Bool
== :: XPrv -> XPrv -> Bool
$c/= :: XPrv -> XPrv -> Bool
/= :: XPrv -> XPrv -> Bool
Eq, Int -> XPrv -> ShowS
[XPrv] -> ShowS
XPrv -> [Char]
(Int -> XPrv -> ShowS)
-> (XPrv -> [Char]) -> ([XPrv] -> ShowS) -> Show XPrv
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XPrv -> ShowS
showsPrec :: Int -> XPrv -> ShowS
$cshow :: XPrv -> [Char]
show :: XPrv -> [Char]
$cshowList :: [XPrv] -> ShowS
showList :: [XPrv] -> ShowS
Show, (forall x. XPrv -> Rep XPrv x)
-> (forall x. Rep XPrv x -> XPrv) -> Generic XPrv
forall x. Rep XPrv x -> XPrv
forall x. XPrv -> Rep XPrv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XPrv -> Rep XPrv x
from :: forall x. XPrv -> Rep XPrv x
$cto :: forall x. Rep XPrv x -> XPrv
to :: forall x. Rep XPrv x -> XPrv
Generic)

-- | Read the raw private key from an 'XPrv'.
xprv_key :: XPrv -> Integer
xprv_key :: XPrv -> Integer
xprv_key (XPrv (X Integer
sec ByteString
_)) = Integer
sec

-- | Read the raw chain code from an 'XPrv'.
xprv_cod :: XPrv -> BS.ByteString
xprv_cod :: XPrv -> ByteString
xprv_cod (XPrv (X Integer
_ ByteString
cod)) = ByteString
cod

-- | A public or private key, extended with a chain code.
data X a = X !a !BS.ByteString
  deriving (X a -> X a -> Bool
(X a -> X a -> Bool) -> (X a -> X a -> Bool) -> Eq (X a)
forall a. Eq a => X a -> X a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => X a -> X a -> Bool
== :: X a -> X a -> Bool
$c/= :: forall a. Eq a => X a -> X a -> Bool
/= :: X a -> X a -> Bool
Eq, Int -> X a -> ShowS
[X a] -> ShowS
X a -> [Char]
(Int -> X a -> ShowS)
-> (X a -> [Char]) -> ([X a] -> ShowS) -> Show (X a)
forall a. Show a => Int -> X a -> ShowS
forall a. Show a => [X a] -> ShowS
forall a. Show a => X a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> X a -> ShowS
showsPrec :: Int -> X a -> ShowS
$cshow :: forall a. Show a => X a -> [Char]
show :: X a -> [Char]
$cshowList :: forall a. Show a => [X a] -> ShowS
showList :: [X a] -> ShowS
Show, (forall x. X a -> Rep (X a) x)
-> (forall x. Rep (X a) x -> X a) -> Generic (X a)
forall x. Rep (X a) x -> X a
forall x. X a -> Rep (X a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (X a) x -> X a
forall a x. X a -> Rep (X a) x
$cfrom :: forall a x. X a -> Rep (X a) x
from :: forall x. X a -> Rep (X a) x
$cto :: forall a x. Rep (X a) x -> X a
to :: forall x. Rep (X a) x -> X a
Generic)

-- | Key types supporting identifier/fingerprint calculation.
--
--   >>> let Just hd = master "my very secret entropy"
--   >>> let Right my_xprv = hd_key hd
--   >>> let my_xpub = n k
--   >>> -- all have the same fingerprint
--   >>> fingerprint hd
--   "G\157\&8\146"
--   >>> fingerprint my_xprv
--   "G\157\&8\146"
--   >>> fingerprint my_xpub
--   "G\157\&8\146"
class Extended k where
  -- | Calculate the identifier for an extended key.
  identifier  :: k -> BS.ByteString

  -- | Calculate the fingerprint of an extended key.
  fingerprint :: k -> BS.ByteString
  fingerprint = Int -> ByteString -> ByteString
BS.take Int
4 (ByteString -> ByteString) -> (k -> ByteString) -> k -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> ByteString
forall k. Extended k => k -> ByteString
identifier

instance Extended XPub where
  identifier :: XPub -> ByteString
identifier (XPub (X Projective
pub ByteString
_)) =
    let ser :: ByteString
ser = Projective -> ByteString
Secp256k1.serialize_point Projective
pub
    in  ByteString -> ByteString
RIPEMD160.hash (ByteString -> ByteString
SHA256.hash ByteString
ser)

instance Extended XPrv where
  identifier :: XPrv -> ByteString
identifier (XPrv (X Integer
sec ByteString
_)) = case Projective -> Integer -> Maybe Projective
Secp256k1.mul Projective
Secp256k1._CURVE_G Integer
sec of
    Maybe Projective
Nothing ->
      [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip32 (identifier): internal error, evil extended key"
    Just Projective
p ->
      let ser :: ByteString
ser = Projective -> ByteString
Secp256k1.serialize_point Projective
p
      in  ByteString -> ByteString
RIPEMD160.hash (ByteString -> ByteString
SHA256.hash ByteString
ser)

-- internal key derivation functions-------------------------------------------

hardened :: Word32 -> Bool
hardened :: Word32 -> Bool
hardened = (Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
0x8000_0000)

-- master xprv from seed
_master :: BS.ByteString -> Maybe XPrv
_master :: ByteString -> Maybe XPrv
_master seed :: ByteString
seed@(BI.PS ForeignPtr Word8
_ Int
_ Int
l)
  | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 = Maybe XPrv
forall a. Maybe a
Nothing
  | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
64 = Maybe XPrv
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      let i :: ByteString
i = ByteString -> ByteString -> ByteString
SHA512.hmac ByteString
"Bitcoin seed" ByteString
seed
          (ByteString
il, ByteString
c) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
i
          s :: Integer
s = ByteString -> Integer
parse256 ByteString
il -- safe due to 512-bit hmac
      XPrv -> Maybe XPrv
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XPrv -> Maybe XPrv) -> XPrv -> Maybe XPrv
forall a b. (a -> b) -> a -> b
$! (X Integer -> XPrv
XPrv (Integer -> ByteString -> X Integer
forall a. a -> ByteString -> X a
X Integer
s ByteString
c))

-- private parent key -> private child key
ckd_priv :: XPrv -> Word32 -> XPrv
ckd_priv :: XPrv -> Word32 -> XPrv
ckd_priv _xprv :: XPrv
_xprv@(XPrv (X Integer
sec ByteString
cod)) Word32
i =
    let l :: ByteString
l = ByteString -> ByteString -> ByteString
SHA512.hmac ByteString
cod ByteString
dat
        (ByteString
il, ByteString
ci) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
l
        pil :: Integer
pil = ByteString -> Integer
parse256 ByteString
il -- safe due to 512-bit hmac
        ki :: Integer
ki  = Integer -> Integer
Secp256k1.modQ (Integer
pil Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
sec)
    in  if   Integer
pil Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
Secp256k1._CURVE_Q Bool -> Bool -> Bool
|| Integer
ki Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -- negl
        then XPrv -> Word32 -> XPrv
ckd_priv XPrv
_xprv (Word32 -> Word32
forall a. Enum a => a -> a
succ Word32
i)
        else X Integer -> XPrv
XPrv (Integer -> ByteString -> X Integer
forall a. a -> ByteString -> X a
X Integer
ki ByteString
ci)
  where
    dat :: ByteString
dat | Word32 -> Bool
hardened Word32
i = Word8 -> ByteString
BS.singleton Word8
0x00 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Integer -> ByteString
ser256 Integer
sec ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word32 -> ByteString
ser32 Word32
i
        | Bool
otherwise  = case Projective -> Integer -> Maybe Projective
Secp256k1.mul Projective
Secp256k1._CURVE_G Integer
sec of
            Maybe Projective
Nothing ->
              [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip32 (ckd_priv): internal error, evil extended key"
            Just Projective
p  -> Projective -> ByteString
Secp256k1.serialize_point Projective
p ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word32 -> ByteString
ser32 Word32
i

-- public parent key -> public child key
ckd_pub :: XPub -> Word32 -> Maybe XPub
ckd_pub :: XPub -> Word32 -> Maybe XPub
ckd_pub _xpub :: XPub
_xpub@(XPub (X Projective
pub ByteString
cod)) Word32
i
  | Word32 -> Bool
hardened Word32
i = Maybe XPub
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      let dat :: ByteString
dat = Projective -> ByteString
Secp256k1.serialize_point Projective
pub ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word32 -> ByteString
ser32 Word32
i
          l :: ByteString
l   = ByteString -> ByteString -> ByteString
SHA512.hmac ByteString
cod ByteString
dat
          (ByteString
il, ByteString
ci) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
l
          pil :: Integer
pil = ByteString -> Integer
parse256 ByteString
il -- safe due to 512-bit hmac
      Projective
pt <- Projective -> Integer -> Maybe Projective
Secp256k1.mul_unsafe Projective
Secp256k1._CURVE_G Integer
pil
      let  ki :: Projective
ki = Projective
pt Projective -> Projective -> Projective
`Secp256k1.add` Projective
pub
      if   Integer
pil Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
Secp256k1._CURVE_Q Bool -> Bool -> Bool
|| Projective
ki Projective -> Projective -> Bool
forall a. Eq a => a -> a -> Bool
== Projective
Secp256k1._CURVE_ZERO -- negl
      then XPub -> Word32 -> Maybe XPub
ckd_pub XPub
_xpub (Word32 -> Word32
forall a. Enum a => a -> a
succ Word32
i)
      else XPub -> Maybe XPub
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (X Projective -> XPub
XPub (Projective -> ByteString -> X Projective
forall a. a -> ByteString -> X a
X Projective
ki ByteString
ci))

-- private parent key -> public child key
n :: XPrv -> XPub
n :: XPrv -> XPub
n (XPrv (X Integer
sec ByteString
cod)) = case Projective -> Integer -> Maybe Projective
Secp256k1.mul Projective
Secp256k1._CURVE_G Integer
sec of
  Maybe Projective
Nothing -> [Char] -> XPub
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip32 (n): internal error, evil extended key"
  Just Projective
p -> X Projective -> XPub
XPub (Projective -> ByteString -> X Projective
forall a. a -> ByteString -> X a
X Projective
p ByteString
cod)

-- hierarchical deterministic keys --------------------------------------------

-- | A BIP32 hierarchical deterministic key.
--
--   This differs from lower-level "extended" keys in that it carries all
--   information required for serialization.
data HDKey = HDKey {
    HDKey -> Either XPub XPrv
hd_key    :: !(Either XPub XPrv) -- ^ extended public or private key
  , HDKey -> Word8
hd_depth  :: !Word8              -- ^ key depth
  , HDKey -> ByteString
hd_parent :: !BS.ByteString      -- ^ parent fingerprint
  , HDKey -> ByteString
hd_child  :: !BS.ByteString      -- ^ index or child number
  }
  deriving (HDKey -> HDKey -> Bool
(HDKey -> HDKey -> Bool) -> (HDKey -> HDKey -> Bool) -> Eq HDKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HDKey -> HDKey -> Bool
== :: HDKey -> HDKey -> Bool
$c/= :: HDKey -> HDKey -> Bool
/= :: HDKey -> HDKey -> Bool
Eq, Int -> HDKey -> ShowS
[HDKey] -> ShowS
HDKey -> [Char]
(Int -> HDKey -> ShowS)
-> (HDKey -> [Char]) -> ([HDKey] -> ShowS) -> Show HDKey
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HDKey -> ShowS
showsPrec :: Int -> HDKey -> ShowS
$cshow :: HDKey -> [Char]
show :: HDKey -> [Char]
$cshowList :: [HDKey] -> ShowS
showList :: [HDKey] -> ShowS
Show, (forall x. HDKey -> Rep HDKey x)
-> (forall x. Rep HDKey x -> HDKey) -> Generic HDKey
forall x. Rep HDKey x -> HDKey
forall x. HDKey -> Rep HDKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HDKey -> Rep HDKey x
from :: forall x. HDKey -> Rep HDKey x
$cto :: forall x. Rep HDKey x -> HDKey
to :: forall x. Rep HDKey x -> HDKey
Generic)

instance Extended HDKey where
  identifier :: HDKey -> ByteString
identifier (HDKey Either XPub XPrv
ekey Word8
_ ByteString
_ ByteString
_) = case Either XPub XPrv
ekey of
    Left XPub
l -> XPub -> ByteString
forall k. Extended k => k -> ByteString
identifier XPub
l
    Right XPrv
r -> XPrv -> ByteString
forall k. Extended k => k -> ByteString
identifier XPrv
r

-- | Derive a master 'HDKey' from a master seed.
--
--   Fails with 'Nothing' if the provided seed has an invalid length.
--
---  >>> let Just hd = master "my very secret entropy"
--   >>> xpub hd
--   "xpub661MyMwAqRbcGTJPtZRqZyrvjxHCfhqXeiqb5GVU3EGuFBy4QxT3yt8iiHwZTiCzZFyuyNiqXB3eqzqFZ8z4L6HCrPSkDVFNuW59LXYvMjs"
master :: BS.ByteString -> Maybe HDKey
master :: ByteString -> Maybe HDKey
master ByteString
seed = do
  XPrv
m <- ByteString -> Maybe XPrv
_master ByteString
seed
  HDKey -> Maybe HDKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HDKey -> Maybe HDKey) -> HDKey -> Maybe HDKey
forall a b. (a -> b) -> a -> b
$! HDKey {
      hd_key :: Either XPub XPrv
hd_key = XPrv -> Either XPub XPrv
forall a b. b -> Either a b
Right XPrv
m
    , hd_depth :: Word8
hd_depth = Word8
0
    , hd_parent :: ByteString
hd_parent = ByteString
"\NUL\NUL\NUL\NUL" -- 0x0000_0000
    , hd_child :: ByteString
hd_child = Word32 -> ByteString
ser32 Word32
0
    }

-- | Derive a private child node at the provided index.
--
--   Fails with 'Nothing' if derivation is impossible.
--
--   >>> let Just child_prv = derive_child_priv hd 0
--   >>> xpub child_prv
--   "xpub68R2ZbtFeJTFJApdEdPqW5cy3d5wF96tTfJErhu3mTi2Ttaqvc88BMPrgS3hQSrHj91kRbzVLM9pue9f8219szRKZuTAx1LWbdLDLFDm6Ly"
derive_child_priv :: HDKey -> Word32 -> Maybe HDKey
derive_child_priv :: HDKey -> Word32 -> Maybe HDKey
derive_child_priv HDKey {Word8
Either XPub XPrv
ByteString
hd_key :: HDKey -> Either XPub XPrv
hd_depth :: HDKey -> Word8
hd_parent :: HDKey -> ByteString
hd_child :: HDKey -> ByteString
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..} Word32
i = case Either XPub XPrv
hd_key of
  Left XPub
_ -> Maybe HDKey
forall a. Maybe a
Nothing
  Right XPrv
_xprv -> HDKey -> Maybe HDKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HDKey -> Maybe HDKey) -> HDKey -> Maybe HDKey
forall a b. (a -> b) -> a -> b
$!
    let key :: Either a XPrv
key   = XPrv -> Either a XPrv
forall a b. b -> Either a b
Right (XPrv -> Word32 -> XPrv
ckd_priv XPrv
_xprv Word32
i)
        depth :: Word8
depth = Word8
hd_depth Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1
        parent :: ByteString
parent = XPrv -> ByteString
forall k. Extended k => k -> ByteString
fingerprint XPrv
_xprv
        child :: ByteString
child = Word32 -> ByteString
ser32 Word32
i
    in  Either XPub XPrv -> Word8 -> ByteString -> ByteString -> HDKey
HDKey Either XPub XPrv
forall {a}. Either a XPrv
key Word8
depth ByteString
parent ByteString
child

-- | Derive a public child node at the provided index.
--
--   Fails with 'Nothing' if derivation is impossible.
--
--   >>> :set -XNumericUnderscores
--   >>> let Just child_pub = derive_child_pub child_prv 0x8000_0000
--   >>> xpub child_pub
--   "xpub6B6LoU83Cpyx1UVMwuoQdQvY2BuGbPd2xsEVxCnj85UGgDN9bRz82hQhe9UFmyo4Pokuhjc8M1Cfc8ufLxcL6FkCF7Zc2eajEfWfZwMFF6X"
derive_child_pub :: HDKey -> Word32 -> Maybe HDKey
derive_child_pub :: HDKey -> Word32 -> Maybe HDKey
derive_child_pub HDKey {Word8
Either XPub XPrv
ByteString
hd_key :: HDKey -> Either XPub XPrv
hd_depth :: HDKey -> Word8
hd_parent :: HDKey -> ByteString
hd_child :: HDKey -> ByteString
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..} Word32
i = do
  (XPub
key, ByteString
parent) <- case Either XPub XPrv
hd_key of
    Left XPub
_xpub  -> do
      XPub
pub <- XPub -> Word32 -> Maybe XPub
ckd_pub XPub
_xpub Word32
i
      (XPub, ByteString) -> Maybe (XPub, ByteString)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((XPub, ByteString) -> Maybe (XPub, ByteString))
-> (XPub, ByteString) -> Maybe (XPub, ByteString)
forall a b. (a -> b) -> a -> b
$! (XPub
pub, XPub -> ByteString
forall k. Extended k => k -> ByteString
fingerprint XPub
_xpub)
    Right XPrv
_xprv ->
      let pub :: XPub
pub = XPrv -> XPub
n (XPrv -> Word32 -> XPrv
ckd_priv XPrv
_xprv Word32
i)
      in  (XPub, ByteString) -> Maybe (XPub, ByteString)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((XPub, ByteString) -> Maybe (XPub, ByteString))
-> (XPub, ByteString) -> Maybe (XPub, ByteString)
forall a b. (a -> b) -> a -> b
$! (XPub
pub, XPrv -> ByteString
forall k. Extended k => k -> ByteString
fingerprint XPrv
_xprv)
  let depth :: Word8
depth = Word8
hd_depth Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1
      child :: ByteString
child = Word32 -> ByteString
ser32 Word32
i
  HDKey -> Maybe HDKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HDKey -> Maybe HDKey) -> HDKey -> Maybe HDKey
forall a b. (a -> b) -> a -> b
$! Either XPub XPrv -> Word8 -> ByteString -> ByteString -> HDKey
HDKey (XPub -> Either XPub XPrv
forall a b. a -> Either a b
Left XPub
key) Word8
depth ByteString
parent ByteString
child

-- derivation path expression -------------------------------------------------

-- recursive derivation path
data Path =
    M
  | !Path :| !Word32 -- hardened
  | !Path :/ !Word32
  deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
/= :: Path -> Path -> Bool
Eq, Int -> Path -> ShowS
[Path] -> ShowS
Path -> [Char]
(Int -> Path -> ShowS)
-> (Path -> [Char]) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Path -> ShowS
showsPrec :: Int -> Path -> ShowS
$cshow :: Path -> [Char]
show :: Path -> [Char]
$cshowList :: [Path] -> ShowS
showList :: [Path] -> ShowS
Show)

parse_path :: BS.ByteString -> Maybe Path
parse_path :: ByteString -> Maybe Path
parse_path ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs of
    Maybe (Word8, ByteString)
Nothing -> Maybe Path
forall a. Maybe a
Nothing
    Just (Word8
h, ByteString
t)
      | Word8
h Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
109  -> Path -> ByteString -> Maybe Path
go Path
M ByteString
t -- == 'm'
      | Bool
otherwise -> Maybe Path
forall a. Maybe a
Nothing
  where
    child :: Path -> BS.ByteString -> Maybe (Path, BS.ByteString)
    child :: Path -> ByteString -> Maybe (Path, ByteString)
child Path
pat ByteString
b = case ByteString -> Maybe (Int, ByteString)
B8.readInt ByteString
b of
      Maybe (Int, ByteString)
Nothing -> Maybe (Path, ByteString)
forall a. Maybe a
Nothing
      Just (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fi -> Word32
i, ByteString
etc) -> case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
etc of
        Maybe (Word8, ByteString)
Nothing -> (Path, ByteString) -> Maybe (Path, ByteString)
forall a. a -> Maybe a
Just ((Path, ByteString) -> Maybe (Path, ByteString))
-> (Path, ByteString) -> Maybe (Path, ByteString)
forall a b. (a -> b) -> a -> b
$! (Path
pat Path -> Word32 -> Path
:/ Word32
i, ByteString
forall a. Monoid a => a
mempty)
        Just (Word8
h, ByteString
t)
          | Word8
h Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
39 -> (Path, ByteString) -> Maybe (Path, ByteString)
forall a. a -> Maybe a
Just ((Path, ByteString) -> Maybe (Path, ByteString))
-> (Path, ByteString) -> Maybe (Path, ByteString)
forall a b. (a -> b) -> a -> b
$! (Path
pat Path -> Word32 -> Path
:| Word32
i, ByteString
t) -- '
          | Bool
otherwise -> (Path, ByteString) -> Maybe (Path, ByteString)
forall a. a -> Maybe a
Just ((Path, ByteString) -> Maybe (Path, ByteString))
-> (Path, ByteString) -> Maybe (Path, ByteString)
forall a b. (a -> b) -> a -> b
$! (Path
pat Path -> Word32 -> Path
:/ Word32
i, ByteString
etc)

    go :: Path -> ByteString -> Maybe Path
go Path
pat ByteString
b = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
b of
      Maybe (Word8, ByteString)
Nothing -> Path -> Maybe Path
forall a. a -> Maybe a
Just Path
pat
      Just (Word8
h, ByteString
t)
        | Word8
h Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
47 -> do -- /
            (Path
npat, ByteString
etc) <- Path -> ByteString -> Maybe (Path, ByteString)
child Path
pat ByteString
t
            Path -> ByteString -> Maybe Path
go Path
npat ByteString
etc
        | Bool
otherwise ->
            Maybe Path
forall a. Maybe a
Nothing

-- | Derive a child node via the provided derivation path.
--
--   Fails with 'Nothing' if derivation is impossible, or if the
--   provided path is invalid.
--
--   >>> let Just hd = master "my very secret master seed"
--   >>> let Just child = derive hd "m/44'/0'/0'/0/0"
--   >>> xpub child
--   "xpub6FvaeGNFmCkLky6jwefrUfyH7gCGSAUckRBANT6wLQkm4eWZApsf4LqAadtbM8EBFfuKGFgzhgta4ByP6xnBodk2EV7BiwxCPLgu13oYWGp"
derive
  :: HDKey
  -> BS.ByteString -- ^ derivation path
  -> Maybe HDKey
derive :: HDKey -> ByteString -> Maybe HDKey
derive HDKey
hd ByteString
pat = case ByteString -> Maybe Path
parse_path ByteString
pat of
    Maybe Path
Nothing -> Maybe HDKey
forall a. Maybe a
Nothing
    Just Path
p  -> Path -> Maybe HDKey
go Path
p
  where
    go :: Path -> Maybe HDKey
go = \case
      Path
M -> HDKey -> Maybe HDKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HDKey
hd
      Path
p :| Word32
i -> do
        HDKey
hdkey <- Path -> Maybe HDKey
go Path
p
        HDKey -> Word32 -> Maybe HDKey
derive_child_priv HDKey
hdkey (Word32
0x8000_0000 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
i) -- 2 ^ 31
      Path
p :/ Word32
i -> do
        HDKey
hdkey <- Path -> Maybe HDKey
go Path
p
        HDKey -> Word32 -> Maybe HDKey
derive_child_priv HDKey
hdkey Word32
i

-- | Derive a child node via the provided derivation path.
--
--   Fails with 'error' if derivation is impossible, or if the provided
--   path is invalid.
--
--   >>> let other_child = derive_partial hd "m/44'/0'/0'/0/1"
--   >>> xpub other_child
--   "xpub6FvaeGNFmCkLpkT3uahJnGPTfEX62PtH7uZAyjtru8S2FvPuYTQKn8ct6CNQAwHMXaGN6EYuwi1Tz2VD7msftH8VTAtzgNra9CForA9FBP4"
derive_partial
  :: HDKey
  -> BS.ByteString
  -> HDKey
derive_partial :: HDKey -> ByteString -> HDKey
derive_partial HDKey
hd ByteString
pat = case HDKey -> ByteString -> Maybe HDKey
derive HDKey
hd ByteString
pat of
  Maybe HDKey
Nothing -> [Char] -> HDKey
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip32 (derive_partial): couldn't derive extended key"
  Just HDKey
hdkey -> HDKey
hdkey

-- serialization --------------------------------------------------------------

_MAINNET_PUB, _MAINNET_PRV :: Word32
_TESTNET_PUB, _TESTNET_PRV :: Word32

_MAINNET_PUB_BYTES, _MAINNET_PRV_BYTES :: BS.ByteString
_TESTNET_PUB_BYTES, _TESTNET_PRV_BYTES :: BS.ByteString

_MAINNET_PUB :: Word32
_MAINNET_PUB = Word32
0x0488B21E
_MAINNET_PUB_BYTES :: ByteString
_MAINNET_PUB_BYTES = ByteString
"\EOT\136\178\RS"

_MAINNET_PRV :: Word32
_MAINNET_PRV = Word32
0x0488ADE4
_MAINNET_PRV_BYTES :: ByteString
_MAINNET_PRV_BYTES = ByteString
"\EOT\136\173\228"

_TESTNET_PUB :: Word32
_TESTNET_PUB = Word32
0x043587CF
_TESTNET_PUB_BYTES :: ByteString
_TESTNET_PUB_BYTES = ByteString
"\EOT5\135\207"

_TESTNET_PRV :: Word32
_TESTNET_PRV = Word32
0x04358394
_TESTNET_PRV_BYTES :: ByteString
_TESTNET_PRV_BYTES = ByteString
"\EOT5\131\148"

-- | Serialize a mainnet extended public key in base58check format.
--
--   >>> let Just hd = master "my very secret entropy"
--   >>> xpub hd
--   "xpub661MyMwAqRbcGTJPtZRqZyrvjxHCfhqXeiqb5GVU3EGuFBy4QxT3yt8iiHwZTiCzZFyuyNiqXB3eqzqFZ8z4L6HCrPSkDVFNuW59LXYvMjs"
xpub :: HDKey -> BS.ByteString
xpub :: HDKey -> ByteString
xpub x :: HDKey
x@HDKey {Word8
Either XPub XPrv
ByteString
hd_key :: HDKey -> Either XPub XPrv
hd_depth :: HDKey -> Word8
hd_parent :: HDKey -> ByteString
hd_child :: HDKey -> ByteString
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..} = ByteString -> ByteString
B58C.encode (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
  case Either XPub XPrv
hd_key of
    Left XPub
_  -> Word32 -> HDKey -> Builder
_serialize Word32
_MAINNET_PUB HDKey
x
    Right XPrv
e -> Word32 -> HDKey -> Builder
_serialize Word32
_MAINNET_PUB HDKey {
        hd_key :: Either XPub XPrv
hd_key = XPub -> Either XPub XPrv
forall a b. a -> Either a b
Left (XPrv -> XPub
n XPrv
e)
      , Word8
ByteString
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..
      }

-- | Serialize a mainnet extended private key in base58check format.
--
--   >>> xprv hd
--   Just "xprv9s21ZrQH143K3yDvnXtqCqvCBvSiGF7gHVuzGt5rUtjvNPdusR8oS5pErywDM1jDDTcLpNNCbg9a9NuidBczRzSUp7seDeu8am64h6nfdrg"
xprv :: HDKey -> Maybe BS.ByteString
xprv :: HDKey -> Maybe ByteString
xprv x :: HDKey
x@HDKey {Word8
Either XPub XPrv
ByteString
hd_key :: HDKey -> Either XPub XPrv
hd_depth :: HDKey -> Word8
hd_parent :: HDKey -> ByteString
hd_child :: HDKey -> ByteString
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..} = case Either XPub XPrv
hd_key of
  Left XPub
_  -> Maybe ByteString
forall a. Maybe a
Nothing
  Right XPrv
_ -> do
    let ser :: Builder
ser = Word32 -> HDKey -> Builder
_serialize Word32
_MAINNET_PRV HDKey
x
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! (ByteString -> ByteString
B58C.encode (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString) Builder
ser

-- | Serialize a testnet extended public key in base58check format.
--
--   >>> tpub hd
--   "tpubD6NzVbkrYhZ4YFVFLkQvmuCJ55Nrf6LbCMRtRpYcP92nzUdmVBJ98KoYxL2LzDAEMAWpaxEi4GshYBKrwzqJDXjVuzC3u1ucVTfZ6ZD415x"
tpub :: HDKey -> BS.ByteString
tpub :: HDKey -> ByteString
tpub x :: HDKey
x@HDKey {Word8
Either XPub XPrv
ByteString
hd_key :: HDKey -> Either XPub XPrv
hd_depth :: HDKey -> Word8
hd_parent :: HDKey -> ByteString
hd_child :: HDKey -> ByteString
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..} = ByteString -> ByteString
B58C.encode (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
  case Either XPub XPrv
hd_key of
    Left XPub
_  -> Word32 -> HDKey -> Builder
_serialize Word32
_TESTNET_PUB HDKey
x
    Right XPrv
e -> Word32 -> HDKey -> Builder
_serialize Word32
_TESTNET_PUB HDKey {
      hd_key :: Either XPub XPrv
hd_key = XPub -> Either XPub XPrv
forall a b. a -> Either a b
Left (XPrv -> XPub
n XPrv
e)
      , Word8
ByteString
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..
      }

-- | Serialize a testnet extended private key in base58check format.
--
--   >>> tprv hd
--   Just "tprv8ZgxMBicQKsPenTTT6kLNVYBW3rvVm9gd3q79JWJxsEQ9zNzrnUYwqBgnA6sMP7Xau97pTyxm2jNcETTkPxwF3i5Lm5wt1dBVrqV8kKi5v5"
tprv :: HDKey -> Maybe BS.ByteString
tprv :: HDKey -> Maybe ByteString
tprv x :: HDKey
x@HDKey {Word8
Either XPub XPrv
ByteString
hd_key :: HDKey -> Either XPub XPrv
hd_depth :: HDKey -> Word8
hd_parent :: HDKey -> ByteString
hd_child :: HDKey -> ByteString
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..} = case Either XPub XPrv
hd_key of
  Left XPub
_  -> Maybe ByteString
forall a. Maybe a
Nothing
  Right XPrv
_ -> do
    let ser :: Builder
ser = Word32 -> HDKey -> Builder
_serialize Word32
_TESTNET_PRV HDKey
x
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! (ByteString -> ByteString
B58C.encode (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString) Builder
ser

_serialize :: Word32 -> HDKey -> BSB.Builder
_serialize :: Word32 -> HDKey -> Builder
_serialize Word32
version HDKey {Word8
Either XPub XPrv
ByteString
hd_key :: HDKey -> Either XPub XPrv
hd_depth :: HDKey -> Word8
hd_parent :: HDKey -> ByteString
hd_child :: HDKey -> ByteString
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..} =
     Word32 -> Builder
BSB.word32BE Word32
version
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
BSB.word8 Word8
hd_depth
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.byteString ByteString
hd_parent
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.byteString ByteString
hd_child
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> case Either XPub XPrv
hd_key of
       Left (XPub (X Projective
pub ByteString
cod)) ->
            ByteString -> Builder
BSB.byteString ByteString
cod
         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.byteString (Projective -> ByteString
Secp256k1.serialize_point Projective
pub)
       Right (XPrv (X Integer
sec ByteString
cod)) ->
            ByteString -> Builder
BSB.byteString ByteString
cod
         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
BSB.word8 Word8
0x00
         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.byteString (Integer -> ByteString
ser256 Integer
sec)

-- parsing --------------------------------------------------------------------

data KeyType =
    Pub
  | Prv

-- | Parse a base58check-encoded 'ByteString' into a 'HDKey'.
--
--   Fails with 'Nothing' if the provided key is invalid.
--
--   >>> let Just hd = master "my very secret entropy"
--   >>> let Just my_xprv = parse (xprv hd)
--   >>> my_xprv == hd
--   True
parse :: BS.ByteString -> Maybe HDKey
parse :: ByteString -> Maybe HDKey
parse ByteString
b58 = do
    ByteString
bs <- ByteString -> Maybe ByteString
B58C.decode ByteString
b58
    case Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
4 ByteString
bs of
      (ByteString
version, ByteString
etc)
        | ByteString
version ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
_MAINNET_PUB_BYTES Bool -> Bool -> Bool
|| ByteString
version ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
_TESTNET_PUB_BYTES ->
            ByteString -> Maybe HDKey
parse_pub ByteString
etc
        | ByteString
version ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
_MAINNET_PRV_BYTES Bool -> Bool -> Bool
|| ByteString
version ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
_TESTNET_PRV_BYTES ->
            ByteString -> Maybe HDKey
parse_prv ByteString
etc
        | Bool
otherwise ->
            Maybe HDKey
forall a. Maybe a
Nothing
  where
    parse_pub :: ByteString -> Maybe HDKey
parse_pub = KeyType -> ByteString -> Maybe HDKey
_parse KeyType
Pub
    parse_prv :: ByteString -> Maybe HDKey
parse_prv = KeyType -> ByteString -> Maybe HDKey
_parse KeyType
Prv

    _parse :: KeyType -> ByteString -> Maybe HDKey
_parse KeyType
ktype ByteString
bs = do
      (Word8
hd_depth, ByteString
etc0) <- ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs
      let (ByteString
hd_parent, ByteString
etc1) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
4 ByteString
etc0
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
hd_parent Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4)
      let (ByteString
hd_child, ByteString
etc2) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
4 ByteString
etc1
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
hd_child Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4)
      let (ByteString
cod, ByteString
etc3) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
etc2
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
cod Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32)
      let (ByteString
key, ByteString
etc4) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
33 ByteString
etc3
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
key Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
33)
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
etc4 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
      HDKey
hd <- case KeyType
ktype of
        KeyType
Pub -> do
          Projective
pub <- ByteString -> Maybe Projective
Secp256k1.parse_point ByteString
key
          let hd_key :: Either XPub b
hd_key = XPub -> Either XPub b
forall a b. a -> Either a b
Left (X Projective -> XPub
XPub (Projective -> ByteString -> X Projective
forall a. a -> ByteString -> X a
X Projective
pub ByteString
cod))
          HDKey -> Maybe HDKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HDKey {Word8
Either XPub XPrv
ByteString
forall {b}. Either XPub b
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
hd_key :: forall {b}. Either XPub b
..}
        KeyType
Prv -> do
          (Word8
b, ByteString -> Integer
parse256 -> Integer
prv) <- ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
key -- safe due to guarded keylen
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0)
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
prv Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
prv Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
Secp256k1._CURVE_Q)
          let hd_key :: Either a XPrv
hd_key = XPrv -> Either a XPrv
forall a b. b -> Either a b
Right (X Integer -> XPrv
XPrv (Integer -> ByteString -> X Integer
forall a. a -> ByteString -> X a
X Integer
prv ByteString
cod))
          HDKey -> Maybe HDKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HDKey {Word8
Either XPub XPrv
ByteString
forall {a}. Either a XPrv
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
hd_key :: forall {a}. Either a XPrv
..}
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (HDKey -> Bool
valid_lineage HDKey
hd)
      HDKey -> Maybe HDKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HDKey
hd
    {-# INLINE _parse #-}

valid_lineage :: HDKey -> Bool
valid_lineage :: HDKey -> Bool
valid_lineage HDKey {Word8
Either XPub XPrv
ByteString
hd_key :: HDKey -> Either XPub XPrv
hd_depth :: HDKey -> Word8
hd_parent :: HDKey -> ByteString
hd_child :: HDKey -> ByteString
hd_key :: Either XPub XPrv
hd_depth :: Word8
hd_parent :: ByteString
hd_child :: ByteString
..}
  | Word8
hd_depth Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 =
         ByteString
hd_parent ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"\NUL\NUL\NUL\NUL"
      Bool -> Bool -> Bool
&& ByteString
hd_child ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"\NUL\NUL\NUL\NUL"
  | Bool
otherwise = Bool
True