commit 2ce742c04d9c794f6fb0dda3b631f3df4905201c
parent 9696a67e84a765c53c4636cad30ce900b358520a
Author: Jared Tobin <jared@jtobin.io>
Date: Fri, 20 Jun 2025 15:12:04 +0400
lib: more total work
Hide X, XPrv, XPub constructors; make xprv/tprv total.
Diffstat:
3 files changed, 65 insertions(+), 55 deletions(-)
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -1,5 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -9,17 +10,14 @@ import Criterion.Main
import Crypto.HDKey.BIP32
import Control.DeepSeq
import Crypto.Curve.Secp256k1 as S
+import qualified Data.Maybe as M
instance NFData S.Projective
-
-instance NFData XPub where
- rnf (XPub (X a b)) = a `deepseq` b `deepseq` ()
-
-instance NFData XPrv where
- rnf (XPrv (X a b)) = a `deepseq` b `deepseq` ()
-
-instance NFData HDKey where
- rnf (HDKey a b c d) = a `deepseq` b `deepseq` c `deepseq` d `deepseq` ()
+instance NFData (X Integer)
+instance NFData (X S.Projective)
+instance NFData XPub
+instance NFData XPrv
+instance NFData HDKey
main :: IO ()
main = defaultMain [
@@ -54,5 +52,5 @@ bench_xprv :: Benchmark
bench_xprv = bench "xprv" $ nf xprv m
bench_parse :: Benchmark
-bench_parse = bench "parse" $ nf parse (xprv m)
+bench_parse = bench "parse" $ nf parse (M.fromJust (xprv m))
diff --git a/lib/Crypto/HDKey/BIP32.hs b/lib/Crypto/HDKey/BIP32.hs
@@ -1,6 +1,7 @@
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -24,9 +25,9 @@ module Crypto.HDKey.BIP32 (
-- * Extended keys
, Extended(..)
- , XPub(..)
- , XPrv(..)
- , X(..)
+ , XPub
+ , XPrv
+ , X
, ckd_pub
, ckd_priv
, n
@@ -61,6 +62,7 @@ import qualified Data.ByteString.Base58Check as B58C
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Internal as BI
import Data.Word (Word8, Word32)
+import GHC.Generics
-- utilities ------------------------------------------------------------------
@@ -106,15 +108,15 @@ ser32 w =
-- | An extended public key.
newtype XPub = XPub (X Secp256k1.Projective)
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic)
-- | An extended private key.
newtype XPrv = XPrv (X Integer)
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic)
-- | A public or private key, extended with a chain code.
data X a = X !a !BS.ByteString
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic)
-- | Key types supporting identifier/fingerprint calculation.
--
@@ -143,7 +145,8 @@ instance Extended XPub where
instance Extended XPrv where
identifier (XPrv (X sec _)) = case Secp256k1.mul Secp256k1._CURVE_G sec of
- Nothing -> error "ppad-bip32 (identifier): evil extended key"
+ Nothing ->
+ error "ppad-bip32 (identifier): internal error, evil extended key"
Just p ->
let ser = Secp256k1.serialize_point p
in RIPEMD160.hash (SHA256.hash ser)
@@ -177,7 +180,8 @@ ckd_priv _xprv@(XPrv (X sec cod)) i =
where
dat | hardened i = BS.singleton 0x00 <> ser256 sec <> ser32 i
| otherwise = case Secp256k1.mul Secp256k1._CURVE_G sec of
- Nothing -> error "ppad-bip32 (ckd_priv): evil extended key"
+ Nothing ->
+ error "ppad-bip32 (ckd_priv): internal error, evil extended key"
Just p -> Secp256k1.serialize_point p <> ser32 i
-- public parent key -> public child key
@@ -198,7 +202,7 @@ ckd_pub _xpub@(XPub (X pub cod)) i
-- private parent key -> public child key
n :: XPrv -> XPub
n (XPrv (X sec cod)) = case Secp256k1.mul Secp256k1._CURVE_G sec of
- Nothing -> error "ppad-bip32 (n): evil extended key"
+ Nothing -> error "ppad-bip32 (n): internal error, evil extended key"
Just p -> XPub (X p cod)
-- hierarchical deterministic keys --------------------------------------------
@@ -213,7 +217,7 @@ data HDKey = HDKey {
, hd_parent :: !BS.ByteString -- ^ parent fingerprint
, hd_child :: !BS.ByteString -- ^ index or child number
}
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic)
instance Extended HDKey where
identifier (HDKey ekey _ _ _) = case ekey of
@@ -340,7 +344,7 @@ derive hd pat = case parse_path pat of
-- Fails with 'error' if derivation is impossible, or if the provided
-- path is invalid.
--
--- >>> let Just other_child = derive hd "m/44'/0'/0'/0/1"
+-- >>> let other_child = derive_partial hd "m/44'/0'/0'/0/1"
-- >>> xpub other_child
-- "xpub6FvaeGNFmCkLpkT3uahJnGPTfEX62PtH7uZAyjtru8S2FvPuYTQKn8ct6CNQAwHMXaGN6EYuwi1Tz2VD7msftH8VTAtzgNra9CForA9FBP4"
derive_partial
@@ -388,12 +392,13 @@ xpub x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $
-- | Serialize a mainnet extended private key in base58check format.
--
-- >>> xprv hd
--- "xprv9s21ZrQH143K3yDvnXtqCqvCBvSiGF7gHVuzGt5rUtjvNPdusR8oS5pErywDM1jDDTcLpNNCbg9a9NuidBczRzSUp7seDeu8am64h6nfdrg"
-xprv :: HDKey -> BS.ByteString
-xprv x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $
- case hd_key of
- Left _ -> error "ppad-bip32 (xprv): no private key"
- Right _ -> _serialize _MAINNET_PRV x
+-- Just "xprv9s21ZrQH143K3yDvnXtqCqvCBvSiGF7gHVuzGt5rUtjvNPdusR8oS5pErywDM1jDDTcLpNNCbg9a9NuidBczRzSUp7seDeu8am64h6nfdrg"
+xprv :: HDKey -> Maybe BS.ByteString
+xprv x@HDKey {..} = case hd_key of
+ Left _ -> Nothing
+ Right _ -> do
+ let ser = _serialize _MAINNET_PRV x
+ pure $! (B58C.encode . BS.toStrict . BSB.toLazyByteString) ser
-- | Serialize a testnet extended public key in base58check format.
--
@@ -411,12 +416,13 @@ tpub x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $
-- | Serialize a testnet extended private key in base58check format.
--
-- >>> tprv hd
--- "tprv8ZgxMBicQKsPenTTT6kLNVYBW3rvVm9gd3q79JWJxsEQ9zNzrnUYwqBgnA6sMP7Xau97pTyxm2jNcETTkPxwF3i5Lm5wt1dBVrqV8kKi5v5"
-tprv :: HDKey -> BS.ByteString
-tprv x@HDKey {..} = B58C.encode . BS.toStrict . BSB.toLazyByteString $
- case hd_key of
- Left _ -> error "ppad-bip32 (tprv): no private key"
- Right _ -> _serialize _TESTNET_PRV x
+-- Just "tprv8ZgxMBicQKsPenTTT6kLNVYBW3rvVm9gd3q79JWJxsEQ9zNzrnUYwqBgnA6sMP7Xau97pTyxm2jNcETTkPxwF3i5Lm5wt1dBVrqV8kKi5v5"
+tprv :: HDKey -> Maybe BS.ByteString
+tprv x@HDKey {..} = case hd_key of
+ Left _ -> Nothing
+ Right _ -> do
+ let ser = _serialize _TESTNET_PRV x
+ pure $! (B58C.encode . BS.toStrict . BSB.toLazyByteString) ser
_serialize :: Word32 -> HDKey -> BSB.Builder
_serialize version HDKey {..} =
diff --git a/test/Main.hs b/test/Main.hs
@@ -9,6 +9,12 @@ import qualified Data.ByteString.Base16 as B16
import Test.Tasty
import qualified Test.Tasty.HUnit as H
+-- for testing
+xprv_partial :: HDKey -> BS.ByteString
+xprv_partial val = case xprv val of
+ Nothing -> error "bang"
+ Just v -> v
+
main :: IO ()
main = defaultMain $ testGroup "BIP32 vectors" [
vector_1
@@ -63,38 +69,38 @@ vector_1 :: TestTree
vector_1 = H.testCase "BIP32 vector 1" $ do
let Just _m = master seed_1
H.assertEqual "M" xpub_1_m (xpub _m)
- H.assertEqual "m" xprv_1_m (xprv _m)
+ H.assertEqual "m" xprv_1_m (xprv_partial _m)
let Just _m_0' = derive_child_priv _m 0x80000000
H.assertEqual "M/0'" xpub_1_m_0' (xpub _m_0')
- H.assertEqual "m/0'" xprv_1_m_0' (xprv _m_0')
+ H.assertEqual "m/0'" xprv_1_m_0' (xprv_partial _m_0')
H.assertEqual "M/0', path" xpub_1_m_0' (xpub (derive_partial _m "m/0'"))
- H.assertEqual "m/0', path" xprv_1_m_0' (xprv (derive_partial _m "m/0'"))
+ H.assertEqual "m/0', path" xprv_1_m_0' (xprv_partial (derive_partial _m "m/0'"))
let Just _m_0'_1 = derive_child_priv _m_0' 1
H.assertEqual "M/0'/1" xpub_1_m_0'_1 (xpub _m_0'_1)
- H.assertEqual "m/0'/1" xprv_1_m_0'_1 (xprv _m_0'_1)
+ H.assertEqual "m/0'/1" xprv_1_m_0'_1 (xprv_partial _m_0'_1)
H.assertEqual "M/0'/1" xpub_1_m_0'_1 (xpub (derive_partial _m "m/0'/1"))
- H.assertEqual "m/0'/1" xprv_1_m_0'_1 (xprv (derive_partial _m "m/0'/1"))
+ H.assertEqual "m/0'/1" xprv_1_m_0'_1 (xprv_partial (derive_partial _m "m/0'/1"))
let Just _m_0'_1_2' = derive_child_priv _m_0'_1 (0x80000000 + 2)
H.assertEqual "M/0'/1/2'" xpub_1_m_0'_1_2' (xpub _m_0'_1_2')
- H.assertEqual "m/0'/1/2'" xprv_1_m_0'_1_2' (xprv _m_0'_1_2')
+ H.assertEqual "m/0'/1/2'" xprv_1_m_0'_1_2' (xprv_partial _m_0'_1_2')
H.assertEqual "M/0'/1/2'" xpub_1_m_0'_1_2' (xpub (derive_partial _m "m/0'/1/2'"))
- H.assertEqual "m/0'/1/2'" xprv_1_m_0'_1_2' (xprv (derive_partial _m "m/0'/1/2'"))
+ H.assertEqual "m/0'/1/2'" xprv_1_m_0'_1_2' (xprv_partial (derive_partial _m "m/0'/1/2'"))
let Just _m_0'_1_2'_2 = derive_child_priv _m_0'_1_2' 2
H.assertEqual "M/0'/1/2'/2" xpub_1_m_0'_1_2'_2 (xpub _m_0'_1_2'_2)
- H.assertEqual "m/0'/1/2'/2" xprv_1_m_0'_1_2'_2 (xprv _m_0'_1_2'_2)
+ H.assertEqual "m/0'/1/2'/2" xprv_1_m_0'_1_2'_2 (xprv_partial _m_0'_1_2'_2)
H.assertEqual "M/0'/1/2'/2" xpub_1_m_0'_1_2'_2
(xpub (derive_partial _m "m/0'/1/2'/2"))
H.assertEqual "m/0'/1/2'/2" xprv_1_m_0'_1_2'_2
- (xprv (derive_partial _m "m/0'/1/2'/2"))
+ (xprv_partial (derive_partial _m "m/0'/1/2'/2"))
let Just _m_0'_1_2'_2_1000000000 = derive_child_priv _m_0'_1_2'_2 1000000000
H.assertEqual "M/0'/1/2'/2/1000000000" xpub_1_m_0'_1_2'_2_1000000000
(xpub _m_0'_1_2'_2_1000000000)
H.assertEqual "m/0'/1/2'/2/1000000000" xprv_1_m_0'_1_2'_2_1000000000
- (xprv _m_0'_1_2'_2_1000000000)
+ (xprv_partial _m_0'_1_2'_2_1000000000)
H.assertEqual "M/0'/1/2'/2/1000000000" xpub_1_m_0'_1_2'_2_1000000000
(xpub (derive_partial _m "m/0'/1/2'/2/1000000000"))
H.assertEqual "m/0'/1/2'/2/1000000000" xprv_1_m_0'_1_2'_2_1000000000
- (xprv (derive_partial _m "m/0'/1/2'/2/1000000000"))
+ (xprv_partial (derive_partial _m "m/0'/1/2'/2/1000000000"))
seed_2 :: BS.ByteString
seed_2 = case B16.decode "fffcf9f6f3f0edeae7e4e1dedbd8d5d2cfccc9c6c3c0bdbab7b4b1aeaba8a5a29f9c999693908d8a8784817e7b7875726f6c696663605d5a5754514e4b484542" of
@@ -108,34 +114,34 @@ vector_2 = H.testCase "BIP32 vector 2" $ do
H.assertEqual "M" "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB"
(xpub _m)
H.assertEqual "m" "xprv9s21ZrQH143K31xYSDQpPDxsXRTUcvj2iNHm5NUtrGiGG5e2DtALGdso3pGz6ssrdK4PFmM8NSpSBHNqPqm55Qn3LqFtT2emdEXVYsCzC2U"
- (xprv _m)
+ (xprv_partial _m)
let _m_0 = derive_partial mas "m/0"
H.assertEqual "M/0" "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH"
(xpub _m_0)
H.assertEqual "m/0" "xprv9vHkqa6EV4sPZHYqZznhT2NPtPCjKuDKGY38FBWLvgaDx45zo9WQRUT3dKYnjwih2yJD9mkrocEZXo1ex8G81dwSM1fwqWpWkeS3v86pgKt"
- (xprv _m_0)
+ (xprv_partial _m_0)
let _m_0_2147483647' = derive_partial mas "m/0/2147483647'"
H.assertEqual "M/0/2147483647'" "xpub6ASAVgeehLbnwdqV6UKMHVzgqAG8Gr6riv3Fxxpj8ksbH9ebxaEyBLZ85ySDhKiLDBrQSARLq1uNRts8RuJiHjaDMBU4Zn9h8LZNnBC5y4a"
(xpub _m_0_2147483647')
H.assertEqual "m/0/2147483647'" "xprv9wSp6B7kry3Vj9m1zSnLvN3xH8RdsPP1Mh7fAaR7aRLcQMKTR2vidYEeEg2mUCTAwCd6vnxVrcjfy2kRgVsFawNzmjuHc2YmYRmagcEPdU9"
- (xprv _m_0_2147483647')
+ (xprv_partial _m_0_2147483647')
let _m_0_2147483647'_1 = derive_partial mas "m/0/2147483647'/1"
H.assertEqual "M/0/2147483647'/1" "xpub6DF8uhdarytz3FWdA8TvFSvvAh8dP3283MY7p2V4SeE2wyWmG5mg5EwVvmdMVCQcoNJxGoWaU9DCWh89LojfZ537wTfunKau47EL2dhHKon"
(xpub _m_0_2147483647'_1)
H.assertEqual "m/0/2147483647'/1" "xprv9zFnWC6h2cLgpmSA46vutJzBcfJ8yaJGg8cX1e5StJh45BBciYTRXSd25UEPVuesF9yog62tGAQtHjXajPPdbRCHuWS6T8XA2ECKADdw4Ef"
- (xprv _m_0_2147483647'_1)
+ (xprv_partial _m_0_2147483647'_1)
let _m_0_2147483647'_1_2147483646' =
derive_partial mas "m/0/2147483647'/1/2147483646'"
H.assertEqual "M/0/2147483647'/1/2147483646'" "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL"
(xpub _m_0_2147483647'_1_2147483646')
H.assertEqual "m/0/2147483647'/1/2147483646'" "xprvA1RpRA33e1JQ7ifknakTFpgNXPmW2YvmhqLQYMmrj4xJXXWYpDPS3xz7iAxn8L39njGVyuoseXzU6rcxFLJ8HFsTjSyQbLYnMpCqE2VbFWc"
- (xprv _m_0_2147483647'_1_2147483646')
+ (xprv_partial _m_0_2147483647'_1_2147483646')
let _m_0_2147483647'_1_2147483646'_2 =
derive_partial mas "m/0/2147483647'/1/2147483646'/2"
H.assertEqual "M/0/2147483647'/1/2147483646'/2" "xpub6FnCn6nSzZAw5Tw7cgR9bi15UV96gLZhjDstkXXxvCLsUXBGXPdSnLFbdpq8p9HmGsApME5hQTZ3emM2rnY5agb9rXpVGyy3bdW6EEgAtqt"
(xpub _m_0_2147483647'_1_2147483646'_2)
H.assertEqual "m/0/2147483647'/1/2147483646'/2" "xprvA2nrNbFZABcdryreWet9Ea4LvTJcGsqrMzxHx98MMrotbir7yrKCEXw7nadnHM8Dq38EGfSh6dqA9QWTyefMLEcBYJUuekgW4BYPJcr9E7j"
- (xprv _m_0_2147483647'_1_2147483646'_2)
+ (xprv_partial _m_0_2147483647'_1_2147483646'_2)
seed_3 :: BS.ByteString
seed_3 = case B16.decode "4b381541583be4423346c643850da4b320e46a87ae3d2a4e6da11eba819cd4acba45d239319ac14f863b8d5ab5a0d0c64d2e8a1e7d1457df2e5a3c51c73235be" of
@@ -149,12 +155,12 @@ vector_3 = H.testCase "BIP32 vector 3" $ do
H.assertEqual "M" "xpub661MyMwAqRbcEZVB4dScxMAdx6d4nFc9nvyvH3v4gJL378CSRZiYmhRoP7mBy6gSPSCYk6SzXPTf3ND1cZAceL7SfJ1Z3GC8vBgp2epUt13"
(xpub _m)
H.assertEqual "m" "xprv9s21ZrQH143K25QhxbucbDDuQ4naNntJRi4KUfWT7xo4EKsHt2QJDu7KXp1A3u7Bi1j8ph3EGsZ9Xvz9dGuVrtHHs7pXeTzjuxBrCmmhgC6"
- (xprv _m)
+ (xprv_partial _m)
let _m_0' = derive_partial mas "m/0'"
H.assertEqual "M/0'" "xpub68NZiKmJWnxxS6aaHmn81bvJeTESw724CRDs6HbuccFQN9Ku14VQrADWgqbhhTHBaohPX4CjNLf9fq9MYo6oDaPPLPxSb7gwQN3ih19Zm4Y"
(xpub _m_0')
H.assertEqual "m/0'" "xprv9uPDJpEQgRQfDcW7BkF7eTya6RPxXeJCqCJGHuCJ4GiRVLzkTXBAJMu2qaMWPrS7AANYqdq6vcBcBUdJCVVFceUvJFjaPdGZ2y9WACViL4L"
- (xprv _m_0')
+ (xprv_partial _m_0')
seed_4 :: BS.ByteString
seed_4 = case B16.decode "3ddd5602285899a946114506157c7997e5444528f3003f6134712147db19b678" of
@@ -168,17 +174,17 @@ vector_4 = H.testCase "BIP32 vector 4" $ do
H.assertEqual "M" "xpub661MyMwAqRbcGczjuMoRm6dXaLDEhW1u34gKenbeYqAix21mdUKJyuyu5F1rzYGVxyL6tmgBUAEPrEz92mBXjByMRiJdba9wpnN37RLLAXa"
(xpub _m)
H.assertEqual "m" "xprv9s21ZrQH143K48vGoLGRPxgo2JNkJ3J3fqkirQC2zVdk5Dgd5w14S7fRDyHH4dWNHUgkvsvNDCkvAwcSHNAQwhwgNMgZhLtQC63zxwhQmRv"
- (xprv _m)
+ (xprv_partial _m)
let _m_0' = derive_partial mas "m/0'"
H.assertEqual "M/0'" "xpub69AUMk3qDBi3uW1sXgjCmVjJ2G6WQoYSnNHyzkmdCHEhSZ4tBok37xfFEqHd2AddP56Tqp4o56AePAgCjYdvpW2PU2jbUPFKsav5ut6Ch1m"
(xpub _m_0')
H.assertEqual "m/0'" "xprv9vB7xEWwNp9kh1wQRfCCQMnZUEG21LpbR9NPCNN1dwhiZkjjeGRnaALmPXCX7SgjFTiCTT6bXes17boXtjq3xLpcDjzEuGLQBM5ohqkao9G"
- (xprv _m_0')
+ (xprv_partial _m_0')
let _m_0'_1' = derive_partial mas "m/0'/1'"
H.assertEqual "M/0'/1'" "xpub6BJA1jSqiukeaesWfxe6sNK9CCGaujFFSJLomWHprUL9DePQ4JDkM5d88n49sMGJxrhpjazuXYWdMf17C9T5XnxkopaeS7jGk1GyyVziaMt"
(xpub _m_0'_1')
H.assertEqual "m/0'/1'" "xprv9xJocDuwtYCMNAo3Zw76WENQeAS6WGXQ55RCy7tDJ8oALr4FWkuVoHJeHVAcAqiZLE7Je3vZJHxspZdFHfnBEjHqU5hG1Jaj32dVoS6XLT1"
- (xprv _m_0'_1')
+ (xprv_partial _m_0'_1')
vector_5 :: TestTree
vector_5 = H.testCase "BIP32 vector 5" $ do
