commit e8732d3c8950901056484fc977a8c3cd51c13b8c
parent 9828a12a5892a51e8e574159d48873d91a048b84
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 27 Dec 2025 13:39:01 -0330
lib: update to fixed v0.1.2, secp256k1 v0.5.1
Diffstat:
4 files changed, 42 insertions(+), 20 deletions(-)
diff --git a/README.md b/README.md
@@ -54,16 +54,16 @@ Current benchmark figures on an M4 Silicon MacBook Air look like (use
```
benchmarking ppad-bip32 (wNAF)/derive_child_pub'
- time 180.7 μs (180.6 μs .. 180.9 μs)
+ time 211.1 μs (210.9 μs .. 211.5 μs)
1.000 R² (1.000 R² .. 1.000 R²)
- mean 180.8 μs (180.6 μs .. 180.9 μs)
- std dev 493.6 ns (382.1 ns .. 639.6 ns)
+ mean 212.0 μs (211.6 μs .. 212.3 μs)
+ std dev 1.164 μs (1.001 μs .. 1.336 μs)
benchmarking ppad-bip32 (wNAF)/derive_child_priv'
- time 167.0 μs (166.8 μs .. 167.2 μs)
+ time 184.5 μs (183.1 μs .. 185.7 μs)
1.000 R² (1.000 R² .. 1.000 R²)
- mean 167.0 μs (166.8 μs .. 167.2 μs)
- std dev 667.4 ns (488.1 ns .. 925.3 ns)
+ mean 183.6 μs (183.3 μs .. 184.1 μs)
+ std dev 1.346 μs (907.9 ns .. 2.111 μs)
benchmarking ppad-bip32/xpub
time 149.6 μs (149.1 μs .. 150.2 μs)
@@ -78,10 +78,10 @@ Current benchmark figures on an M4 Silicon MacBook Air look like (use
std dev 19.72 ns (12.91 ns .. 34.71 ns)
benchmarking ppad-bip32/parse
- time 6.905 μs (6.899 μs .. 6.913 μs)
+ time 6.746 μs (6.739 μs .. 6.753 μs)
1.000 R² (1.000 R² .. 1.000 R²)
- mean 6.926 μs (6.919 μs .. 6.933 μs)
- std dev 23.14 ns (18.74 ns .. 28.17 ns)
+ mean 6.764 μs (6.754 μs .. 6.777 μs)
+ std dev 37.04 ns (27.90 ns .. 51.11 ns)
```
You should compile with the 'llvm' flag (and ensure [ppad-fixed][fixed],
diff --git a/lib/Crypto/HDKey/BIP32.hs b/lib/Crypto/HDKey/BIP32.hs
@@ -79,10 +79,12 @@ import qualified Data.ByteString.Base58Check as B58C
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as BU
+import qualified Data.Choice as C
import Data.Word (Word8, Word32)
import Data.Word.Limb (Limb(..))
import qualified Data.Word.Limb as L
import Data.Word.Wider (Wider(..))
+import qualified Data.Word.Wider as W
import qualified Foreign.Storable as Storable (pokeByteOff)
import qualified GHC.Exts as Exts
import GHC.Generics
@@ -258,7 +260,7 @@ xpub_cod (XPub (X _ cod)) = cod
-- | An extended private key.
newtype XPrv = XPrv (X Wider)
- deriving (Eq, Show, Generic)
+ deriving (Show, Generic)
-- | Read the raw private key from an 'XPrv'.
xprv_key :: XPrv -> Wider
@@ -328,7 +330,8 @@ ckd_priv _xprv@(XPrv (X sec cod)) i =
(il, ci) = BS.splitAt 32 l
pil = unsafe_roll32 il -- safe due to 512-bit hmac
ki = S.from (S.to pil + S.to sec)
- in if pil >= Secp256k1._CURVE_Q || ki == 0 -- negl
+ com = W.cmp_vartime pil Secp256k1._CURVE_Q
+ in if com /= LT || W.eq_vartime ki 0 -- negl
then ckd_priv _xprv (succ i)
else XPrv (X ki ci)
where
@@ -348,8 +351,9 @@ ckd_pub _xpub@(XPub (X pub cod)) i
(il, ci) = BS.splitAt 32 l
pil = unsafe_roll32 il -- safe due to 512-bit hmac
pt <- Secp256k1.mul_vartime Secp256k1._CURVE_G pil
- let ki = pt `Secp256k1.add` pub
- if pil >= Secp256k1._CURVE_Q || ki == Secp256k1._CURVE_ZERO -- negl
+ let ki = pt `Secp256k1.add` pub
+ com = W.cmp_vartime pil Secp256k1._CURVE_Q
+ if com /= LT || ki == Secp256k1._CURVE_ZERO -- negl
then ckd_pub _xpub (succ i)
else pure (XPub (X ki ci))
@@ -369,7 +373,8 @@ ckd_priv' ctx _xprv@(XPrv (X sec cod)) i =
(il, ci) = BS.splitAt 32 l
pil = unsafe_roll32 il -- safe due to 512-bit hmac
ki = S.from (S.to pil + S.to sec)
- in if pil >= Secp256k1._CURVE_Q || ki == 0 -- negl
+ com = W.cmp_vartime pil Secp256k1._CURVE_Q
+ in if com /= LT || W.eq_vartime ki 0 -- negl
then ckd_priv' ctx _xprv (succ i)
else XPrv (X ki ci)
where
@@ -391,7 +396,8 @@ ckd_pub' ctx _xpub@(XPub (X pub cod)) i
pil = unsafe_roll32 il -- safe due to 512-bit hmac
pt <- Secp256k1.mul_wnaf ctx pil
let ki = pt `Secp256k1.add` pub
- if pil >= Secp256k1._CURVE_Q || ki == Secp256k1._CURVE_ZERO -- negl
+ com = W.cmp_vartime pil Secp256k1._CURVE_Q
+ if com /= LT || ki == Secp256k1._CURVE_ZERO -- negl
then ckd_pub' ctx _xpub (succ i)
else pure (XPub (X ki ci))
@@ -413,7 +419,7 @@ data HDKey = HDKey {
, hd_parent :: !BS.ByteString -- ^ parent fingerprint
, hd_child :: !BS.ByteString -- ^ index or child number
}
- deriving (Eq, Show, Generic)
+ deriving (Show, Generic)
instance Extended HDKey where
identifier (HDKey ekey _ _ _) = case ekey of
@@ -748,7 +754,9 @@ parse b58 = do
Prv -> do
(b, unsafe_roll32 -> prv) <- BS.uncons key -- safe, guarded keylen
guard (b == 0)
- guard (prv > 0 && prv < Secp256k1._CURVE_Q)
+ let com0 = W.gt prv 0
+ com1 = W.lt prv Secp256k1._CURVE_Q
+ guard (C.decide (C.and com0 com1))
let hd_key = Right (XPrv (X prv cod))
pure HDKey {..}
guard (valid_lineage hd)
diff --git a/ppad-bip32.cabal b/ppad-bip32.cabal
@@ -37,9 +37,9 @@ library
base >= 4.9 && < 5
, bytestring >= 0.9 && < 0.13
, ppad-base58 >= 0.2 && < 0.3
- , ppad-fixed >= 0.1 && < 0.2
+ , ppad-fixed >= 0.1.2 && < 0.2
, ppad-ripemd160 >= 0.1.3 && < 0.2
- , ppad-secp256k1 >= 0.5 && < 0.6
+ , ppad-secp256k1 >= 0.5.1 && < 0.6
, ppad-sha256 >= 0.2.3 && < 0.3
, ppad-sha512 >= 0.1.3 && < 0.2
@@ -59,6 +59,7 @@ test-suite bip32-tests
, ppad-base16
, ppad-base58
, ppad-bip32
+ , ppad-fixed
, tasty
, tasty-hunit
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
@@ -6,9 +6,22 @@ module Main where
import Crypto.HDKey.BIP32
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
+import qualified Data.Word.Wider as W
import Test.Tasty
import qualified Test.Tasty.HUnit as H
+instance Eq XPrv where
+ x1 == x2 = W.eq_vartime (xprv_key x1) (xprv_key x2)
+ && xprv_cod x1 == xprv_cod x2
+
+instance Eq HDKey where
+ HDKey k1 d1 p1 c1 == HDKey k2 d2 p2 c2 =
+ eqKey k1 k2 && d1 == d2 && p1 == p2 && c1 == c2
+ where
+ eqKey (Left a) (Left b) = a == b
+ eqKey (Right a) (Right b) = a == b
+ eqKey _ _ = False
+
-- for testing
xprv_partial :: HDKey -> BS.ByteString
xprv_partial val = case xprv val of
