BIP32.hs (25309B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE BinaryLiterals #-} 4 {-# LANGUAGE DeriveGeneric #-} 5 {-# LANGUAGE LambdaCase #-} 6 {-# LANGUAGE MagicHash #-} 7 {-# LANGUAGE NumericUnderscores #-} 8 {-# LANGUAGE OverloadedStrings #-} 9 {-# LANGUAGE RecordWildCards #-} 10 {-# LANGUAGE UnboxedTuples #-} 11 {-# LANGUAGE ViewPatterns #-} 12 13 -- | 14 -- Module: Crypto.HDKey.BIP32 15 -- Copyright: (c) 2025 Jared Tobin 16 -- License: MIT 17 -- Maintainer: Jared Tobin <jared@ppad.tech> 18 -- 19 -- [BIP32](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki) 20 -- hierarchical deterministic wallets and extended keys, with support for 21 -- serialization and parsing. 22 23 module Crypto.HDKey.BIP32 ( 24 -- * Hierarchical deterministic keys 25 HDKey(..) 26 , master 27 28 -- * Extended keys 29 , Extended(..) 30 , XPub 31 , xpub_key 32 , xpub_cod 33 , XPrv 34 , xprv_key 35 , xprv_cod 36 , X 37 , ckd_pub 38 , ckd_priv 39 , n 40 41 -- * Child derivation via path 42 , derive 43 , derive_partial 44 45 -- * Serialization 46 , xpub 47 , xprv 48 , tpub 49 , tprv 50 51 -- * Parsing 52 , parse 53 54 -- * Child key derivation functions 55 , derive_child_pub 56 , derive_child_priv 57 58 -- * Fast wNAF variants 59 , Context 60 , precompute 61 , ckd_priv' 62 , ckd_pub' 63 , n' 64 , derive' 65 , derive_partial' 66 , derive_child_priv' 67 , derive_child_pub' 68 ) where 69 70 import Control.Monad (guard) 71 import qualified Crypto.Hash.SHA256 as SHA256 72 import qualified Crypto.Hash.SHA512 as SHA512 73 import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 74 import qualified Crypto.Curve.Secp256k1 as Secp256k1 75 import Data.Bits ((.>>.), (.&.)) 76 import qualified Data.ByteString as BS 77 import qualified Data.ByteString.Char8 as B8 78 import qualified Data.ByteString.Base58Check as B58C 79 import qualified Data.ByteString.Builder as BSB 80 import qualified Data.ByteString.Internal as BI 81 import qualified Data.ByteString.Unsafe as BU 82 import Data.Word (Word8, Word32) 83 import Data.Word.Limb (Limb(..)) 84 import qualified Data.Word.Limb as L 85 import Data.Word.Wider (Wider(..)) 86 import qualified Foreign.Storable as Storable (pokeByteOff) 87 import qualified GHC.Exts as Exts 88 import GHC.Generics 89 import qualified GHC.Word (Word8(..)) 90 import qualified Numeric.Montgomery.Secp256k1.Scalar as S 91 92 -- | Precomputed multiples of the secp256k1 generator point, for faster 93 -- scalar multiplication. 94 type Context = Secp256k1.Context 95 96 -- | Create a secp256k1 context by precomputing multiples of the curve's 97 -- generator point. 98 -- 99 -- This should be computed once and reused for all derivations. 100 -- 101 -- >>> let !ctx = precompute 102 -- >>> derive' ctx hd "m/44'/0'/0'/0/0" 103 precompute :: Context 104 precompute = Secp256k1.precompute 105 106 -- parsing utilities ---------------------------------------------------------- 107 108 -- convert a Word8 to a Limb 109 limb :: Word8 -> Limb 110 limb (GHC.Word.W8# (Exts.word8ToWord# -> w)) = Limb w 111 {-# INLINABLE limb #-} 112 113 -- convert a Limb to a Word8 114 word8 :: Limb -> Word8 115 word8 (Limb w) = GHC.Word.W8# (Exts.wordToWord8# w) 116 {-# INLINABLE word8 #-} 117 118 -- unsafely extract the first 64-bit word from a big-endian-encoded bytestring 119 unsafe_word0 :: BS.ByteString -> Limb 120 unsafe_word0 bs = 121 (limb (BU.unsafeIndex bs 00) `L.shl#` 56#) 122 `L.or#` (limb (BU.unsafeIndex bs 01) `L.shl#` 48#) 123 `L.or#` (limb (BU.unsafeIndex bs 02) `L.shl#` 40#) 124 `L.or#` (limb (BU.unsafeIndex bs 03) `L.shl#` 32#) 125 `L.or#` (limb (BU.unsafeIndex bs 04) `L.shl#` 24#) 126 `L.or#` (limb (BU.unsafeIndex bs 05) `L.shl#` 16#) 127 `L.or#` (limb (BU.unsafeIndex bs 06) `L.shl#` 08#) 128 `L.or#` (limb (BU.unsafeIndex bs 07)) 129 {-# INLINABLE unsafe_word0 #-} 130 131 -- unsafely extract the second 64-bit word from a big-endian-encoded bytestring 132 unsafe_word1 :: BS.ByteString -> Limb 133 unsafe_word1 bs = 134 (limb (BU.unsafeIndex bs 08) `L.shl#` 56#) 135 `L.or#` (limb (BU.unsafeIndex bs 09) `L.shl#` 48#) 136 `L.or#` (limb (BU.unsafeIndex bs 10) `L.shl#` 40#) 137 `L.or#` (limb (BU.unsafeIndex bs 11) `L.shl#` 32#) 138 `L.or#` (limb (BU.unsafeIndex bs 12) `L.shl#` 24#) 139 `L.or#` (limb (BU.unsafeIndex bs 13) `L.shl#` 16#) 140 `L.or#` (limb (BU.unsafeIndex bs 14) `L.shl#` 08#) 141 `L.or#` (limb (BU.unsafeIndex bs 15)) 142 {-# INLINABLE unsafe_word1 #-} 143 144 -- unsafely extract the third 64-bit word from a big-endian-encoded bytestring 145 unsafe_word2 :: BS.ByteString -> Limb 146 unsafe_word2 bs = 147 (limb (BU.unsafeIndex bs 16) `L.shl#` 56#) 148 `L.or#` (limb (BU.unsafeIndex bs 17) `L.shl#` 48#) 149 `L.or#` (limb (BU.unsafeIndex bs 18) `L.shl#` 40#) 150 `L.or#` (limb (BU.unsafeIndex bs 19) `L.shl#` 32#) 151 `L.or#` (limb (BU.unsafeIndex bs 20) `L.shl#` 24#) 152 `L.or#` (limb (BU.unsafeIndex bs 21) `L.shl#` 16#) 153 `L.or#` (limb (BU.unsafeIndex bs 22) `L.shl#` 08#) 154 `L.or#` (limb (BU.unsafeIndex bs 23)) 155 {-# INLINABLE unsafe_word2 #-} 156 157 -- unsafely extract the fourth 64-bit word from a big-endian-encoded bytestring 158 unsafe_word3 :: BS.ByteString -> Limb 159 unsafe_word3 bs = 160 (limb (BU.unsafeIndex bs 24) `L.shl#` 56#) 161 `L.or#` (limb (BU.unsafeIndex bs 25) `L.shl#` 48#) 162 `L.or#` (limb (BU.unsafeIndex bs 26) `L.shl#` 40#) 163 `L.or#` (limb (BU.unsafeIndex bs 27) `L.shl#` 32#) 164 `L.or#` (limb (BU.unsafeIndex bs 28) `L.shl#` 24#) 165 `L.or#` (limb (BU.unsafeIndex bs 29) `L.shl#` 16#) 166 `L.or#` (limb (BU.unsafeIndex bs 30) `L.shl#` 08#) 167 `L.or#` (limb (BU.unsafeIndex bs 31)) 168 {-# INLINABLE unsafe_word3 #-} 169 170 -- 256-bit big-endian bytestring decoding. the input size is not checked! 171 unsafe_roll32 :: BS.ByteString -> Wider 172 unsafe_roll32 bs = 173 let !w0 = unsafe_word0 bs 174 !w1 = unsafe_word1 bs 175 !w2 = unsafe_word2 bs 176 !w3 = unsafe_word3 bs 177 in Wider (# w3, w2, w1, w0 #) 178 {-# INLINABLE unsafe_roll32 #-} 179 180 -- convert a Limb to a Word8 after right-shifting 181 word8s :: Limb -> Exts.Int# -> Word8 182 word8s l s = 183 let !(Limb w) = L.shr# l s 184 in GHC.Word.W8# (Exts.wordToWord8# w) 185 {-# INLINABLE word8s #-} 186 187 -- utilities ------------------------------------------------------------------ 188 189 fi :: (Integral a, Num b) => a -> b 190 fi = fromIntegral 191 {-# INLINE fi #-} 192 193 -- 256-bit big-endian bytestring encoding 194 unroll32 :: Wider -> BS.ByteString 195 unroll32 (Wider (# w0, w1, w2, w3 #)) = 196 BI.unsafeCreate 32 $ \ptr -> do 197 -- w0 198 Storable.pokeByteOff ptr 00 (word8s w3 56#) 199 Storable.pokeByteOff ptr 01 (word8s w3 48#) 200 Storable.pokeByteOff ptr 02 (word8s w3 40#) 201 Storable.pokeByteOff ptr 03 (word8s w3 32#) 202 Storable.pokeByteOff ptr 04 (word8s w3 24#) 203 Storable.pokeByteOff ptr 05 (word8s w3 16#) 204 Storable.pokeByteOff ptr 06 (word8s w3 08#) 205 Storable.pokeByteOff ptr 07 (word8 w3) 206 -- w1 207 Storable.pokeByteOff ptr 08 (word8s w2 56#) 208 Storable.pokeByteOff ptr 09 (word8s w2 48#) 209 Storable.pokeByteOff ptr 10 (word8s w2 40#) 210 Storable.pokeByteOff ptr 11 (word8s w2 32#) 211 Storable.pokeByteOff ptr 12 (word8s w2 24#) 212 Storable.pokeByteOff ptr 13 (word8s w2 16#) 213 Storable.pokeByteOff ptr 14 (word8s w2 08#) 214 Storable.pokeByteOff ptr 15 (word8 w2) 215 -- w2 216 Storable.pokeByteOff ptr 16 (word8s w1 56#) 217 Storable.pokeByteOff ptr 17 (word8s w1 48#) 218 Storable.pokeByteOff ptr 18 (word8s w1 40#) 219 Storable.pokeByteOff ptr 19 (word8s w1 32#) 220 Storable.pokeByteOff ptr 20 (word8s w1 24#) 221 Storable.pokeByteOff ptr 21 (word8s w1 16#) 222 Storable.pokeByteOff ptr 22 (word8s w1 08#) 223 Storable.pokeByteOff ptr 23 (word8 w1) 224 -- w3 225 Storable.pokeByteOff ptr 24 (word8s w0 56#) 226 Storable.pokeByteOff ptr 25 (word8s w0 48#) 227 Storable.pokeByteOff ptr 26 (word8s w0 40#) 228 Storable.pokeByteOff ptr 27 (word8s w0 32#) 229 Storable.pokeByteOff ptr 28 (word8s w0 24#) 230 Storable.pokeByteOff ptr 29 (word8s w0 16#) 231 Storable.pokeByteOff ptr 30 (word8s w0 08#) 232 Storable.pokeByteOff ptr 31 (word8 w0) 233 {-# INLINABLE unroll32 #-} 234 235 -- serialize a 32-bit word, MSB first 236 ser32 :: Word32 -> BS.ByteString 237 ser32 w = 238 let !mask = 0b00000000_00000000_00000000_11111111 239 !w0 = fi (w .>>. 24) .&. mask 240 !w1 = fi (w .>>. 16) .&. mask 241 !w2 = fi (w .>>. 08) .&. mask 242 !w3 = fi w .&. mask 243 in BS.cons w0 (BS.cons w1 (BS.cons w2 (BS.singleton w3))) 244 245 -- extended keys -------------------------------------------------------------- 246 247 -- | An extended public key. 248 newtype XPub = XPub (X Secp256k1.Projective) 249 deriving (Eq, Show, Generic) 250 251 -- | Read the raw public key from an 'XPub'. 252 xpub_key :: XPub -> Secp256k1.Projective 253 xpub_key (XPub (X pub _)) = pub 254 255 -- | Read the raw chain code from an 'XPub'. 256 xpub_cod :: XPub -> BS.ByteString 257 xpub_cod (XPub (X _ cod)) = cod 258 259 -- | An extended private key. 260 newtype XPrv = XPrv (X Wider) 261 deriving (Eq, Show, Generic) 262 263 -- | Read the raw private key from an 'XPrv'. 264 xprv_key :: XPrv -> Wider 265 xprv_key (XPrv (X sec _)) = sec 266 267 -- | Read the raw chain code from an 'XPrv'. 268 xprv_cod :: XPrv -> BS.ByteString 269 xprv_cod (XPrv (X _ cod)) = cod 270 271 -- | A public or private key, extended with a chain code. 272 data X a = X !a !BS.ByteString 273 deriving (Eq, Show, Generic) 274 275 -- | Key types supporting identifier/fingerprint calculation. 276 -- 277 -- >>> let Just hd = master "my very secret entropy" 278 -- >>> let Right my_xprv = hd_key hd 279 -- >>> let my_xpub = n k 280 -- >>> -- all have the same fingerprint 281 -- >>> fingerprint hd 282 -- "G\157\&8\146" 283 -- >>> fingerprint my_xprv 284 -- "G\157\&8\146" 285 -- >>> fingerprint my_xpub 286 -- "G\157\&8\146" 287 class Extended k where 288 -- | Calculate the identifier for an extended key. 289 identifier :: k -> BS.ByteString 290 291 -- | Calculate the fingerprint of an extended key. 292 fingerprint :: k -> BS.ByteString 293 fingerprint = BS.take 4 . identifier 294 295 instance Extended XPub where 296 identifier (XPub (X pub _)) = 297 let ser = Secp256k1.serialize_point pub 298 in RIPEMD160.hash (SHA256.hash ser) 299 300 instance Extended XPrv where 301 identifier (XPrv (X sec _)) = case Secp256k1.mul Secp256k1._CURVE_G sec of 302 Nothing -> 303 error "ppad-bip32 (identifier): internal error, evil extended key" 304 Just p -> 305 let ser = Secp256k1.serialize_point p 306 in RIPEMD160.hash (SHA256.hash ser) 307 308 -- internal key derivation functions------------------------------------------- 309 310 hardened :: Word32 -> Bool 311 hardened = (>= 0x8000_0000) 312 313 -- master xprv from seed 314 _master :: BS.ByteString -> Maybe XPrv 315 _master seed@(BI.PS _ _ l) 316 | l < 16 = Nothing 317 | l > 64 = Nothing 318 | otherwise = do 319 let i = SHA512.hmac "Bitcoin seed" seed 320 (il, c) = BS.splitAt 32 i 321 s = unsafe_roll32 il -- safe due to 512-bit hmac 322 pure $! (XPrv (X s c)) 323 324 -- private parent key -> private child key 325 ckd_priv :: XPrv -> Word32 -> XPrv 326 ckd_priv _xprv@(XPrv (X sec cod)) i = 327 let l = SHA512.hmac cod dat 328 (il, ci) = BS.splitAt 32 l 329 pil = unsafe_roll32 il -- safe due to 512-bit hmac 330 ki = S.from (S.to pil + S.to sec) 331 in if pil >= Secp256k1._CURVE_Q || ki == 0 -- negl 332 then ckd_priv _xprv (succ i) 333 else XPrv (X ki ci) 334 where 335 dat | hardened i = BS.singleton 0x00 <> unroll32 sec <> ser32 i 336 | otherwise = case Secp256k1.mul Secp256k1._CURVE_G sec of 337 Nothing -> 338 error "ppad-bip32 (ckd_priv): internal error, evil extended key" 339 Just p -> Secp256k1.serialize_point p <> ser32 i 340 341 -- public parent key -> public child key 342 ckd_pub :: XPub -> Word32 -> Maybe XPub 343 ckd_pub _xpub@(XPub (X pub cod)) i 344 | hardened i = Nothing 345 | otherwise = do 346 let dat = Secp256k1.serialize_point pub <> ser32 i 347 l = SHA512.hmac cod dat 348 (il, ci) = BS.splitAt 32 l 349 pil = unsafe_roll32 il -- safe due to 512-bit hmac 350 pt <- Secp256k1.mul_vartime Secp256k1._CURVE_G pil 351 let ki = pt `Secp256k1.add` pub 352 if pil >= Secp256k1._CURVE_Q || ki == Secp256k1._CURVE_ZERO -- negl 353 then ckd_pub _xpub (succ i) 354 else pure (XPub (X ki ci)) 355 356 -- private parent key -> public child key 357 n :: XPrv -> XPub 358 n (XPrv (X sec cod)) = case Secp256k1.mul Secp256k1._CURVE_G sec of 359 Nothing -> error "ppad-bip32 (n): internal error, evil extended key" 360 Just p -> XPub (X p cod) 361 362 -- fast variants -------------------------------------------------------------- 363 364 -- | The same as 'ckd_priv', but uses a 'Context' to optimise internal 365 -- calculations. 366 ckd_priv' :: Context -> XPrv -> Word32 -> XPrv 367 ckd_priv' ctx _xprv@(XPrv (X sec cod)) i = 368 let l = SHA512.hmac cod dat 369 (il, ci) = BS.splitAt 32 l 370 pil = unsafe_roll32 il -- safe due to 512-bit hmac 371 ki = S.from (S.to pil + S.to sec) 372 in if pil >= Secp256k1._CURVE_Q || ki == 0 -- negl 373 then ckd_priv' ctx _xprv (succ i) 374 else XPrv (X ki ci) 375 where 376 dat | hardened i = BS.singleton 0x00 <> unroll32 sec <> ser32 i 377 | otherwise = case Secp256k1.mul_wnaf ctx sec of 378 Nothing -> 379 error "ppad-bip32 (ckd_priv'): internal error, evil extended key" 380 Just p -> Secp256k1.serialize_point p <> ser32 i 381 382 -- | The same as 'ckd_pub', but uses a 'Context' to optimise internal 383 -- calculations. 384 ckd_pub' :: Context -> XPub -> Word32 -> Maybe XPub 385 ckd_pub' ctx _xpub@(XPub (X pub cod)) i 386 | hardened i = Nothing 387 | otherwise = do 388 let dat = Secp256k1.serialize_point pub <> ser32 i 389 l = SHA512.hmac cod dat 390 (il, ci) = BS.splitAt 32 l 391 pil = unsafe_roll32 il -- safe due to 512-bit hmac 392 pt <- Secp256k1.mul_wnaf ctx pil 393 let ki = pt `Secp256k1.add` pub 394 if pil >= Secp256k1._CURVE_Q || ki == Secp256k1._CURVE_ZERO -- negl 395 then ckd_pub' ctx _xpub (succ i) 396 else pure (XPub (X ki ci)) 397 398 -- | The same as 'n', but uses a 'Context' to optimise internal calculations. 399 n' :: Context -> XPrv -> XPub 400 n' ctx (XPrv (X sec cod)) = case Secp256k1.mul_wnaf ctx sec of 401 Nothing -> error "ppad-bip32 (n'): internal error, evil extended key" 402 Just p -> XPub (X p cod) 403 404 -- hierarchical deterministic keys -------------------------------------------- 405 406 -- | A BIP32 hierarchical deterministic key. 407 -- 408 -- This differs from lower-level "extended" keys in that it carries all 409 -- information required for serialization. 410 data HDKey = HDKey { 411 hd_key :: !(Either XPub XPrv) -- ^ extended public or private key 412 , hd_depth :: !Word8 -- ^ key depth 413 , hd_parent :: !BS.ByteString -- ^ parent fingerprint 414 , hd_child :: !BS.ByteString -- ^ index or child number 415 } 416 deriving (Eq, Show, Generic) 417 418 instance Extended HDKey where 419 identifier (HDKey ekey _ _ _) = case ekey of 420 Left l -> identifier l 421 Right r -> identifier r 422 423 -- | Derive a master 'HDKey' from a master seed. 424 -- 425 -- Fails with 'Nothing' if the provided seed has an invalid length. 426 -- 427 --- >>> let Just hd = master "my very secret entropy" 428 -- >>> xpub hd 429 -- "xpub661MyMwAqRbcGTJPtZRqZyrvjxHCfhqXeiqb5GVU3EGuFBy4QxT3yt8iiHwZTiCzZFyuyNiqXB3eqzqFZ8z4L6HCrPSkDVFNuW59LXYvMjs" 430 master :: BS.ByteString -> Maybe HDKey 431 master seed = do 432 m <- _master seed 433 pure $! HDKey { 434 hd_key = Right m 435 , hd_depth = 0 436 , hd_parent = "\NUL\NUL\NUL\NUL" -- 0x0000_0000 437 , hd_child = ser32 0 438 } 439 440 -- | Derive a private child node at the provided index. 441 -- 442 -- Fails with 'Nothing' if derivation is impossible. 443 -- 444 -- >>> let Just child_prv = derive_child_priv hd 0 445 -- >>> xpub child_prv 446 -- "xpub68R2ZbtFeJTFJApdEdPqW5cy3d5wF96tTfJErhu3mTi2Ttaqvc88BMPrgS3hQSrHj91kRbzVLM9pue9f8219szRKZuTAx1LWbdLDLFDm6Ly" 447 derive_child_priv :: HDKey -> Word32 -> Maybe HDKey 448 derive_child_priv HDKey {..} i = case hd_key of 449 Left _ -> Nothing 450 Right _xprv -> pure $! 451 let key = Right (ckd_priv _xprv i) 452 depth = hd_depth + 1 453 parent = fingerprint _xprv 454 child = ser32 i 455 in HDKey key depth parent child 456 457 -- | Derive a public child node at the provided index. 458 -- 459 -- Fails with 'Nothing' if derivation is impossible. 460 -- 461 -- >>> :set -XNumericUnderscores 462 -- >>> let Just child_pub = derive_child_pub child_prv 0x8000_0000 463 -- >>> xpub child_pub 464 -- "xpub6B6LoU83Cpyx1UVMwuoQdQvY2BuGbPd2xsEVxCnj85UGgDN9bRz82hQhe9UFmyo4Pokuhjc8M1Cfc8ufLxcL6FkCF7Zc2eajEfWfZwMFF6X" 465 derive_child_pub :: HDKey -> Word32 -> Maybe HDKey 466 derive_child_pub HDKey {..} i = do 467 (key, parent) <- case hd_key of 468 Left _xpub -> do 469 pub <- ckd_pub _xpub i 470 pure $! (pub, fingerprint _xpub) 471 Right _xprv -> 472 let pub = n (ckd_priv _xprv i) 473 in pure $! (pub, fingerprint _xprv) 474 let depth = hd_depth + 1 475 child = ser32 i 476 pure $! HDKey (Left key) depth parent child 477 478 -- | The same as 'derive_child_priv', but uses a 'Context' to optimise 479 -- internal calculations. 480 derive_child_priv' :: Context -> HDKey -> Word32 -> Maybe HDKey 481 derive_child_priv' ctx HDKey {..} i = case hd_key of 482 Left _ -> Nothing 483 Right _xprv -> pure $! 484 let key = Right (ckd_priv' ctx _xprv i) 485 depth = hd_depth + 1 486 parent = fingerprint _xprv 487 child = ser32 i 488 in HDKey key depth parent child 489 490 -- | The same as 'derive_child_pub', but uses a 'Context' to optimise 491 -- internal calculations. 492 derive_child_pub' :: Context -> HDKey -> Word32 -> Maybe HDKey 493 derive_child_pub' ctx HDKey {..} i = do 494 (key, parent) <- case hd_key of 495 Left _xpub -> do 496 pub <- ckd_pub' ctx _xpub i 497 pure $! (pub, fingerprint _xpub) 498 Right _xprv -> 499 let pub = n' ctx (ckd_priv' ctx _xprv i) 500 in pure $! (pub, fingerprint _xprv) 501 let depth = hd_depth + 1 502 child = ser32 i 503 pure $! HDKey (Left key) depth parent child 504 505 -- derivation path expression ------------------------------------------------- 506 507 -- recursive derivation path 508 data Path = 509 M 510 | !Path :| !Word32 -- hardened 511 | !Path :/ !Word32 512 deriving (Eq, Show) 513 514 parse_path :: BS.ByteString -> Maybe Path 515 parse_path bs = case BS.uncons bs of 516 Nothing -> Nothing 517 Just (h, t) 518 | h == 109 -> go M t -- == 'm' 519 | otherwise -> Nothing 520 where 521 child :: Path -> BS.ByteString -> Maybe (Path, BS.ByteString) 522 child pat b = case B8.readInt b of 523 Nothing -> Nothing 524 Just (fi -> i, etc) -> case BS.uncons etc of 525 Nothing -> Just $! (pat :/ i, mempty) 526 Just (h, t) 527 | h == 39 -> Just $! (pat :| i, t) -- ' 528 | otherwise -> Just $! (pat :/ i, etc) 529 530 go pat b = case BS.uncons b of 531 Nothing -> Just pat 532 Just (h, t) 533 | h == 47 -> do -- / 534 (npat, etc) <- child pat t 535 go npat etc 536 | otherwise -> 537 Nothing 538 539 -- | Derive a child node via the provided derivation path. 540 -- 541 -- Fails with 'Nothing' if derivation is impossible, or if the 542 -- provided path is invalid. 543 -- 544 -- >>> let Just hd = master "my very secret master seed" 545 -- >>> let Just child = derive hd "m/44'/0'/0'/0/0" 546 -- >>> xpub child 547 -- "xpub6FvaeGNFmCkLky6jwefrUfyH7gCGSAUckRBANT6wLQkm4eWZApsf4LqAadtbM8EBFfuKGFgzhgta4ByP6xnBodk2EV7BiwxCPLgu13oYWGp" 548 derive 549 :: HDKey 550 -> BS.ByteString -- ^ derivation path 551 -> Maybe HDKey 552 derive hd pat = case parse_path pat of 553 Nothing -> Nothing 554 Just p -> go p 555 where 556 go = \case 557 M -> pure hd 558 p :| i -> do 559 hdkey <- go p 560 derive_child_priv hdkey (0x8000_0000 + i) -- 2 ^ 31 561 p :/ i -> do 562 hdkey <- go p 563 derive_child_priv hdkey i 564 565 -- | Derive a child node via the provided derivation path. 566 -- 567 -- Fails with 'error' if derivation is impossible, or if the provided 568 -- path is invalid. 569 -- 570 -- >>> let other_child = derive_partial hd "m/44'/0'/0'/0/1" 571 -- >>> xpub other_child 572 -- "xpub6FvaeGNFmCkLpkT3uahJnGPTfEX62PtH7uZAyjtru8S2FvPuYTQKn8ct6CNQAwHMXaGN6EYuwi1Tz2VD7msftH8VTAtzgNra9CForA9FBP4" 573 derive_partial 574 :: HDKey 575 -> BS.ByteString 576 -> HDKey 577 derive_partial hd pat = case derive hd pat of 578 Nothing -> error "ppad-bip32 (derive_partial): couldn't derive extended key" 579 Just hdkey -> hdkey 580 581 -- | The same as 'derive', but uses a 'Context' to optimise internal 582 -- calculations. 583 -- 584 -- >>> let !ctx = precompute 585 -- >>> let Just child = derive' ctx hd "m/44'/0'/0'/0/0" 586 derive' 587 :: Context 588 -> HDKey 589 -> BS.ByteString -- ^ derivation path 590 -> Maybe HDKey 591 derive' ctx hd pat = case parse_path pat of 592 Nothing -> Nothing 593 Just p -> go p 594 where 595 go = \case 596 M -> pure hd 597 p :| i -> do 598 hdkey <- go p 599 derive_child_priv' ctx hdkey (0x8000_0000 + i) -- 2 ^ 31 600 p :/ i -> do 601 hdkey <- go p 602 derive_child_priv' ctx hdkey i 603 604 -- | The same as 'derive_partial', but uses a 'Context' to optimise internal 605 -- calculations. 606 -- 607 -- >>> let !ctx = precompute 608 -- >>> let child = derive_partial' ctx hd "m/44'/0'/0'/0/0" 609 derive_partial' 610 :: Context 611 -> HDKey 612 -> BS.ByteString 613 -> HDKey 614 derive_partial' ctx hd pat = case derive' ctx hd pat of 615 Nothing -> 616 error "ppad-bip32 (derive_partial'): couldn't derive extended key" 617 Just hdkey -> hdkey 618 619 -- serialization -------------------------------------------------------------- 620 621 _MAINNET_PUB, _MAINNET_PRV :: Word32 622 _TESTNET_PUB, _TESTNET_PRV :: Word32 623 624 _MAINNET_PUB_BYTES, _MAINNET_PRV_BYTES :: BS.ByteString 625 _TESTNET_PUB_BYTES, _TESTNET_PRV_BYTES :: BS.ByteString 626 627 _MAINNET_PUB = 0x0488B21E 628 _MAINNET_PUB_BYTES = "\EOT\136\178\RS" 629 630 _MAINNET_PRV = 0x0488ADE4 631 _MAINNET_PRV_BYTES = "\EOT\136\173\228" 632 633 _TESTNET_PUB = 0x043587CF 634 _TESTNET_PUB_BYTES = "\EOT5\135\207" 635 636 _TESTNET_PRV = 0x04358394 637 _TESTNET_PRV_BYTES = "\EOT5\131\148" 638 639 -- | Serialize a mainnet extended public key in base58check format. 640 -- 641 -- >>> let Just hd = master "my very secret entropy" 642 -- >>> xpub hd 643 -- "xpub661MyMwAqRbcGTJPtZRqZyrvjxHCfhqXeiqb5GVU3EGuFBy4QxT3yt8iiHwZTiCzZFyuyNiqXB3eqzqFZ8z4L6HCrPSkDVFNuW59LXYvMjs" 644 xpub :: HDKey -> BS.ByteString 645 xpub x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $ 646 case hd_key of 647 Left _ -> _serialize _MAINNET_PUB x 648 Right e -> _serialize _MAINNET_PUB HDKey { 649 hd_key = Left (n e) 650 , .. 651 } 652 653 -- | Serialize a mainnet extended private key in base58check format. 654 -- 655 -- >>> xprv hd 656 -- Just "xprv9s21ZrQH143K3yDvnXtqCqvCBvSiGF7gHVuzGt5rUtjvNPdusR8oS5pErywDM1jDDTcLpNNCbg9a9NuidBczRzSUp7seDeu8am64h6nfdrg" 657 xprv :: HDKey -> Maybe BS.ByteString 658 xprv x@HDKey {..} = case hd_key of 659 Left _ -> Nothing 660 Right _ -> do 661 let ser = _serialize _MAINNET_PRV x 662 pure $! (B58C.encode . BS.toStrict . BSB.toLazyByteString) ser 663 664 -- | Serialize a testnet extended public key in base58check format. 665 -- 666 -- >>> tpub hd 667 -- "tpubD6NzVbkrYhZ4YFVFLkQvmuCJ55Nrf6LbCMRtRpYcP92nzUdmVBJ98KoYxL2LzDAEMAWpaxEi4GshYBKrwzqJDXjVuzC3u1ucVTfZ6ZD415x" 668 tpub :: HDKey -> BS.ByteString 669 tpub x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $ 670 case hd_key of 671 Left _ -> _serialize _TESTNET_PUB x 672 Right e -> _serialize _TESTNET_PUB HDKey { 673 hd_key = Left (n e) 674 , .. 675 } 676 677 -- | Serialize a testnet extended private key in base58check format. 678 -- 679 -- >>> tprv hd 680 -- Just "tprv8ZgxMBicQKsPenTTT6kLNVYBW3rvVm9gd3q79JWJxsEQ9zNzrnUYwqBgnA6sMP7Xau97pTyxm2jNcETTkPxwF3i5Lm5wt1dBVrqV8kKi5v5" 681 tprv :: HDKey -> Maybe BS.ByteString 682 tprv x@HDKey {..} = case hd_key of 683 Left _ -> Nothing 684 Right _ -> do 685 let ser = _serialize _TESTNET_PRV x 686 pure $! (B58C.encode . BS.toStrict . BSB.toLazyByteString) ser 687 688 _serialize :: Word32 -> HDKey -> BSB.Builder 689 _serialize version HDKey {..} = 690 BSB.word32BE version 691 <> BSB.word8 hd_depth 692 <> BSB.byteString hd_parent 693 <> BSB.byteString hd_child 694 <> case hd_key of 695 Left (XPub (X pub cod)) -> 696 BSB.byteString cod 697 <> BSB.byteString (Secp256k1.serialize_point pub) 698 Right (XPrv (X sec cod)) -> 699 BSB.byteString cod 700 <> BSB.word8 0x00 701 <> BSB.byteString (unroll32 sec) 702 703 -- parsing -------------------------------------------------------------------- 704 705 data KeyType = 706 Pub 707 | Prv 708 709 -- | Parse a base58check-encoded 'ByteString' into a 'HDKey'. 710 -- 711 -- Fails with 'Nothing' if the provided key is invalid. 712 -- 713 -- >>> let Just hd = master "my very secret entropy" 714 -- >>> let Just my_xprv = parse (xprv hd) 715 -- >>> my_xprv == hd 716 -- True 717 parse :: BS.ByteString -> Maybe HDKey 718 parse b58 = do 719 bs <- B58C.decode b58 720 case BS.splitAt 4 bs of 721 (version, etc) 722 | version == _MAINNET_PUB_BYTES || version == _TESTNET_PUB_BYTES -> 723 parse_pub etc 724 | version == _MAINNET_PRV_BYTES || version == _TESTNET_PRV_BYTES -> 725 parse_prv etc 726 | otherwise -> 727 Nothing 728 where 729 parse_pub = _parse Pub 730 parse_prv = _parse Prv 731 732 _parse ktype bs = do 733 (hd_depth, etc0) <- BS.uncons bs 734 let (hd_parent, etc1) = BS.splitAt 4 etc0 735 guard (BS.length hd_parent == 4) 736 let (hd_child, etc2) = BS.splitAt 4 etc1 737 guard (BS.length hd_child == 4) 738 let (cod, etc3) = BS.splitAt 32 etc2 739 guard (BS.length cod == 32) 740 let (key, etc4) = BS.splitAt 33 etc3 741 guard (BS.length key == 33) 742 guard (BS.length etc4 == 0) 743 hd <- case ktype of 744 Pub -> do 745 pub <- Secp256k1.parse_point key 746 let hd_key = Left (XPub (X pub cod)) 747 pure HDKey {..} 748 Prv -> do 749 (b, unsafe_roll32 -> prv) <- BS.uncons key -- safe, guarded keylen 750 guard (b == 0) 751 guard (prv > 0 && prv < Secp256k1._CURVE_Q) 752 let hd_key = Right (XPrv (X prv cod)) 753 pure HDKey {..} 754 guard (valid_lineage hd) 755 pure hd 756 {-# INLINE _parse #-} 757 758 valid_lineage :: HDKey -> Bool 759 valid_lineage HDKey {..} 760 | hd_depth == 0 = 761 hd_parent == "\NUL\NUL\NUL\NUL" 762 && hd_child == "\NUL\NUL\NUL\NUL" 763 | otherwise = True 764