BIP32.hs (25674B)
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 = BI.unsafeCreate 4 $ \ptr -> do 240 Storable.pokeByteOff ptr 0 (fi (w .>>. 24) :: Word8) 241 Storable.pokeByteOff ptr 1 (fi (w .>>. 16) :: Word8) 242 Storable.pokeByteOff ptr 2 (fi (w .>>. 08) :: Word8) 243 Storable.pokeByteOff ptr 3 (fi w :: Word8) 244 {-# INLINABLE ser32 #-} 245 246 -- extended keys -------------------------------------------------------------- 247 248 -- | An extended public key. 249 newtype XPub = XPub (X Secp256k1.Projective) 250 deriving (Eq, Show, Generic) 251 252 -- | Read the raw public key from an 'XPub'. 253 xpub_key :: XPub -> Secp256k1.Projective 254 xpub_key (XPub (X pub _)) = pub 255 256 -- | Read the raw chain code from an 'XPub'. 257 xpub_cod :: XPub -> BS.ByteString 258 xpub_cod (XPub (X _ cod)) = cod 259 260 -- | An extended private key. 261 newtype XPrv = XPrv (X Wider) 262 deriving (Show, Generic) 263 264 -- | Read the raw private key from an 'XPrv'. 265 xprv_key :: XPrv -> Wider 266 xprv_key (XPrv (X sec _)) = sec 267 268 -- | Read the raw chain code from an 'XPrv'. 269 xprv_cod :: XPrv -> BS.ByteString 270 xprv_cod (XPrv (X _ cod)) = cod 271 272 -- | A public or private key, extended with a chain code. 273 data X a = X !a !BS.ByteString 274 deriving (Eq, Show, Generic) 275 276 -- | Key types supporting identifier/fingerprint calculation. 277 -- 278 -- >>> let Just hd = master "my very secret entropy" 279 -- >>> let Right my_xprv = hd_key hd 280 -- >>> let my_xpub = n k 281 -- >>> -- all have the same fingerprint 282 -- >>> fingerprint hd 283 -- "G\157\&8\146" 284 -- >>> fingerprint my_xprv 285 -- "G\157\&8\146" 286 -- >>> fingerprint my_xpub 287 -- "G\157\&8\146" 288 class Extended k where 289 -- | Calculate the identifier for an extended key. 290 identifier :: k -> BS.ByteString 291 292 -- | Calculate the fingerprint of an extended key. 293 fingerprint :: k -> BS.ByteString 294 fingerprint = BS.take 4 . identifier 295 296 instance Extended XPub where 297 identifier (XPub (X pub _)) = 298 let ser = Secp256k1.serialize_point pub 299 in RIPEMD160.hash (SHA256.hash ser) 300 301 instance Extended XPrv where 302 identifier (XPrv (X sec _)) = case Secp256k1.mul Secp256k1._CURVE_G sec of 303 Nothing -> 304 error "ppad-bip32 (identifier): internal error, evil extended key" 305 Just p -> 306 let ser = Secp256k1.serialize_point p 307 in RIPEMD160.hash (SHA256.hash ser) 308 309 -- internal key derivation functions------------------------------------------- 310 311 hardened :: Word32 -> Bool 312 hardened = (>= 0x8000_0000) 313 314 -- master xprv from seed 315 _master :: BS.ByteString -> Maybe XPrv 316 _master seed@(BI.PS _ _ l) 317 | l < 16 = Nothing 318 | l > 64 = Nothing 319 | otherwise = do 320 let SHA512.MAC i = SHA512.hmac "Bitcoin seed" seed 321 (il, c) = BS.splitAt 32 i 322 s = unsafe_roll32 il -- safe due to 512-bit hmac 323 pure $! (XPrv (X s c)) 324 325 -- private parent key -> private child key 326 ckd_priv :: XPrv -> Word32 -> XPrv 327 ckd_priv _xprv@(XPrv (X sec cod)) i = 328 let SHA512.MAC l = SHA512.hmac cod dat 329 (il, ci) = BS.splitAt 32 l 330 pil = unsafe_roll32 il -- safe due to 512-bit hmac 331 ki = S.from (S.to pil + S.to sec) 332 com = W.cmp_vartime pil Secp256k1._CURVE_Q 333 in if com /= LT || W.eq_vartime ki 0 -- negl 334 then ckd_priv _xprv (succ i) 335 else XPrv (X ki ci) 336 where 337 dat | hardened i = BS.singleton 0x00 <> unroll32 sec <> ser32 i 338 | otherwise = case Secp256k1.mul Secp256k1._CURVE_G sec of 339 Nothing -> 340 error "ppad-bip32 (ckd_priv): internal error, evil extended key" 341 Just p -> Secp256k1.serialize_point p <> ser32 i 342 343 -- public parent key -> public child key 344 ckd_pub :: XPub -> Word32 -> Maybe XPub 345 ckd_pub _xpub@(XPub (X pub cod)) i 346 | hardened i = Nothing 347 | otherwise = do 348 let dat = Secp256k1.serialize_point pub <> ser32 i 349 SHA512.MAC l = SHA512.hmac cod dat 350 (il, ci) = BS.splitAt 32 l 351 pil = unsafe_roll32 il -- safe due to 512-bit hmac 352 pt <- Secp256k1.mul_vartime Secp256k1._CURVE_G pil 353 let ki = pt `Secp256k1.add` pub 354 com = W.cmp_vartime pil Secp256k1._CURVE_Q 355 if com /= LT || ki == Secp256k1._CURVE_ZERO -- negl 356 then ckd_pub _xpub (succ i) 357 else pure (XPub (X ki ci)) 358 359 -- private parent key -> public child key 360 n :: XPrv -> XPub 361 n (XPrv (X sec cod)) = case Secp256k1.mul Secp256k1._CURVE_G sec of 362 Nothing -> error "ppad-bip32 (n): internal error, evil extended key" 363 Just p -> XPub (X p cod) 364 365 -- fast variants -------------------------------------------------------------- 366 367 -- | The same as 'ckd_priv', but uses a 'Context' to optimise internal 368 -- calculations. 369 ckd_priv' :: Context -> XPrv -> Word32 -> XPrv 370 ckd_priv' ctx _xprv@(XPrv (X sec cod)) i = 371 let SHA512.MAC l = SHA512.hmac cod dat 372 (il, ci) = BS.splitAt 32 l 373 pil = unsafe_roll32 il -- safe due to 512-bit hmac 374 ki = S.from (S.to pil + S.to sec) 375 com = W.cmp_vartime pil Secp256k1._CURVE_Q 376 in if com /= LT || W.eq_vartime ki 0 -- negl 377 then ckd_priv' ctx _xprv (succ i) 378 else XPrv (X ki ci) 379 where 380 dat | hardened i = BS.singleton 0x00 <> unroll32 sec <> ser32 i 381 | otherwise = case Secp256k1.mul_wnaf ctx sec of 382 Nothing -> 383 error "ppad-bip32 (ckd_priv'): internal error, evil extended key" 384 Just p -> Secp256k1.serialize_point p <> ser32 i 385 386 -- | The same as 'ckd_pub', but uses a 'Context' to optimise internal 387 -- calculations. 388 ckd_pub' :: Context -> XPub -> Word32 -> Maybe XPub 389 ckd_pub' ctx _xpub@(XPub (X pub cod)) i 390 | hardened i = Nothing 391 | otherwise = do 392 let dat = Secp256k1.serialize_point pub <> ser32 i 393 SHA512.MAC l = SHA512.hmac cod dat 394 (il, ci) = BS.splitAt 32 l 395 pil = unsafe_roll32 il -- safe due to 512-bit hmac 396 pt <- Secp256k1.mul_wnaf ctx pil 397 let ki = pt `Secp256k1.add` pub 398 com = W.cmp_vartime pil Secp256k1._CURVE_Q 399 if com /= LT || ki == Secp256k1._CURVE_ZERO -- negl 400 then ckd_pub' ctx _xpub (succ i) 401 else pure (XPub (X ki ci)) 402 403 -- | The same as 'n', but uses a 'Context' to optimise internal calculations. 404 n' :: Context -> XPrv -> XPub 405 n' ctx (XPrv (X sec cod)) = case Secp256k1.mul_wnaf ctx sec of 406 Nothing -> error "ppad-bip32 (n'): internal error, evil extended key" 407 Just p -> XPub (X p cod) 408 409 -- hierarchical deterministic keys -------------------------------------------- 410 411 -- | A BIP32 hierarchical deterministic key. 412 -- 413 -- This differs from lower-level "extended" keys in that it carries all 414 -- information required for serialization. 415 data HDKey = HDKey { 416 hd_key :: !(Either XPub XPrv) -- ^ extended public or private key 417 , hd_depth :: !Word8 -- ^ key depth 418 , hd_parent :: !BS.ByteString -- ^ parent fingerprint 419 , hd_child :: !BS.ByteString -- ^ index or child number 420 } 421 deriving (Show, Generic) 422 423 instance Extended HDKey where 424 identifier (HDKey ekey _ _ _) = case ekey of 425 Left l -> identifier l 426 Right r -> identifier r 427 428 -- | Derive a master 'HDKey' from a master seed. 429 -- 430 -- Fails with 'Nothing' if the provided seed has an invalid length. 431 -- 432 --- >>> let Just hd = master "my very secret entropy" 433 -- >>> xpub hd 434 -- "xpub661MyMwAqRbcGTJPtZRqZyrvjxHCfhqXeiqb5GVU3EGuFBy4QxT3yt8iiHwZTiCzZFyuyNiqXB3eqzqFZ8z4L6HCrPSkDVFNuW59LXYvMjs" 435 master :: BS.ByteString -> Maybe HDKey 436 master seed = do 437 m <- _master seed 438 pure $! HDKey { 439 hd_key = Right m 440 , hd_depth = 0 441 , hd_parent = "\NUL\NUL\NUL\NUL" -- 0x0000_0000 442 , hd_child = ser32 0 443 } 444 445 -- | Derive a private child node at the provided index. 446 -- 447 -- Fails with 'Nothing' if derivation is impossible. 448 -- 449 -- >>> let Just child_prv = derive_child_priv hd 0 450 -- >>> xpub child_prv 451 -- "xpub68R2ZbtFeJTFJApdEdPqW5cy3d5wF96tTfJErhu3mTi2Ttaqvc88BMPrgS3hQSrHj91kRbzVLM9pue9f8219szRKZuTAx1LWbdLDLFDm6Ly" 452 derive_child_priv :: HDKey -> Word32 -> Maybe HDKey 453 derive_child_priv HDKey {..} i = case hd_key of 454 Left _ -> Nothing 455 Right _xprv -> pure $! 456 let key = Right (ckd_priv _xprv i) 457 depth = hd_depth + 1 458 parent = fingerprint _xprv 459 child = ser32 i 460 in HDKey key depth parent child 461 462 -- | Derive a public child node at the provided index. 463 -- 464 -- Fails with 'Nothing' if derivation is impossible. 465 -- 466 -- >>> :set -XNumericUnderscores 467 -- >>> let Just child_pub = derive_child_pub child_prv 0x8000_0000 468 -- >>> xpub child_pub 469 -- "xpub6B6LoU83Cpyx1UVMwuoQdQvY2BuGbPd2xsEVxCnj85UGgDN9bRz82hQhe9UFmyo4Pokuhjc8M1Cfc8ufLxcL6FkCF7Zc2eajEfWfZwMFF6X" 470 derive_child_pub :: HDKey -> Word32 -> Maybe HDKey 471 derive_child_pub HDKey {..} i = do 472 (key, parent) <- case hd_key of 473 Left _xpub -> do 474 pub <- ckd_pub _xpub i 475 pure $! (pub, fingerprint _xpub) 476 Right _xprv -> 477 let pub = n (ckd_priv _xprv i) 478 in pure $! (pub, fingerprint _xprv) 479 let depth = hd_depth + 1 480 child = ser32 i 481 pure $! HDKey (Left key) depth parent child 482 483 -- | The same as 'derive_child_priv', but uses a 'Context' to optimise 484 -- internal calculations. 485 derive_child_priv' :: Context -> HDKey -> Word32 -> Maybe HDKey 486 derive_child_priv' ctx HDKey {..} i = case hd_key of 487 Left _ -> Nothing 488 Right _xprv -> pure $! 489 let key = Right (ckd_priv' ctx _xprv i) 490 depth = hd_depth + 1 491 parent = fingerprint _xprv 492 child = ser32 i 493 in HDKey key depth parent child 494 495 -- | The same as 'derive_child_pub', but uses a 'Context' to optimise 496 -- internal calculations. 497 derive_child_pub' :: Context -> HDKey -> Word32 -> Maybe HDKey 498 derive_child_pub' ctx HDKey {..} i = do 499 (key, parent) <- case hd_key of 500 Left _xpub -> do 501 pub <- ckd_pub' ctx _xpub i 502 pure $! (pub, fingerprint _xpub) 503 Right _xprv -> 504 let pub = n' ctx (ckd_priv' ctx _xprv i) 505 in pure $! (pub, fingerprint _xprv) 506 let depth = hd_depth + 1 507 child = ser32 i 508 pure $! HDKey (Left key) depth parent child 509 510 -- derivation path expression ------------------------------------------------- 511 512 -- recursive derivation path 513 data Path = 514 M 515 | !Path :| !Word32 -- hardened 516 | !Path :/ !Word32 517 deriving (Eq, Show) 518 519 parse_path :: BS.ByteString -> Maybe Path 520 parse_path bs = case BS.uncons bs of 521 Nothing -> Nothing 522 Just (h, t) 523 | h == 109 -> go M t -- == 'm' 524 | otherwise -> Nothing 525 where 526 child :: Path -> BS.ByteString -> Maybe (Path, BS.ByteString) 527 child pat b = case B8.readInt b of 528 Nothing -> Nothing 529 Just (fi -> i, etc) -> case BS.uncons etc of 530 Nothing -> Just $! (pat :/ i, mempty) 531 Just (h, t) 532 | h == 39 -> Just $! (pat :| i, t) -- ' 533 | otherwise -> Just $! (pat :/ i, etc) 534 535 go pat b = case BS.uncons b of 536 Nothing -> Just pat 537 Just (h, t) 538 | h == 47 -> do -- / 539 (npat, etc) <- child pat t 540 go npat etc 541 | otherwise -> 542 Nothing 543 544 -- | Derive a child node via the provided derivation path. 545 -- 546 -- Fails with 'Nothing' if derivation is impossible, or if the 547 -- provided path is invalid. 548 -- 549 -- >>> let Just hd = master "my very secret master seed" 550 -- >>> let Just child = derive hd "m/44'/0'/0'/0/0" 551 -- >>> xpub child 552 -- "xpub6FvaeGNFmCkLky6jwefrUfyH7gCGSAUckRBANT6wLQkm4eWZApsf4LqAadtbM8EBFfuKGFgzhgta4ByP6xnBodk2EV7BiwxCPLgu13oYWGp" 553 derive 554 :: HDKey 555 -> BS.ByteString -- ^ derivation path 556 -> Maybe HDKey 557 derive hd pat = case parse_path pat of 558 Nothing -> Nothing 559 Just p -> go p 560 where 561 go = \case 562 M -> pure hd 563 p :| i -> do 564 hdkey <- go p 565 derive_child_priv hdkey (0x8000_0000 + i) -- 2 ^ 31 566 p :/ i -> do 567 hdkey <- go p 568 derive_child_priv hdkey i 569 570 -- | Derive a child node via the provided derivation path. 571 -- 572 -- Fails with 'error' if derivation is impossible, or if the provided 573 -- path is invalid. 574 -- 575 -- >>> let other_child = derive_partial hd "m/44'/0'/0'/0/1" 576 -- >>> xpub other_child 577 -- "xpub6FvaeGNFmCkLpkT3uahJnGPTfEX62PtH7uZAyjtru8S2FvPuYTQKn8ct6CNQAwHMXaGN6EYuwi1Tz2VD7msftH8VTAtzgNra9CForA9FBP4" 578 derive_partial 579 :: HDKey 580 -> BS.ByteString 581 -> HDKey 582 derive_partial hd pat = case derive hd pat of 583 Nothing -> error "ppad-bip32 (derive_partial): couldn't derive extended key" 584 Just hdkey -> hdkey 585 586 -- | The same as 'derive', but uses a 'Context' to optimise internal 587 -- calculations. 588 -- 589 -- >>> let !ctx = precompute 590 -- >>> let Just child = derive' ctx hd "m/44'/0'/0'/0/0" 591 derive' 592 :: Context 593 -> HDKey 594 -> BS.ByteString -- ^ derivation path 595 -> Maybe HDKey 596 derive' ctx hd pat = case parse_path pat of 597 Nothing -> Nothing 598 Just p -> go p 599 where 600 go = \case 601 M -> pure hd 602 p :| i -> do 603 hdkey <- go p 604 derive_child_priv' ctx hdkey (0x8000_0000 + i) -- 2 ^ 31 605 p :/ i -> do 606 hdkey <- go p 607 derive_child_priv' ctx hdkey i 608 609 -- | The same as 'derive_partial', but uses a 'Context' to optimise internal 610 -- calculations. 611 -- 612 -- >>> let !ctx = precompute 613 -- >>> let child = derive_partial' ctx hd "m/44'/0'/0'/0/0" 614 derive_partial' 615 :: Context 616 -> HDKey 617 -> BS.ByteString 618 -> HDKey 619 derive_partial' ctx hd pat = case derive' ctx hd pat of 620 Nothing -> 621 error "ppad-bip32 (derive_partial'): couldn't derive extended key" 622 Just hdkey -> hdkey 623 624 -- serialization -------------------------------------------------------------- 625 626 _MAINNET_PUB, _MAINNET_PRV :: Word32 627 _TESTNET_PUB, _TESTNET_PRV :: Word32 628 629 _MAINNET_PUB_BYTES, _MAINNET_PRV_BYTES :: BS.ByteString 630 _TESTNET_PUB_BYTES, _TESTNET_PRV_BYTES :: BS.ByteString 631 632 _MAINNET_PUB = 0x0488B21E 633 _MAINNET_PUB_BYTES = "\EOT\136\178\RS" 634 635 _MAINNET_PRV = 0x0488ADE4 636 _MAINNET_PRV_BYTES = "\EOT\136\173\228" 637 638 _TESTNET_PUB = 0x043587CF 639 _TESTNET_PUB_BYTES = "\EOT5\135\207" 640 641 _TESTNET_PRV = 0x04358394 642 _TESTNET_PRV_BYTES = "\EOT5\131\148" 643 644 -- | Serialize a mainnet extended public key in base58check format. 645 -- 646 -- >>> let Just hd = master "my very secret entropy" 647 -- >>> xpub hd 648 -- "xpub661MyMwAqRbcGTJPtZRqZyrvjxHCfhqXeiqb5GVU3EGuFBy4QxT3yt8iiHwZTiCzZFyuyNiqXB3eqzqFZ8z4L6HCrPSkDVFNuW59LXYvMjs" 649 xpub :: HDKey -> BS.ByteString 650 xpub x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $ 651 case hd_key of 652 Left _ -> _serialize _MAINNET_PUB x 653 Right e -> _serialize _MAINNET_PUB HDKey { 654 hd_key = Left (n e) 655 , .. 656 } 657 658 -- | Serialize a mainnet extended private key in base58check format. 659 -- 660 -- >>> xprv hd 661 -- Just "xprv9s21ZrQH143K3yDvnXtqCqvCBvSiGF7gHVuzGt5rUtjvNPdusR8oS5pErywDM1jDDTcLpNNCbg9a9NuidBczRzSUp7seDeu8am64h6nfdrg" 662 xprv :: HDKey -> Maybe BS.ByteString 663 xprv x@HDKey {..} = case hd_key of 664 Left _ -> Nothing 665 Right _ -> do 666 let ser = _serialize _MAINNET_PRV x 667 pure $! (B58C.encode . BS.toStrict . BSB.toLazyByteString) ser 668 669 -- | Serialize a testnet extended public key in base58check format. 670 -- 671 -- >>> tpub hd 672 -- "tpubD6NzVbkrYhZ4YFVFLkQvmuCJ55Nrf6LbCMRtRpYcP92nzUdmVBJ98KoYxL2LzDAEMAWpaxEi4GshYBKrwzqJDXjVuzC3u1ucVTfZ6ZD415x" 673 tpub :: HDKey -> BS.ByteString 674 tpub x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $ 675 case hd_key of 676 Left _ -> _serialize _TESTNET_PUB x 677 Right e -> _serialize _TESTNET_PUB HDKey { 678 hd_key = Left (n e) 679 , .. 680 } 681 682 -- | Serialize a testnet extended private key in base58check format. 683 -- 684 -- >>> tprv hd 685 -- Just "tprv8ZgxMBicQKsPenTTT6kLNVYBW3rvVm9gd3q79JWJxsEQ9zNzrnUYwqBgnA6sMP7Xau97pTyxm2jNcETTkPxwF3i5Lm5wt1dBVrqV8kKi5v5" 686 tprv :: HDKey -> Maybe BS.ByteString 687 tprv x@HDKey {..} = case hd_key of 688 Left _ -> Nothing 689 Right _ -> do 690 let ser = _serialize _TESTNET_PRV x 691 pure $! (B58C.encode . BS.toStrict . BSB.toLazyByteString) ser 692 693 _serialize :: Word32 -> HDKey -> BSB.Builder 694 _serialize version HDKey {..} = 695 BSB.word32BE version 696 <> BSB.word8 hd_depth 697 <> BSB.byteString hd_parent 698 <> BSB.byteString hd_child 699 <> case hd_key of 700 Left (XPub (X pub cod)) -> 701 BSB.byteString cod 702 <> BSB.byteString (Secp256k1.serialize_point pub) 703 Right (XPrv (X sec cod)) -> 704 BSB.byteString cod 705 <> BSB.word8 0x00 706 <> BSB.byteString (unroll32 sec) 707 708 -- parsing -------------------------------------------------------------------- 709 710 data KeyType = 711 Pub 712 | Prv 713 714 -- | Parse a base58check-encoded 'ByteString' into a 'HDKey'. 715 -- 716 -- Fails with 'Nothing' if the provided key is invalid. 717 -- 718 -- >>> let Just hd = master "my very secret entropy" 719 -- >>> let Just my_xprv = parse (xprv hd) 720 -- >>> my_xprv == hd 721 -- True 722 parse :: BS.ByteString -> Maybe HDKey 723 parse b58 = do 724 bs <- B58C.decode b58 725 case BS.splitAt 4 bs of 726 (version, etc) 727 | version == _MAINNET_PUB_BYTES || version == _TESTNET_PUB_BYTES -> 728 parse_pub etc 729 | version == _MAINNET_PRV_BYTES || version == _TESTNET_PRV_BYTES -> 730 parse_prv etc 731 | otherwise -> 732 Nothing 733 where 734 parse_pub = _parse Pub 735 parse_prv = _parse Prv 736 737 _parse ktype bs = do 738 (hd_depth, etc0) <- BS.uncons bs 739 let (hd_parent, etc1) = BS.splitAt 4 etc0 740 guard (BS.length hd_parent == 4) 741 let (hd_child, etc2) = BS.splitAt 4 etc1 742 guard (BS.length hd_child == 4) 743 let (cod, etc3) = BS.splitAt 32 etc2 744 guard (BS.length cod == 32) 745 let (key, etc4) = BS.splitAt 33 etc3 746 guard (BS.length key == 33) 747 guard (BS.length etc4 == 0) 748 hd <- case ktype of 749 Pub -> do 750 pub <- Secp256k1.parse_point key 751 let hd_key = Left (XPub (X pub cod)) 752 pure HDKey {..} 753 Prv -> do 754 (b, unsafe_roll32 -> prv) <- BS.uncons key -- safe, guarded keylen 755 guard (b == 0) 756 let com0 = W.gt prv 0 757 com1 = W.lt prv Secp256k1._CURVE_Q 758 guard (C.decide (C.and com0 com1)) 759 let hd_key = Right (XPrv (X prv cod)) 760 pure HDKey {..} 761 guard (valid_lineage hd) 762 pure hd 763 {-# INLINE _parse #-} 764 765 valid_lineage :: HDKey -> Bool 766 valid_lineage HDKey {..} 767 | hd_depth == 0 = 768 hd_parent == "\NUL\NUL\NUL\NUL" 769 && hd_child == "\NUL\NUL\NUL\NUL" 770 | otherwise = True 771