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