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