bip32

Pure Haskell BIP32 hierarchical deterministic wallets (docs.ppad.tech/bip32).
git clone git://git.ppad.tech/bip32.git
Log | Files | Refs | README | LICENSE

BIP32.hs (16397B)


      1 {-# OPTIONS_HADDOCK prune #-}
      2 {-# LANGUAGE BangPatterns #-}
      3 {-# LANGUAGE BinaryLiterals #-}
      4 {-# LANGUAGE DeriveGeneric #-}
      5 {-# LANGUAGE LambdaCase #-}
      6 {-# LANGUAGE NumericUnderscores #-}
      7 {-# LANGUAGE OverloadedStrings #-}
      8 {-# LANGUAGE RecordWildCards #-}
      9 {-# LANGUAGE ViewPatterns #-}
     10 
     11 -- |
     12 -- Module: Crypto.HDKey.BIP32
     13 -- Copyright: (c) 2025 Jared Tobin
     14 -- License: MIT
     15 -- Maintainer: Jared Tobin <jared@ppad.tech>
     16 --
     17 -- [BIP32](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki)
     18 -- hierarchical deterministic wallets and extended keys, with support for
     19 -- serialization and parsing.
     20 
     21 module Crypto.HDKey.BIP32 (
     22   -- * Hierarchical deterministic keys
     23     HDKey(..)
     24   , master
     25 
     26   -- * Extended keys
     27   , Extended(..)
     28   , XPub
     29   , xpub_key
     30   , xpub_cod
     31   , XPrv
     32   , xprv_key
     33   , xprv_cod
     34   , X
     35   , ckd_pub
     36   , ckd_priv
     37   , n
     38 
     39   -- * Child derivation via path
     40   , derive
     41   , derive_partial
     42 
     43   -- * Serialization
     44   , xpub
     45   , xprv
     46   , tpub
     47   , tprv
     48 
     49   -- * Parsing
     50   , parse
     51 
     52   -- * Child key derivation functions
     53   , derive_child_pub
     54   , derive_child_priv
     55   ) where
     56 
     57 import Control.Monad (guard)
     58 import qualified Crypto.Hash.SHA256 as SHA256
     59 import qualified Crypto.Hash.SHA512 as SHA512
     60 import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
     61 import qualified Crypto.Curve.Secp256k1 as Secp256k1
     62 import Data.Bits ((.<<.), (.>>.), (.|.), (.&.))
     63 import qualified Data.ByteString as BS
     64 import qualified Data.ByteString.Char8 as B8
     65 import qualified Data.ByteString.Base58Check as B58C
     66 import qualified Data.ByteString.Builder as BSB
     67 import qualified Data.ByteString.Internal as BI
     68 import Data.Word (Word8, Word32)
     69 import GHC.Generics
     70 
     71 -- utilities ------------------------------------------------------------------
     72 
     73 fi :: (Integral a, Num b) => a -> b
     74 fi = fromIntegral
     75 {-# INLINE fi #-}
     76 
     77 -- big-endian bytestring encoding
     78 unroll :: Integer -> BS.ByteString
     79 unroll i = case i of
     80     0 -> BS.singleton 0
     81     _ -> BS.reverse $ BS.unfoldr coalg i
     82   where
     83     coalg 0 = Nothing
     84     coalg m = Just (fi m, m .>>. 8)
     85 
     86 -- parse 32 bytes to a 256-bit integer
     87 parse256 :: BS.ByteString -> Integer
     88 parse256 bs@(BI.PS _ _ l)
     89     | l == 32   = BS.foldl' alg 0 bs
     90     | otherwise = error "ppad-bip32 (parse256): internal error"
     91   where
     92     alg !a (fi -> !b) = (a .<<. 8) .|. b
     93 
     94 -- serialize a 256-bit integer to 32 bytes, left-padding with zeros if
     95 -- necessary. the size of the integer is not checked.
     96 ser256 :: Integer -> BS.ByteString
     97 ser256 (unroll -> u@(BI.PS _ _ l))
     98   | l < 32 = BS.replicate (32 - l) 0 <> u
     99   | otherwise = u
    100 
    101 -- serialize a 32-bit word, MSB first
    102 ser32 :: Word32 -> BS.ByteString
    103 ser32 w =
    104   let !mask = 0b00000000_00000000_00000000_11111111
    105       !w0 = fi (w .>>. 24) .&. mask
    106       !w1 = fi (w .>>. 16) .&. mask
    107       !w2 = fi (w .>>. 08) .&. mask
    108       !w3 = fi w .&. mask
    109   in  BS.cons w0 (BS.cons w1 (BS.cons w2 (BS.singleton w3)))
    110 
    111 -- extended keys --------------------------------------------------------------
    112 
    113 -- | An extended public key.
    114 newtype XPub = XPub (X Secp256k1.Projective)
    115   deriving (Eq, Show, Generic)
    116 
    117 -- | Read the raw public key from an 'XPub'.
    118 xpub_key :: XPub -> Secp256k1.Projective
    119 xpub_key (XPub (X pub _)) = pub
    120 
    121 -- | Read the raw chain code from an 'XPub'.
    122 xpub_cod :: XPub -> BS.ByteString
    123 xpub_cod (XPub (X _ cod)) = cod
    124 
    125 -- | An extended private key.
    126 newtype XPrv = XPrv (X Integer)
    127   deriving (Eq, Show, Generic)
    128 
    129 -- | Read the raw private key from an 'XPrv'.
    130 xprv_key :: XPrv -> Integer
    131 xprv_key (XPrv (X sec _)) = sec
    132 
    133 -- | Read the raw chain code from an 'XPrv'.
    134 xprv_cod :: XPrv -> BS.ByteString
    135 xprv_cod (XPrv (X _ cod)) = cod
    136 
    137 -- | A public or private key, extended with a chain code.
    138 data X a = X !a !BS.ByteString
    139   deriving (Eq, Show, Generic)
    140 
    141 -- | Key types supporting identifier/fingerprint calculation.
    142 --
    143 --   >>> let Just hd = master "my very secret entropy"
    144 --   >>> let Right my_xprv = hd_key hd
    145 --   >>> let my_xpub = n k
    146 --   >>> -- all have the same fingerprint
    147 --   >>> fingerprint hd
    148 --   "G\157\&8\146"
    149 --   >>> fingerprint my_xprv
    150 --   "G\157\&8\146"
    151 --   >>> fingerprint my_xpub
    152 --   "G\157\&8\146"
    153 class Extended k where
    154   -- | Calculate the identifier for an extended key.
    155   identifier  :: k -> BS.ByteString
    156 
    157   -- | Calculate the fingerprint of an extended key.
    158   fingerprint :: k -> BS.ByteString
    159   fingerprint = BS.take 4 . identifier
    160 
    161 instance Extended XPub where
    162   identifier (XPub (X pub _)) =
    163     let ser = Secp256k1.serialize_point pub
    164     in  RIPEMD160.hash (SHA256.hash ser)
    165 
    166 instance Extended XPrv where
    167   identifier (XPrv (X sec _)) = case Secp256k1.mul Secp256k1._CURVE_G sec of
    168     Nothing ->
    169       error "ppad-bip32 (identifier): internal error, evil extended key"
    170     Just p ->
    171       let ser = Secp256k1.serialize_point p
    172       in  RIPEMD160.hash (SHA256.hash ser)
    173 
    174 -- internal key derivation functions-------------------------------------------
    175 
    176 hardened :: Word32 -> Bool
    177 hardened = (>= 0x8000_0000)
    178 
    179 -- master xprv from seed
    180 _master :: BS.ByteString -> Maybe XPrv
    181 _master seed@(BI.PS _ _ l)
    182   | l < 16 = Nothing
    183   | l > 64 = Nothing
    184   | otherwise = do
    185       let i = SHA512.hmac "Bitcoin seed" seed
    186           (il, c) = BS.splitAt 32 i
    187           s = parse256 il -- safe due to 512-bit hmac
    188       pure $! (XPrv (X s c))
    189 
    190 -- private parent key -> private child key
    191 ckd_priv :: XPrv -> Word32 -> XPrv
    192 ckd_priv _xprv@(XPrv (X sec cod)) i =
    193     let l = SHA512.hmac cod dat
    194         (il, ci) = BS.splitAt 32 l
    195         pil = parse256 il -- safe due to 512-bit hmac
    196         ki  = Secp256k1.modQ (pil + sec)
    197     in  if   pil >= Secp256k1._CURVE_Q || ki == 0 -- negl
    198         then ckd_priv _xprv (succ i)
    199         else XPrv (X ki ci)
    200   where
    201     dat | hardened i = BS.singleton 0x00 <> ser256 sec <> ser32 i
    202         | otherwise  = case Secp256k1.mul Secp256k1._CURVE_G sec of
    203             Nothing ->
    204               error "ppad-bip32 (ckd_priv): internal error, evil extended key"
    205             Just p  -> Secp256k1.serialize_point p <> ser32 i
    206 
    207 -- public parent key -> public child key
    208 ckd_pub :: XPub -> Word32 -> Maybe XPub
    209 ckd_pub _xpub@(XPub (X pub cod)) i
    210   | hardened i = Nothing
    211   | otherwise = do
    212       let dat = Secp256k1.serialize_point pub <> ser32 i
    213           l   = SHA512.hmac cod dat
    214           (il, ci) = BS.splitAt 32 l
    215           pil = parse256 il -- safe due to 512-bit hmac
    216       pt <- Secp256k1.mul_unsafe Secp256k1._CURVE_G pil
    217       let  ki = pt `Secp256k1.add` pub
    218       if   pil >= Secp256k1._CURVE_Q || ki == Secp256k1._CURVE_ZERO -- negl
    219       then ckd_pub _xpub (succ i)
    220       else pure (XPub (X ki ci))
    221 
    222 -- private parent key -> public child key
    223 n :: XPrv -> XPub
    224 n (XPrv (X sec cod)) = case Secp256k1.mul Secp256k1._CURVE_G sec of
    225   Nothing -> error "ppad-bip32 (n): internal error, evil extended key"
    226   Just p -> XPub (X p cod)
    227 
    228 -- hierarchical deterministic keys --------------------------------------------
    229 
    230 -- | A BIP32 hierarchical deterministic key.
    231 --
    232 --   This differs from lower-level "extended" keys in that it carries all
    233 --   information required for serialization.
    234 data HDKey = HDKey {
    235     hd_key    :: !(Either XPub XPrv) -- ^ extended public or private key
    236   , hd_depth  :: !Word8              -- ^ key depth
    237   , hd_parent :: !BS.ByteString      -- ^ parent fingerprint
    238   , hd_child  :: !BS.ByteString      -- ^ index or child number
    239   }
    240   deriving (Eq, Show, Generic)
    241 
    242 instance Extended HDKey where
    243   identifier (HDKey ekey _ _ _) = case ekey of
    244     Left l -> identifier l
    245     Right r -> identifier r
    246 
    247 -- | Derive a master 'HDKey' from a master seed.
    248 --
    249 --   Fails with 'Nothing' if the provided seed has an invalid length.
    250 --
    251 ---  >>> let Just hd = master "my very secret entropy"
    252 --   >>> xpub hd
    253 --   "xpub661MyMwAqRbcGTJPtZRqZyrvjxHCfhqXeiqb5GVU3EGuFBy4QxT3yt8iiHwZTiCzZFyuyNiqXB3eqzqFZ8z4L6HCrPSkDVFNuW59LXYvMjs"
    254 master :: BS.ByteString -> Maybe HDKey
    255 master seed = do
    256   m <- _master seed
    257   pure $! HDKey {
    258       hd_key = Right m
    259     , hd_depth = 0
    260     , hd_parent = "\NUL\NUL\NUL\NUL" -- 0x0000_0000
    261     , hd_child = ser32 0
    262     }
    263 
    264 -- | Derive a private child node at the provided index.
    265 --
    266 --   Fails with 'Nothing' if derivation is impossible.
    267 --
    268 --   >>> let Just child_prv = derive_child_priv hd 0
    269 --   >>> xpub child_prv
    270 --   "xpub68R2ZbtFeJTFJApdEdPqW5cy3d5wF96tTfJErhu3mTi2Ttaqvc88BMPrgS3hQSrHj91kRbzVLM9pue9f8219szRKZuTAx1LWbdLDLFDm6Ly"
    271 derive_child_priv :: HDKey -> Word32 -> Maybe HDKey
    272 derive_child_priv HDKey {..} i = case hd_key of
    273   Left _ -> Nothing
    274   Right _xprv -> pure $!
    275     let key   = Right (ckd_priv _xprv i)
    276         depth = hd_depth + 1
    277         parent = fingerprint _xprv
    278         child = ser32 i
    279     in  HDKey key depth parent child
    280 
    281 -- | Derive a public child node at the provided index.
    282 --
    283 --   Fails with 'Nothing' if derivation is impossible.
    284 --
    285 --   >>> :set -XNumericUnderscores
    286 --   >>> let Just child_pub = derive_child_pub child_prv 0x8000_0000
    287 --   >>> xpub child_pub
    288 --   "xpub6B6LoU83Cpyx1UVMwuoQdQvY2BuGbPd2xsEVxCnj85UGgDN9bRz82hQhe9UFmyo4Pokuhjc8M1Cfc8ufLxcL6FkCF7Zc2eajEfWfZwMFF6X"
    289 derive_child_pub :: HDKey -> Word32 -> Maybe HDKey
    290 derive_child_pub HDKey {..} i = do
    291   (key, parent) <- case hd_key of
    292     Left _xpub  -> do
    293       pub <- ckd_pub _xpub i
    294       pure $! (pub, fingerprint _xpub)
    295     Right _xprv ->
    296       let pub = n (ckd_priv _xprv i)
    297       in  pure $! (pub, fingerprint _xprv)
    298   let depth = hd_depth + 1
    299       child = ser32 i
    300   pure $! HDKey (Left key) depth parent child
    301 
    302 -- derivation path expression -------------------------------------------------
    303 
    304 -- recursive derivation path
    305 data Path =
    306     M
    307   | !Path :| !Word32 -- hardened
    308   | !Path :/ !Word32
    309   deriving (Eq, Show)
    310 
    311 parse_path :: BS.ByteString -> Maybe Path
    312 parse_path bs = case BS.uncons bs of
    313     Nothing -> Nothing
    314     Just (h, t)
    315       | h == 109  -> go M t -- == 'm'
    316       | otherwise -> Nothing
    317   where
    318     child :: Path -> BS.ByteString -> Maybe (Path, BS.ByteString)
    319     child pat b = case B8.readInt b of
    320       Nothing -> Nothing
    321       Just (fi -> i, etc) -> case BS.uncons etc of
    322         Nothing -> Just $! (pat :/ i, mempty)
    323         Just (h, t)
    324           | h == 39 -> Just $! (pat :| i, t) -- '
    325           | otherwise -> Just $! (pat :/ i, etc)
    326 
    327     go pat b = case BS.uncons b of
    328       Nothing -> Just pat
    329       Just (h, t)
    330         | h == 47 -> do -- /
    331             (npat, etc) <- child pat t
    332             go npat etc
    333         | otherwise ->
    334             Nothing
    335 
    336 -- | Derive a child node via the provided derivation path.
    337 --
    338 --   Fails with 'Nothing' if derivation is impossible, or if the
    339 --   provided path is invalid.
    340 --
    341 --   >>> let Just hd = master "my very secret master seed"
    342 --   >>> let Just child = derive hd "m/44'/0'/0'/0/0"
    343 --   >>> xpub child
    344 --   "xpub6FvaeGNFmCkLky6jwefrUfyH7gCGSAUckRBANT6wLQkm4eWZApsf4LqAadtbM8EBFfuKGFgzhgta4ByP6xnBodk2EV7BiwxCPLgu13oYWGp"
    345 derive
    346   :: HDKey
    347   -> BS.ByteString -- ^ derivation path
    348   -> Maybe HDKey
    349 derive hd pat = case parse_path pat of
    350     Nothing -> Nothing
    351     Just p  -> go p
    352   where
    353     go = \case
    354       M -> pure hd
    355       p :| i -> do
    356         hdkey <- go p
    357         derive_child_priv hdkey (0x8000_0000 + i) -- 2 ^ 31
    358       p :/ i -> do
    359         hdkey <- go p
    360         derive_child_priv hdkey i
    361 
    362 -- | Derive a child node via the provided derivation path.
    363 --
    364 --   Fails with 'error' if derivation is impossible, or if the provided
    365 --   path is invalid.
    366 --
    367 --   >>> let other_child = derive_partial hd "m/44'/0'/0'/0/1"
    368 --   >>> xpub other_child
    369 --   "xpub6FvaeGNFmCkLpkT3uahJnGPTfEX62PtH7uZAyjtru8S2FvPuYTQKn8ct6CNQAwHMXaGN6EYuwi1Tz2VD7msftH8VTAtzgNra9CForA9FBP4"
    370 derive_partial
    371   :: HDKey
    372   -> BS.ByteString
    373   -> HDKey
    374 derive_partial hd pat = case derive hd pat of
    375   Nothing -> error "ppad-bip32 (derive_partial): couldn't derive extended key"
    376   Just hdkey -> hdkey
    377 
    378 -- serialization --------------------------------------------------------------
    379 
    380 _MAINNET_PUB, _MAINNET_PRV :: Word32
    381 _TESTNET_PUB, _TESTNET_PRV :: Word32
    382 
    383 _MAINNET_PUB_BYTES, _MAINNET_PRV_BYTES :: BS.ByteString
    384 _TESTNET_PUB_BYTES, _TESTNET_PRV_BYTES :: BS.ByteString
    385 
    386 _MAINNET_PUB = 0x0488B21E
    387 _MAINNET_PUB_BYTES = "\EOT\136\178\RS"
    388 
    389 _MAINNET_PRV = 0x0488ADE4
    390 _MAINNET_PRV_BYTES = "\EOT\136\173\228"
    391 
    392 _TESTNET_PUB = 0x043587CF
    393 _TESTNET_PUB_BYTES = "\EOT5\135\207"
    394 
    395 _TESTNET_PRV = 0x04358394
    396 _TESTNET_PRV_BYTES = "\EOT5\131\148"
    397 
    398 -- | Serialize a mainnet extended public key in base58check format.
    399 --
    400 --   >>> let Just hd = master "my very secret entropy"
    401 --   >>> xpub hd
    402 --   "xpub661MyMwAqRbcGTJPtZRqZyrvjxHCfhqXeiqb5GVU3EGuFBy4QxT3yt8iiHwZTiCzZFyuyNiqXB3eqzqFZ8z4L6HCrPSkDVFNuW59LXYvMjs"
    403 xpub :: HDKey -> BS.ByteString
    404 xpub x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $
    405   case hd_key of
    406     Left _  -> _serialize _MAINNET_PUB x
    407     Right e -> _serialize _MAINNET_PUB HDKey {
    408         hd_key = Left (n e)
    409       , ..
    410       }
    411 
    412 -- | Serialize a mainnet extended private key in base58check format.
    413 --
    414 --   >>> xprv hd
    415 --   Just "xprv9s21ZrQH143K3yDvnXtqCqvCBvSiGF7gHVuzGt5rUtjvNPdusR8oS5pErywDM1jDDTcLpNNCbg9a9NuidBczRzSUp7seDeu8am64h6nfdrg"
    416 xprv :: HDKey -> Maybe BS.ByteString
    417 xprv x@HDKey {..} = case hd_key of
    418   Left _  -> Nothing
    419   Right _ -> do
    420     let ser = _serialize _MAINNET_PRV x
    421     pure $! (B58C.encode . BS.toStrict . BSB.toLazyByteString) ser
    422 
    423 -- | Serialize a testnet extended public key in base58check format.
    424 --
    425 --   >>> tpub hd
    426 --   "tpubD6NzVbkrYhZ4YFVFLkQvmuCJ55Nrf6LbCMRtRpYcP92nzUdmVBJ98KoYxL2LzDAEMAWpaxEi4GshYBKrwzqJDXjVuzC3u1ucVTfZ6ZD415x"
    427 tpub :: HDKey -> BS.ByteString
    428 tpub x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $
    429   case hd_key of
    430     Left _  -> _serialize _TESTNET_PUB x
    431     Right e -> _serialize _TESTNET_PUB HDKey {
    432       hd_key = Left (n e)
    433       , ..
    434       }
    435 
    436 -- | Serialize a testnet extended private key in base58check format.
    437 --
    438 --   >>> tprv hd
    439 --   Just "tprv8ZgxMBicQKsPenTTT6kLNVYBW3rvVm9gd3q79JWJxsEQ9zNzrnUYwqBgnA6sMP7Xau97pTyxm2jNcETTkPxwF3i5Lm5wt1dBVrqV8kKi5v5"
    440 tprv :: HDKey -> Maybe BS.ByteString
    441 tprv x@HDKey {..} = case hd_key of
    442   Left _  -> Nothing
    443   Right _ -> do
    444     let ser = _serialize _TESTNET_PRV x
    445     pure $! (B58C.encode . BS.toStrict . BSB.toLazyByteString) ser
    446 
    447 _serialize :: Word32 -> HDKey -> BSB.Builder
    448 _serialize version HDKey {..} =
    449      BSB.word32BE version
    450   <> BSB.word8 hd_depth
    451   <> BSB.byteString hd_parent
    452   <> BSB.byteString hd_child
    453   <> case hd_key of
    454        Left (XPub (X pub cod)) ->
    455             BSB.byteString cod
    456          <> BSB.byteString (Secp256k1.serialize_point pub)
    457        Right (XPrv (X sec cod)) ->
    458             BSB.byteString cod
    459          <> BSB.word8 0x00
    460          <> BSB.byteString (ser256 sec)
    461 
    462 -- parsing --------------------------------------------------------------------
    463 
    464 data KeyType =
    465     Pub
    466   | Prv
    467 
    468 -- | Parse a base58check-encoded 'ByteString' into a 'HDKey'.
    469 --
    470 --   Fails with 'Nothing' if the provided key is invalid.
    471 --
    472 --   >>> let Just hd = master "my very secret entropy"
    473 --   >>> let Just my_xprv = parse (xprv hd)
    474 --   >>> my_xprv == hd
    475 --   True
    476 parse :: BS.ByteString -> Maybe HDKey
    477 parse b58 = do
    478     bs <- B58C.decode b58
    479     case BS.splitAt 4 bs of
    480       (version, etc)
    481         | version == _MAINNET_PUB_BYTES || version == _TESTNET_PUB_BYTES ->
    482             parse_pub etc
    483         | version == _MAINNET_PRV_BYTES || version == _TESTNET_PRV_BYTES ->
    484             parse_prv etc
    485         | otherwise ->
    486             Nothing
    487   where
    488     parse_pub = _parse Pub
    489     parse_prv = _parse Prv
    490 
    491     _parse ktype bs = do
    492       (hd_depth, etc0) <- BS.uncons bs
    493       let (hd_parent, etc1) = BS.splitAt 4 etc0
    494       guard (BS.length hd_parent == 4)
    495       let (hd_child, etc2) = BS.splitAt 4 etc1
    496       guard (BS.length hd_child == 4)
    497       let (cod, etc3) = BS.splitAt 32 etc2
    498       guard (BS.length cod == 32)
    499       let (key, etc4) = BS.splitAt 33 etc3
    500       guard (BS.length key == 33)
    501       guard (BS.length etc4 == 0)
    502       hd <- case ktype of
    503         Pub -> do
    504           pub <- Secp256k1.parse_point key
    505           let hd_key = Left (XPub (X pub cod))
    506           pure HDKey {..}
    507         Prv -> do
    508           (b, parse256 -> prv) <- BS.uncons key -- safe due to guarded keylen
    509           guard (b == 0)
    510           guard (prv > 0 && prv < Secp256k1._CURVE_Q)
    511           let hd_key = Right (XPrv (X prv cod))
    512           pure HDKey {..}
    513       guard (valid_lineage hd)
    514       pure hd
    515     {-# INLINE _parse #-}
    516 
    517 valid_lineage :: HDKey -> Bool
    518 valid_lineage HDKey {..}
    519   | hd_depth == 0 =
    520          hd_parent == "\NUL\NUL\NUL\NUL"
    521       && hd_child == "\NUL\NUL\NUL\NUL"
    522   | otherwise = True
    523