{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UnboxedTuples #-}
{-# 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

  -- * Fast wNAF variants
  , Context
  , precompute
  , ckd_priv'
  , ckd_pub'
  , n'
  , derive'
  , derive_partial'
  , derive_child_priv'
  , derive_child_pub'
  ) 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 qualified Data.ByteString.Unsafe as BU
import qualified Data.Choice as C
import Data.Word (Word8, Word32)
import Data.Word.Limb (Limb(..))
import qualified Data.Word.Limb as L
import Data.Word.Wider (Wider(..))
import qualified Data.Word.Wider as W
import qualified Foreign.Storable as Storable (pokeByteOff)
import qualified GHC.Exts as Exts
import GHC.Generics
import qualified GHC.Word (Word8(..))
import qualified Numeric.Montgomery.Secp256k1.Scalar as S

-- | Precomputed multiples of the secp256k1 generator point, for faster
--   scalar multiplication.
type Context = Secp256k1.Context

-- | Create a secp256k1 context by precomputing multiples of the curve's
--   generator point.
--
--   This should be computed once and reused for all derivations.
--
--   >>> let !ctx = precompute
--   >>> derive' ctx hd "m/44'/0'/0'/0/0"
precompute :: Context
precompute :: Context
precompute = Context
Secp256k1.precompute

-- parsing utilities ----------------------------------------------------------

-- convert a Word8 to a Limb
limb :: Word8 -> Limb
limb :: Word8 -> Limb
limb (GHC.Word.W8# (Word8# -> Word#
Exts.word8ToWord# -> Word#
w)) = Word# -> Limb
Limb Word#
w
{-# INLINABLE limb #-}

-- convert a Limb to a Word8
word8 :: Limb -> Word8
word8 :: Limb -> Word8
word8 (Limb Word#
w) = Word8# -> Word8
GHC.Word.W8# (Word# -> Word8#
Exts.wordToWord8# Word#
w)
{-# INLINABLE word8 #-}

-- unsafely extract the first 64-bit word from a big-endian-encoded bytestring
unsafe_word0 :: BS.ByteString -> Limb
unsafe_word0 :: ByteString -> Limb
unsafe_word0 ByteString
bs =
          (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
00) Limb -> Int# -> Limb
`L.shl#` Int#
56#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
01) Limb -> Int# -> Limb
`L.shl#` Int#
48#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
02) Limb -> Int# -> Limb
`L.shl#` Int#
40#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
03) Limb -> Int# -> Limb
`L.shl#` Int#
32#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
04) Limb -> Int# -> Limb
`L.shl#` Int#
24#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
05) Limb -> Int# -> Limb
`L.shl#` Int#
16#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
06) Limb -> Int# -> Limb
`L.shl#` Int#
08#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
07))
{-# INLINABLE unsafe_word0 #-}

-- unsafely extract the second 64-bit word from a big-endian-encoded bytestring
unsafe_word1 :: BS.ByteString -> Limb
unsafe_word1 :: ByteString -> Limb
unsafe_word1 ByteString
bs =
          (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
08) Limb -> Int# -> Limb
`L.shl#` Int#
56#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
09) Limb -> Int# -> Limb
`L.shl#` Int#
48#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
10) Limb -> Int# -> Limb
`L.shl#` Int#
40#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
11) Limb -> Int# -> Limb
`L.shl#` Int#
32#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
12) Limb -> Int# -> Limb
`L.shl#` Int#
24#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
13) Limb -> Int# -> Limb
`L.shl#` Int#
16#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
14) Limb -> Int# -> Limb
`L.shl#` Int#
08#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
15))
{-# INLINABLE unsafe_word1 #-}

-- unsafely extract the third 64-bit word from a big-endian-encoded bytestring
unsafe_word2 :: BS.ByteString -> Limb
unsafe_word2 :: ByteString -> Limb
unsafe_word2 ByteString
bs =
          (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
16) Limb -> Int# -> Limb
`L.shl#` Int#
56#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
17) Limb -> Int# -> Limb
`L.shl#` Int#
48#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
18) Limb -> Int# -> Limb
`L.shl#` Int#
40#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
19) Limb -> Int# -> Limb
`L.shl#` Int#
32#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
20) Limb -> Int# -> Limb
`L.shl#` Int#
24#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
21) Limb -> Int# -> Limb
`L.shl#` Int#
16#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
22) Limb -> Int# -> Limb
`L.shl#` Int#
08#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
23))
{-# INLINABLE unsafe_word2 #-}

-- unsafely extract the fourth 64-bit word from a big-endian-encoded bytestring
unsafe_word3 :: BS.ByteString -> Limb
unsafe_word3 :: ByteString -> Limb
unsafe_word3 ByteString
bs =
          (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
24) Limb -> Int# -> Limb
`L.shl#` Int#
56#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
25) Limb -> Int# -> Limb
`L.shl#` Int#
48#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
26) Limb -> Int# -> Limb
`L.shl#` Int#
40#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
27) Limb -> Int# -> Limb
`L.shl#` Int#
32#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
28) Limb -> Int# -> Limb
`L.shl#` Int#
24#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
29) Limb -> Int# -> Limb
`L.shl#` Int#
16#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
30) Limb -> Int# -> Limb
`L.shl#` Int#
08#)
  Limb -> Limb -> Limb
`L.or#` (Word8 -> Limb
limb (ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
31))
{-# INLINABLE unsafe_word3 #-}

-- 256-bit big-endian bytestring decoding. the input size is not checked!
unsafe_roll32 :: BS.ByteString -> Wider
unsafe_roll32 :: ByteString -> Wider
unsafe_roll32 ByteString
bs =
  let !w0 :: Limb
w0 = ByteString -> Limb
unsafe_word0 ByteString
bs
      !w1 :: Limb
w1 = ByteString -> Limb
unsafe_word1 ByteString
bs
      !w2 :: Limb
w2 = ByteString -> Limb
unsafe_word2 ByteString
bs
      !w3 :: Limb
w3 = ByteString -> Limb
unsafe_word3 ByteString
bs
  in  Limb4 -> Wider
Wider (# Limb
w3, Limb
w2, Limb
w1, Limb
w0 #)
{-# INLINABLE unsafe_roll32 #-}

-- convert a Limb to a Word8 after right-shifting
word8s :: Limb -> Exts.Int# -> Word8
word8s :: Limb -> Int# -> Word8
word8s Limb
l Int#
s =
  let !(Limb Word#
w) = Limb -> Int# -> Limb
L.shr# Limb
l Int#
s
  in  Word8# -> Word8
GHC.Word.W8# (Word# -> Word8#
Exts.wordToWord8# Word#
w)
{-# INLINABLE word8s #-}

-- 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 #-}

-- 256-bit big-endian bytestring encoding
unroll32 :: Wider -> BS.ByteString
unroll32 :: Wider -> ByteString
unroll32 (Wider (# Limb
w0, Limb
w1, Limb
w2, Limb
w3 #)) =
  Int -> (Ptr Word8 -> IO ()) -> ByteString
BI.unsafeCreate Int
32 ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
    -- w0
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
00 (Limb -> Int# -> Word8
word8s Limb
w3 Int#
56#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
01 (Limb -> Int# -> Word8
word8s Limb
w3 Int#
48#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
02 (Limb -> Int# -> Word8
word8s Limb
w3 Int#
40#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
03 (Limb -> Int# -> Word8
word8s Limb
w3 Int#
32#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
04 (Limb -> Int# -> Word8
word8s Limb
w3 Int#
24#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
05 (Limb -> Int# -> Word8
word8s Limb
w3 Int#
16#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
06 (Limb -> Int# -> Word8
word8s Limb
w3 Int#
08#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
07 (Limb -> Word8
word8 Limb
w3)
    -- w1
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
08 (Limb -> Int# -> Word8
word8s Limb
w2 Int#
56#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
09 (Limb -> Int# -> Word8
word8s Limb
w2 Int#
48#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
10 (Limb -> Int# -> Word8
word8s Limb
w2 Int#
40#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
11 (Limb -> Int# -> Word8
word8s Limb
w2 Int#
32#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
12 (Limb -> Int# -> Word8
word8s Limb
w2 Int#
24#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
13 (Limb -> Int# -> Word8
word8s Limb
w2 Int#
16#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
14 (Limb -> Int# -> Word8
word8s Limb
w2 Int#
08#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
15 (Limb -> Word8
word8 Limb
w2)
    -- w2
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
16 (Limb -> Int# -> Word8
word8s Limb
w1 Int#
56#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
17 (Limb -> Int# -> Word8
word8s Limb
w1 Int#
48#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
18 (Limb -> Int# -> Word8
word8s Limb
w1 Int#
40#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
19 (Limb -> Int# -> Word8
word8s Limb
w1 Int#
32#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
20 (Limb -> Int# -> Word8
word8s Limb
w1 Int#
24#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
21 (Limb -> Int# -> Word8
word8s Limb
w1 Int#
16#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
22 (Limb -> Int# -> Word8
word8s Limb
w1 Int#
08#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
23 (Limb -> Word8
word8 Limb
w1)
    -- w3
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
24 (Limb -> Int# -> Word8
word8s Limb
w0 Int#
56#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
25 (Limb -> Int# -> Word8
word8s Limb
w0 Int#
48#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
26 (Limb -> Int# -> Word8
word8s Limb
w0 Int#
40#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
27 (Limb -> Int# -> Word8
word8s Limb
w0 Int#
32#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
28 (Limb -> Int# -> Word8
word8s Limb
w0 Int#
24#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
29 (Limb -> Int# -> Word8
word8s Limb
w0 Int#
16#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
30 (Limb -> Int# -> Word8
word8s Limb
w0 Int#
08#)
    Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
Storable.pokeByteOff Ptr Word8
ptr Int
31 (Limb -> Word8
word8 Limb
w0)
{-# INLINABLE unroll32 #-}

-- 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 -> String
(Int -> XPub -> ShowS)
-> (XPub -> String) -> ([XPub] -> ShowS) -> Show XPub
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XPub -> ShowS
showsPrec :: Int -> XPub -> ShowS
$cshow :: XPub -> String
show :: XPub -> String
$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 Wider)
  deriving (Int -> XPrv -> ShowS
[XPrv] -> ShowS
XPrv -> String
(Int -> XPrv -> ShowS)
-> (XPrv -> String) -> ([XPrv] -> ShowS) -> Show XPrv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XPrv -> ShowS
showsPrec :: Int -> XPrv -> ShowS
$cshow :: XPrv -> String
show :: XPrv -> String
$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 -> Wider
xprv_key :: XPrv -> Wider
xprv_key (XPrv (X Wider
sec ByteString
_)) = Wider
sec

-- | Read the raw chain code from an 'XPrv'.
xprv_cod :: XPrv -> BS.ByteString
xprv_cod :: XPrv -> ByteString
xprv_cod (XPrv (X Wider
_ 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 -> String
(Int -> X a -> ShowS)
-> (X a -> String) -> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
show :: X a -> String
$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 Wider
sec ByteString
_)) = case Projective -> Wider -> Maybe Projective
Secp256k1.mul Projective
Secp256k1._CURVE_G Wider
sec of
    Maybe Projective
Nothing ->
      String -> ByteString
forall a. HasCallStack => String -> a
error String
"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 SHA512.MAC ByteString
i = ByteString -> ByteString -> MAC
SHA512.hmac ByteString
"Bitcoin seed" ByteString
seed
          (ByteString
il, ByteString
c) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
i
          s :: Wider
s = ByteString -> Wider
unsafe_roll32 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 Wider -> XPrv
XPrv (Wider -> ByteString -> X Wider
forall a. a -> ByteString -> X a
X Wider
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 Wider
sec ByteString
cod)) Word32
i =
    let SHA512.MAC ByteString
l = ByteString -> ByteString -> MAC
SHA512.hmac ByteString
cod ByteString
dat
        (ByteString
il, ByteString
ci) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
l
        pil :: Wider
pil = ByteString -> Wider
unsafe_roll32 ByteString
il -- safe due to 512-bit hmac
        ki :: Wider
ki  = Montgomery -> Wider
S.from (Wider -> Montgomery
S.to Wider
pil Montgomery -> Montgomery -> Montgomery
forall a. Num a => a -> a -> a
+ Wider -> Montgomery
S.to Wider
sec)
        com :: Ordering
com = Wider -> Wider -> Ordering
W.cmp_vartime Wider
pil Wider
Secp256k1._CURVE_Q
    in  if   Ordering
com Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT Bool -> Bool -> Bool
|| Wider -> Wider -> Bool
W.eq_vartime Wider
ki Wider
0 -- negl
        then XPrv -> Word32 -> XPrv
ckd_priv XPrv
_xprv (Word32 -> Word32
forall a. Enum a => a -> a
succ Word32
i)
        else X Wider -> XPrv
XPrv (Wider -> ByteString -> X Wider
forall a. a -> ByteString -> X a
X Wider
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
<> Wider -> ByteString
unroll32 Wider
sec ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word32 -> ByteString
ser32 Word32
i
        | Bool
otherwise  = case Projective -> Wider -> Maybe Projective
Secp256k1.mul Projective
Secp256k1._CURVE_G Wider
sec of
            Maybe Projective
Nothing ->
              String -> ByteString
forall a. HasCallStack => String -> a
error String
"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
          SHA512.MAC ByteString
l = ByteString -> ByteString -> MAC
SHA512.hmac ByteString
cod ByteString
dat
          (ByteString
il, ByteString
ci) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
l
          pil :: Wider
pil = ByteString -> Wider
unsafe_roll32 ByteString
il -- safe due to 512-bit hmac
      pt <- Projective -> Wider -> Maybe Projective
Secp256k1.mul_vartime Projective
Secp256k1._CURVE_G Wider
pil
      let  ki  = Projective
pt Projective -> Projective -> Projective
`Secp256k1.add` Projective
pub
           com = Wider -> Wider -> Ordering
W.cmp_vartime Wider
pil Wider
Secp256k1._CURVE_Q
      if   com /= LT || ki == Secp256k1._CURVE_ZERO -- negl
      then ckd_pub _xpub (succ i)
      else pure (XPub (X ki ci))

-- private parent key -> public child key
n :: XPrv -> XPub
n :: XPrv -> XPub
n (XPrv (X Wider
sec ByteString
cod)) = case Projective -> Wider -> Maybe Projective
Secp256k1.mul Projective
Secp256k1._CURVE_G Wider
sec of
  Maybe Projective
Nothing -> String -> XPub
forall a. HasCallStack => String -> a
error String
"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)

-- fast variants --------------------------------------------------------------

-- | The same as 'ckd_priv', but uses a 'Context' to optimise internal
--   calculations.
ckd_priv' :: Context -> XPrv -> Word32 -> XPrv
ckd_priv' :: Context -> XPrv -> Word32 -> XPrv
ckd_priv' Context
ctx _xprv :: XPrv
_xprv@(XPrv (X Wider
sec ByteString
cod)) Word32
i =
    let SHA512.MAC ByteString
l = ByteString -> ByteString -> MAC
SHA512.hmac ByteString
cod ByteString
dat
        (ByteString
il, ByteString
ci) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
l
        pil :: Wider
pil = ByteString -> Wider
unsafe_roll32 ByteString
il -- safe due to 512-bit hmac
        ki :: Wider
ki  = Montgomery -> Wider
S.from (Wider -> Montgomery
S.to Wider
pil Montgomery -> Montgomery -> Montgomery
forall a. Num a => a -> a -> a
+ Wider -> Montgomery
S.to Wider
sec)
        com :: Ordering
com = Wider -> Wider -> Ordering
W.cmp_vartime Wider
pil Wider
Secp256k1._CURVE_Q
    in  if   Ordering
com Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT Bool -> Bool -> Bool
|| Wider -> Wider -> Bool
W.eq_vartime Wider
ki Wider
0 -- negl
        then Context -> XPrv -> Word32 -> XPrv
ckd_priv' Context
ctx XPrv
_xprv (Word32 -> Word32
forall a. Enum a => a -> a
succ Word32
i)
        else X Wider -> XPrv
XPrv (Wider -> ByteString -> X Wider
forall a. a -> ByteString -> X a
X Wider
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
<> Wider -> ByteString
unroll32 Wider
sec ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word32 -> ByteString
ser32 Word32
i
        | Bool
otherwise  = case Context -> Wider -> Maybe Projective
Secp256k1.mul_wnaf Context
ctx Wider
sec of
            Maybe Projective
Nothing ->
              String -> ByteString
forall a. HasCallStack => String -> a
error String
"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

-- | The same as 'ckd_pub', but uses a 'Context' to optimise internal
--   calculations.
ckd_pub' :: Context -> XPub -> Word32 -> Maybe XPub
ckd_pub' :: Context -> XPub -> Word32 -> Maybe XPub
ckd_pub' Context
ctx _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
          SHA512.MAC ByteString
l = ByteString -> ByteString -> MAC
SHA512.hmac ByteString
cod ByteString
dat
          (ByteString
il, ByteString
ci) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 ByteString
l
          pil :: Wider
pil = ByteString -> Wider
unsafe_roll32 ByteString
il -- safe due to 512-bit hmac
      pt <- Context -> Wider -> Maybe Projective
Secp256k1.mul_wnaf Context
ctx Wider
pil
      let  ki = Projective
pt Projective -> Projective -> Projective
`Secp256k1.add` Projective
pub
           com = Wider -> Wider -> Ordering
W.cmp_vartime Wider
pil Wider
Secp256k1._CURVE_Q
      if   com /= LT || ki == Secp256k1._CURVE_ZERO -- negl
      then ckd_pub' ctx _xpub (succ i)
      else pure (XPub (X ki ci))

-- | The same as 'n', but uses a 'Context' to optimise internal calculations.
n' :: Context -> XPrv -> XPub
n' :: Context -> XPrv -> XPub
n' Context
ctx (XPrv (X Wider
sec ByteString
cod)) = case Context -> Wider -> Maybe Projective
Secp256k1.mul_wnaf Context
ctx Wider
sec of
  Maybe Projective
Nothing -> String -> XPub
forall a. HasCallStack => String -> a
error String
"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 (Int -> HDKey -> ShowS
[HDKey] -> ShowS
HDKey -> String
(Int -> HDKey -> ShowS)
-> (HDKey -> String) -> ([HDKey] -> ShowS) -> Show HDKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HDKey -> ShowS
showsPrec :: Int -> HDKey -> ShowS
$cshow :: HDKey -> String
show :: HDKey -> String
$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
  m <- ByteString -> Maybe XPrv
_master ByteString
seed
  pure $! HDKey {
      hd_key = Right m
    , hd_depth = 0
    , hd_parent = "\NUL\NUL\NUL\NUL" -- 0x0000_0000
    , hd_child = ser32 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
  (key, parent) <- case Either XPub XPrv
hd_key of
    Left XPub
_xpub  -> do
      pub <- XPub -> Word32 -> Maybe XPub
ckd_pub XPub
_xpub Word32
i
      pure $! (pub, fingerprint _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
hd_depth Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1
      child = Word32 -> ByteString
ser32 Word32
i
  pure $! HDKey (Left key) depth parent child

-- | The same as 'derive_child_priv', but uses a 'Context' to optimise
--   internal calculations.
derive_child_priv' :: Context -> HDKey -> Word32 -> Maybe HDKey
derive_child_priv' :: Context -> HDKey -> Word32 -> Maybe HDKey
derive_child_priv' Context
ctx 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 (Context -> XPrv -> Word32 -> XPrv
ckd_priv' Context
ctx 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

-- | The same as 'derive_child_pub', but uses a 'Context' to optimise
--   internal calculations.
derive_child_pub' :: Context -> HDKey -> Word32 -> Maybe HDKey
derive_child_pub' :: Context -> HDKey -> Word32 -> Maybe HDKey
derive_child_pub' Context
ctx 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
  (key, parent) <- case Either XPub XPrv
hd_key of
    Left XPub
_xpub  -> do
      pub <- Context -> XPub -> Word32 -> Maybe XPub
ckd_pub' Context
ctx XPub
_xpub Word32
i
      pure $! (pub, fingerprint _xpub)
    Right XPrv
_xprv ->
      let pub :: XPub
pub = Context -> XPrv -> XPub
n' Context
ctx (Context -> XPrv -> Word32 -> XPrv
ckd_priv' Context
ctx 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
hd_depth Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1
      child = Word32 -> ByteString
ser32 Word32
i
  pure $! HDKey (Left key) depth parent 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 -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Path -> ShowS
showsPrec :: Int -> Path -> ShowS
$cshow :: Path -> String
show :: Path -> String
$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 -- /
            (npat, etc) <- Path -> ByteString -> Maybe (Path, ByteString)
child Path
pat ByteString
t
            go npat 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 <- Path -> Maybe HDKey
go Path
p
        derive_child_priv hdkey (0x8000_0000 + i) -- 2 ^ 31
      Path
p :/ Word32
i -> do
        hdkey <- Path -> Maybe HDKey
go Path
p
        derive_child_priv hdkey 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 -> String -> HDKey
forall a. HasCallStack => String -> a
error String
"ppad-bip32 (derive_partial): couldn't derive extended key"
  Just HDKey
hdkey -> HDKey
hdkey

-- | The same as 'derive', but uses a 'Context' to optimise internal
--   calculations.
--
--   >>> let !ctx = precompute
--   >>> let Just child = derive' ctx hd "m/44'/0'/0'/0/0"
derive'
  :: Context
  -> HDKey
  -> BS.ByteString -- ^ derivation path
  -> Maybe HDKey
derive' :: Context -> HDKey -> ByteString -> Maybe HDKey
derive' Context
ctx 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 <- Path -> Maybe HDKey
go Path
p
        derive_child_priv' ctx hdkey (0x8000_0000 + i) -- 2 ^ 31
      Path
p :/ Word32
i -> do
        hdkey <- Path -> Maybe HDKey
go Path
p
        derive_child_priv' ctx hdkey i

-- | The same as 'derive_partial', but uses a 'Context' to optimise internal
--   calculations.
--
--   >>> let !ctx = precompute
--   >>> let child = derive_partial' ctx hd "m/44'/0'/0'/0/0"
derive_partial'
  :: Context
  -> HDKey
  -> BS.ByteString
  -> HDKey
derive_partial' :: Context -> HDKey -> ByteString -> HDKey
derive_partial' Context
ctx HDKey
hd ByteString
pat = case Context -> HDKey -> ByteString -> Maybe HDKey
derive' Context
ctx HDKey
hd ByteString
pat of
  Maybe HDKey
Nothing ->
    String -> HDKey
forall a. HasCallStack => String -> a
error String
"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
. LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
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
. LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
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
. LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
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
. LazyByteString -> ByteString
BS.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
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 Wider
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 (Wider -> ByteString
unroll32 Wider
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
    bs <- ByteString -> Maybe ByteString
B58C.decode ByteString
b58
    case BS.splitAt 4 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
      (hd_depth, etc0) <- ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs
      let (hd_parent, etc1) = BS.splitAt 4 etc0
      guard (BS.length hd_parent == 4)
      let (hd_child, etc2) = BS.splitAt 4 etc1
      guard (BS.length hd_child == 4)
      let (cod, etc3) = BS.splitAt 32 etc2
      guard (BS.length cod == 32)
      let (key, etc4) = BS.splitAt 33 etc3
      guard (BS.length key == 33)
      guard (BS.length etc4 == 0)
      hd <- case ktype of
        KeyType
Pub -> do
          pub <- ByteString -> Maybe Projective
Secp256k1.parse_point ByteString
key
          let 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))
          pure HDKey {..}
        KeyType
Prv -> do
          (b, unsafe_roll32 -> prv) <- ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
key -- safe, guarded keylen
          guard (b == 0)
          let com0 = Wider -> Wider -> Choice
W.gt Wider
prv Wider
0
              com1 = Wider -> Wider -> Choice
W.lt Wider
prv Wider
Secp256k1._CURVE_Q
          guard (C.decide (C.and com0 com1))
          let hd_key = XPrv -> Either a XPrv
forall a b. b -> Either a b
Right (X Wider -> XPrv
XPrv (Wider -> ByteString -> X Wider
forall a. a -> ByteString -> X a
X Wider
prv ByteString
cod))
          pure HDKey {..}
      guard (valid_lineage hd)
      pure 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