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