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