ppad-secp256k1 (empty) → 0.1.0
raw patch · 9 files changed
+1797/−0 lines, 9 filesdep +aesondep +attoparsecdep +base
Dependencies added: aeson, attoparsec, base, base16-bytestring, bytestring, criterion, deepseq, ppad-hmac-drbg, ppad-secp256k1, ppad-sha256, tasty, tasty-hunit, text
Files
- CHANGELOG +6/−0
- LICENSE +20/−0
- bench/Main.hs +183/−0
- lib/Crypto/Curve/Secp256k1.hs +941/−0
- ppad-secp256k1.cabal +74/−0
- test/BIP340.hs +89/−0
- test/Main.hs +178/−0
- test/Noble.hs +138/−0
- test/Wycheproof.hs +168/−0
+ CHANGELOG view
@@ -0,0 +1,6 @@+# Changelog++- 0.1.0 (2024-10-19)+ * Initial release, supporting public key derivation and Schnorr &+ ECDSA signatures on secp256k1.+
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2024 Jared Tobin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ bench/Main.hs view
@@ -0,0 +1,183 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import Control.DeepSeq+import Criterion.Main+import qualified Crypto.Curve.Secp256k1 as S++instance NFData S.Projective+instance NFData S.Affine+instance NFData S.ECDSA+instance NFData S.Word256++main :: IO ()+main = defaultMain [+ parse_point+ , add+ , mul+ , derive_pub+ , schnorr+ , ecdsa+ ]++remQ :: Benchmark+remQ = env setup $ \x ->+ bgroup "remQ (remainder modulo _CURVE_Q)" [+ bench "remQ 2 " $ nf S.remQ 2+ , bench "remQ (2 ^ 255 - 19)" $ nf S.remQ x+ ]+ where+ setup = pure . S.parse_int256 $ B16.decodeLenient+ "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed"++parse_point :: Benchmark+parse_point = bgroup "parse_point" [+ bench "compressed" $ nf S.parse_point p_bs+ , bench "uncompressed" $ nf S.parse_point t_bs+ , bench "bip0340" $ nf S.parse_point (BS.drop 1 p_bs)+ ]++parse_integer :: Benchmark+parse_integer = env setup $ \ ~(small, big) ->+ bgroup "parse_int256" [+ bench "parse_int256 (small)" $ nf S.parse_int256 small+ , bench "parse_int256 (big)" $ nf S.parse_int256 big+ ]+ where+ setup = do+ let small = BS.replicate 32 0x00+ big = BS.replicate 32 0xFF+ pure (small, big)++add :: Benchmark+add = bgroup "add" [+ bench "2 p (double, trivial projective point)" $ nf (S.add p) p+ , bench "2 r (double, nontrivial projective point)" $ nf (S.add r) r+ , bench "p + q (trivial projective points)" $ nf (S.add p) q+ , bench "p + s (nontrivial mixed points)" $ nf (S.add p) s+ , bench "s + r (nontrivial projective points)" $ nf (S.add s) r+ ]++mul :: Benchmark+mul = env setup $ \x ->+ bgroup "mul" [+ bench "2 G" $ nf (S.mul S._CURVE_G) 2+ , bench "(2 ^ 255 - 19) G" $ nf (S.mul S._CURVE_G) x+ ]+ where+ setup = pure . S.parse_int256 $ B16.decodeLenient+ "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed"++derive_pub :: Benchmark+derive_pub = env setup $ \x ->+ bgroup "derive_pub" [+ bench "sk = 2" $ nf S.derive_pub 2+ , bench "sk = 2 ^ 255 - 19" $ nf S.derive_pub x+ ]+ where+ setup = pure . S.parse_int256 $ B16.decodeLenient+ "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed"++schnorr :: Benchmark+schnorr = env setup $ \big ->+ bgroup "schnorr" [+ bench "sign_schnorr (small secret)" $ nf (S.sign_schnorr 2 s_msg) s_aux+ , bench "sign_schnorr (large secret)" $ nf (S.sign_schnorr big s_msg) s_aux+ , bench "verify_schnorr" $ nf (S.verify_schnorr s_msg s_pk) s_sig+ ]+ where+ setup = pure . S.parse_int256 $ B16.decodeLenient+ "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed"++ecdsa :: Benchmark+ecdsa = env setup $ \ ~(big, pub, msg, sig) ->+ bgroup "ecdsa" [+ bench "sign_ecdsa (small)" $ nf (S.sign_ecdsa 2) s_msg+ , bench "sign_ecdsa (large)" $ nf (S.sign_ecdsa big) s_msg+ , bench "verify_ecdsa" $ nf (S.verify_ecdsa msg pub) sig+ ]+ where+ setup = do+ let big = S.parse_int256 $ B16.decodeLenient+ "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed"+ pub = S.derive_pub big+ msg = "i approve of this message"+ sig = S.sign_ecdsa big s_msg+ pure (big, pub, msg, sig)++p_bs :: BS.ByteString+p_bs = B16.decodeLenient+ "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"++p :: S.Projective+p = case S.parse_point p_bs of+ Nothing -> error "bang"+ Just !pt -> pt++q_bs :: BS.ByteString+q_bs = B16.decodeLenient+ "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9"++q :: S.Projective+q = case S.parse_point q_bs of+ Nothing -> error "bang"+ Just !pt -> pt++r_bs :: BS.ByteString+r_bs = B16.decodeLenient+ "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8"++r :: S.Projective+r = case S.parse_point r_bs of+ Nothing -> error "bang"+ Just !pt -> pt++s_bs :: BS.ByteString+s_bs = B16.decodeLenient+ "0306413898a49c93cccf3db6e9078c1b6a8e62568e4a4770e0d7d96792d1c580ad"++s :: S.Projective+s = case S.parse_point s_bs of+ Nothing -> error "bang"+ Just !pt -> pt++t_bs :: BS.ByteString+t_bs = B16.decodeLenient "04b838ff44e5bc177bf21189d0766082fc9d843226887fc9760371100b7ee20a6ff0c9d75bfba7b31a6bca1974496eeb56de357071955d83c4b1badaa0b21832e9"++t :: S.Projective+t = case S.parse_point t_bs of+ Nothing -> error "bang"+ Just !pt -> pt++s_sk :: Integer+s_sk = S.parse_int256 . B16.decodeLenient $+ "B7E151628AED2A6ABF7158809CF4F3C762E7160F38B4DA56A784D9045190CFEF"++s_sig :: BS.ByteString+s_sig = B16.decodeLenient "6896BD60EEAE296DB48A229FF71DFE071BDE413E6D43F917DC8DCF8C78DE33418906D11AC976ABCCB20B091292BFF4EA897EFCB639EA871CFA95F6DE339E4B0A"++s_pk_raw :: BS.ByteString+s_pk_raw = B16.decodeLenient+ "DFF1D77F2A671C5F36183726DB2341BE58FEAE1DA2DECED843240F7B502BA659"++s_pk :: S.Projective+s_pk = case S.parse_point s_pk_raw of+ Nothing -> error "bang"+ Just !pt -> pt++s_msg :: BS.ByteString+s_msg = B16.decodeLenient+ "243F6A8885A308D313198A2E03707344A4093822299F31D0082EFA98EC4E6C89"++s_aux :: BS.ByteString+s_aux = B16.decodeLenient+ "0000000000000000000000000000000000000000000000000000000000000001"++-- e_msg = B16.decodeLenient "313233343030"+-- e_sig = B16.decodeLenient "3045022100813ef79ccefa9a56f7ba805f0e478584fe5f0dd5f567bc09b5123ccbc983236502206ff18a52dcc0336f7af62400a6dd9b810732baf1ff758000d6f613a556eb31ba"+
+ lib/Crypto/Curve/Secp256k1.hs view
@@ -0,0 +1,941 @@+{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module: Crypto.Curve.Secp256k1+-- Copyright: (c) 2024 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Pure [BIP0340](https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki)+-- Schnorr signatures and deterministic+-- [RFC6979](https://www.rfc-editor.org/rfc/rfc6979) ECDSA (with+-- [BIP0146](https://github.com/bitcoin/bips/blob/master/bip-0146.mediawiki)-style+-- "low-S" signatures) on the elliptic curve secp256k1.++module Crypto.Curve.Secp256k1 (+ -- * secp256k1 points+ Pub+ , derive_pub++ -- * Parsing+ , parse_int256+ , parse_point++ -- * BIP0340 Schnorr signatures+ , sign_schnorr+ , verify_schnorr++ -- * RFC6979 ECDSA+ , ECDSA(..)+ , SigType(..)+ , sign_ecdsa+ , sign_ecdsa_unrestricted+ , verify_ecdsa+ , verify_ecdsa_unrestricted++ -- Elliptic curve group operations+ , neg+ , add+ , double+ , mul+ , mul_unsafe++ -- Coordinate systems and transformations+ , Affine(..)+ , Projective(..)+ , affine+ , projective+ , valid++ -- for testing/benchmarking+ , Word256(..)+ , _sign_ecdsa_no_hash+ , _CURVE_P+ , _CURVE_Q+ , _CURVE_G+ , remQ+ , modQ+ ) where++import Control.Monad (when)+import Control.Monad.ST+import qualified Crypto.DRBG.HMAC as DRBG+import qualified Crypto.Hash.SHA256 as SHA256+import Data.Bits ((.|.))+import qualified Data.Bits as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BU+import Data.STRef+import Data.Word (Word8, Word64)+import GHC.Generics+import GHC.Natural+import qualified GHC.Num.Integer as I++-- note the use of GHC.Num.Integer-qualified functions throughout this+-- module; in some cases explicit use of these functions (especially+-- I.integerPowMod# and I.integerRecipMod#) yields tremendous speedups+-- compared to more general versions++-- keystroke savers & other utilities -----------------------------------------++fi :: (Integral a, Num b) => a -> b+fi = fromIntegral+{-# INLINE fi #-}++-- generic modular exponentiation+-- b ^ e mod m+modexp :: Integer -> Natural -> Natural -> Integer+modexp b (fi -> e) m = case I.integerPowMod# b e m of+ (# fi -> n | #) -> n+ (# | _ #) -> error "negative power impossible"+{-# INLINE modexp #-}++-- generic modular inverse+-- for a, m return x such that ax = 1 mod m+modinv :: Integer -> Natural -> Maybe Integer+modinv a m = case I.integerRecipMod# a m of+ (# fi -> n | #) -> Just $! n+ (# | _ #) -> Nothing+{-# INLINE modinv #-}++-- bytewise xor+xor :: BS.ByteString -> BS.ByteString -> BS.ByteString+xor = BS.packZipWith B.xor++-- arbitrary-size big-endian bytestring decoding+roll :: BS.ByteString -> Integer+roll = BS.foldl' alg 0 where+ alg !a (fi -> !b) = (a `I.integerShiftL` 8) `I.integerOr` b++data Word256 = Word256+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ deriving (Eq, Show, Generic)++word256_to_integer :: Word256 -> Integer+word256_to_integer (Word256 w0 w1 w2 w3) =+ (fi w0 `B.shiftL` 192)+ .|. (fi w1 `B.shiftL` 128)+ .|. (fi w2 `B.shiftL` 64)+ .|. fi w3+{-# INLINE word256_to_integer #-}++-- /Note:/ there can be substantial differences in execution time+-- when this function is called with "extreme" inputs. For example: a+-- bytestring consisting entirely of 0x00 bytes will parse more quickly+-- than one consisting of entirely 0xFF bytes. For appropriately-random+-- inputs, timings should be indistinguishable.+--+-- Using Word256 under the hood speeds up this function dramatically.++-- 256-bit big-endian bytestring decoding. the input size is not checked!+roll32 :: BS.ByteString -> Integer+roll32 bs = word256_to_integer $! (go 0 0 0 0 0) where+ go !acc0 !acc1 !acc2 !acc3 !j+ | j == 32 = Word256 acc0 acc1 acc2 acc3+ | j < 8 =+ let b = fi (BU.unsafeIndex bs j)+ in go ((acc0 `B.shiftL` 8) .|. b) acc1 acc2 acc3 (j + 1)+ | j < 16 =+ let b = fi (BU.unsafeIndex bs j)+ in go acc0 ((acc1 `B.shiftL` 8) .|. b) acc2 acc3 (j + 1)+ | j < 24 =+ let b = fi (BU.unsafeIndex bs j)+ in go acc0 acc1 ((acc2 `B.shiftL` 8) .|. b) acc3 (j + 1)+ | otherwise =+ let b = fi (BU.unsafeIndex bs j)+ in go acc0 acc1 acc2 ((acc3 `B.shiftL` 8) .|. b) (j + 1)+{-# INLINE roll32 #-}++-- this "looks" inefficient due to the call to reverse, but it's+-- actually really fast++-- big-endian bytestring encoding+unroll :: Integer -> BS.ByteString+unroll i = case i of+ 0 -> BS.singleton 0+ _ -> BS.reverse $ BS.unfoldr step i+ where+ step 0 = Nothing+ step m = Just (fi m, m `I.integerShiftR` 8)++-- big-endian bytestring encoding for 256-bit ints, left-padding with+-- zeros if necessary. the size of the integer is not checked.+unroll32 :: Integer -> BS.ByteString+unroll32 (unroll -> u)+ | l < 32 = BS.replicate (32 - l) 0 <> u+ | otherwise = u+ where+ l = BS.length u++-- replacing the following w/a series of functions with the hashed tags+-- hard-coded is possible, but there is virtually no performance benefit++-- (bip0340) tagged hash function+hash_tagged :: BS.ByteString -> BS.ByteString -> BS.ByteString+hash_tagged tag x =+ let !h = SHA256.hash tag+ in SHA256.hash (h <> h <> x)++-- (bip0340) return point with x coordinate == x and with even y coordinate+lift :: Integer -> Maybe Affine+lift x+ | not (fe x) = Nothing+ | otherwise =+ let c = remP (modexp x 3 (fi _CURVE_P) + 7) -- modexp always nonnegative+ e = (_CURVE_P + 1) `I.integerQuot` 4+ y = modexp c (fi e) (fi _CURVE_P)+ y_p | B.testBit y 0 = _CURVE_P - y+ | otherwise = y+ in if c /= modexp y 2 (fi _CURVE_P)+ then Nothing+ else Just $! (Affine x y_p)++-- coordinate systems & transformations ---------------------------------------++-- curve point, affine coordinates+data Affine = Affine !Integer !Integer+ deriving stock (Show, Generic)++instance Eq Affine where+ Affine x1 y1 == Affine x2 y2 =+ modP x1 == modP x2 && modP y1 == modP y2++-- curve point, projective coordinates+data Projective = Projective {+ px :: !Integer+ , py :: !Integer+ , pz :: !Integer+ }+ deriving stock (Show, Generic)++instance Eq Projective where+ Projective ax ay az == Projective bx by bz =+ let x1z2 = modP (ax * bz)+ x2z1 = modP (bx * az)+ y1z2 = modP (ay * bz)+ y2z1 = modP (by * az)+ in x1z2 == x2z1 && y1z2 == y2z1++-- | A Schnorr and ECDSA-flavoured alias for a secp256k1 point.+type Pub = Projective++-- Convert to affine coordinates.+affine :: Projective -> Affine+affine p@(Projective x y z)+ | p == _ZERO = Affine 0 0+ | z == 1 = Affine x y+ | otherwise = case modinv z (fi _CURVE_P) of+ Nothing -> error "ppad-secp256k1 (affine): impossible point"+ Just iz -> Affine (modP (x * iz)) (modP (y * iz))++-- Convert to projective coordinates.+projective :: Affine -> Projective+projective (Affine x y)+ | x == 0 && y == 0 = _ZERO+ | otherwise = Projective x y 1++-- Point is valid+valid :: Projective -> Bool+valid p = case affine p of+ Affine x y+ | not (fe x) || not (fe y) -> False+ | modP (y * y) /= weierstrass x -> False+ | otherwise -> True++-- curve parameters -----------------------------------------------------------+-- see https://www.secg.org/sec2-v2.pdf for parameter specs++-- secp256k1 field prime+--+-- = 2^256 - 2^32 - 2^9 - 2^8 - 2^7 - 2^6 - 2^4 - 1+_CURVE_P :: Integer+_CURVE_P = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F++-- secp256k1 group order+_CURVE_Q :: Integer+_CURVE_Q = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141++-- bitlength of group order+--+-- = smallest integer such that _CURVE_Q < 2 ^ _CURVE_Q_BITS+_CURVE_Q_BITS :: Int+_CURVE_Q_BITS = 256++-- bytelength of _CURVE_Q+--+-- = _CURVE_Q_BITS / 8+_CURVE_Q_BYTES :: Int+_CURVE_Q_BYTES = 32++-- secp256k1 short weierstrass form, /a/ coefficient+_CURVE_A :: Integer+_CURVE_A = 0++-- secp256k1 weierstrass form, /b/ coefficient+_CURVE_B :: Integer+_CURVE_B = 7++-- secp256k1 generator+--+-- = parse_point+-- "0279BE667EF9DCBBAC55A06295CE870B07029BFCDB2DCE28D959F2815B16F81798"+_CURVE_G :: Projective+_CURVE_G = Projective x y 1 where+ x = 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798+ y = 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8++-- secp256k1 zero point / point at infinity / monoidal identity+_ZERO :: Projective+_ZERO = Projective 0 1 0++-- secp256k1 in prime order j-invariant 0 form (i.e. a == 0).+weierstrass :: Integer -> Integer+weierstrass x = remP (remP (x * x) * x + _CURVE_B)+{-# INLINE weierstrass #-}++-- field, group operations ----------------------------------------------------++-- Division modulo secp256k1 field prime.+modP :: Integer -> Integer+modP a = I.integerMod a _CURVE_P+{-# INLINE modP #-}++-- Division modulo secp256k1 field prime, when argument is nonnegative.+-- (more efficient than modP)+remP :: Integer -> Integer+remP a = I.integerRem a _CURVE_P+{-# INLINE remP #-}++-- Division modulo secp256k1 group order.+modQ :: Integer -> Integer+modQ a = I.integerMod a _CURVE_Q+{-# INLINE modQ #-}++-- Division modulo secp256k1 group order, when argument is nonnegative.+-- (more efficient than modQ)+remQ :: Integer -> Integer+remQ a = I.integerRem a _CURVE_Q+{-# INLINE remQ #-}++-- Is field element?+fe :: Integer -> Bool+fe n = 0 < n && n < _CURVE_P+{-# INLINE fe #-}++-- Is group element?+ge :: Integer -> Bool+ge n = 0 < n && n < _CURVE_Q+{-# INLINE ge #-}++-- Square root (Shanks-Tonelli) modulo secp256k1 field prime.+--+-- For a, return x such that a = x x mod _CURVE_P.+modsqrtP :: Integer -> Maybe Integer+modsqrtP n = runST $ do+ r <- newSTRef 1+ num <- newSTRef n+ e <- newSTRef ((_CURVE_P + 1) `I.integerQuot` 4)++ let loop = do+ ev <- readSTRef e+ when (ev > 0) $ do+ when (I.integerTestBit ev 0) $ do+ numv <- readSTRef num+ modifySTRef' r (\rv -> (rv * numv) `I.integerRem` _CURVE_P)+ modifySTRef' num (\numv -> (numv * numv) `I.integerRem` _CURVE_P)+ modifySTRef' e (`I.integerShiftR` 1)+ loop++ loop+ rv <- readSTRef r+ pure $+ if remP (rv * rv) == n+ then Just $! rv+ else Nothing++-- ec point operations --------------------------------------------------------++-- Negate secp256k1 point.+neg :: Projective -> Projective+neg (Projective x y z) = Projective x (modP (negate y)) z++-- Elliptic curve addition on secp256k1.+add :: Projective -> Projective -> Projective+add p q@(Projective _ _ z)+ | p == q = double p -- algo 9+ | z == 1 = add_mixed p q -- algo 8+ | otherwise = add_proj p q -- algo 7++-- algo 7, "complete addition formulas for prime order elliptic curves,"+-- renes et al, 2015+--+-- https://eprint.iacr.org/2015/1060.pdf+add_proj :: Projective -> Projective -> Projective+add_proj (Projective x1 y1 z1) (Projective x2 y2 z2) = runST $ do+ x3 <- newSTRef 0+ y3 <- newSTRef 0+ z3 <- newSTRef 0+ let b3 = remP (_CURVE_B * 3)+ t0 <- newSTRef (modP (x1 * x2)) -- 1+ t1 <- newSTRef (modP (y1 * y2))+ t2 <- newSTRef (modP (z1 * z2))+ t3 <- newSTRef (modP (x1 + y1)) -- 4+ t4 <- newSTRef (modP (x2 + y2))+ readSTRef t4 >>= \r4 ->+ modifySTRef' t3 (\r3 -> modP (r3 * r4))+ readSTRef t0 >>= \r0 ->+ readSTRef t1 >>= \r1 ->+ writeSTRef t4 (modP (r0 + r1))+ readSTRef t4 >>= \r4 ->+ modifySTRef' t3 (\r3 -> modP (r3 - r4)) -- 8+ writeSTRef t4 (modP (y1 + z1))+ writeSTRef x3 (modP (y2 + z2))+ readSTRef x3 >>= \rx3 ->+ modifySTRef' t4 (\r4 -> modP (r4 * rx3))+ readSTRef t1 >>= \r1 ->+ readSTRef t2 >>= \r2 ->+ writeSTRef x3 (modP (r1 + r2)) -- 12+ readSTRef x3 >>= \rx3 ->+ modifySTRef' t4 (\r4 -> modP (r4 - rx3))+ writeSTRef x3 (modP (x1 + z1))+ writeSTRef y3 (modP (x2 + z2))+ readSTRef y3 >>= \ry3 ->+ modifySTRef' x3 (\rx3 -> modP (rx3 * ry3)) -- 16+ readSTRef t0 >>= \r0 ->+ readSTRef t2 >>= \r2 ->+ writeSTRef y3 (modP (r0 + r2))+ readSTRef x3 >>= \rx3 ->+ modifySTRef' y3 (\ry3 -> modP (rx3 - ry3))+ readSTRef t0 >>= \r0 ->+ writeSTRef x3 (modP (r0 + r0))+ readSTRef x3 >>= \rx3 ->+ modifySTRef t0 (\r0 -> modP (rx3 + r0)) -- 20+ modifySTRef' t2 (\r2 -> modP (b3 * r2))+ readSTRef t1 >>= \r1 ->+ readSTRef t2 >>= \r2 ->+ writeSTRef z3 (modP (r1 + r2))+ readSTRef t2 >>= \r2 ->+ modifySTRef' t1 (\r1 -> modP (r1 - r2))+ modifySTRef' y3 (\ry3 -> modP (b3 * ry3)) -- 24+ readSTRef t4 >>= \r4 ->+ readSTRef y3 >>= \ry3 ->+ writeSTRef x3 (modP (r4 * ry3))+ readSTRef t3 >>= \r3 ->+ readSTRef t1 >>= \r1 ->+ writeSTRef t2 (modP (r3 * r1))+ readSTRef t2 >>= \r2 ->+ modifySTRef' x3 (\rx3 -> modP (r2 - rx3))+ readSTRef t0 >>= \r0 ->+ modifySTRef' y3 (\ry3 -> modP (ry3 * r0)) -- 28+ readSTRef z3 >>= \rz3 ->+ modifySTRef' t1 (\r1 -> modP (r1 * rz3))+ readSTRef t1 >>= \r1 ->+ modifySTRef' y3 (\ry3 -> modP (r1 + ry3))+ readSTRef t3 >>= \r3 ->+ modifySTRef' t0 (\r0 -> modP (r0 * r3))+ readSTRef t4 >>= \r4 ->+ modifySTRef' z3 (\rz3 -> modP (rz3 * r4)) -- 32+ readSTRef t0 >>= \r0 ->+ modifySTRef' z3 (\rz3 -> modP (rz3 + r0))+ Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3++-- algo 8, renes et al, 2015+add_mixed :: Projective -> Projective -> Projective+add_mixed (Projective x1 y1 z1) (Projective x2 y2 z2)+ | z2 /= 1 = error "ppad-secp256k1: internal error"+ | otherwise = runST $ do+ x3 <- newSTRef 0+ y3 <- newSTRef 0+ z3 <- newSTRef 0+ let b3 = remP (_CURVE_B * 3)+ t0 <- newSTRef (modP (x1 * x2)) -- 1+ t1 <- newSTRef (modP (y1 * y2))+ t3 <- newSTRef (modP (x2 + y2))+ t4 <- newSTRef (modP (x1 + y1)) -- 4+ readSTRef t4 >>= \r4 ->+ modifySTRef' t3 (\r3 -> modP (r3 * r4))+ readSTRef t0 >>= \r0 ->+ readSTRef t1 >>= \r1 ->+ writeSTRef t4 (modP (r0 + r1))+ readSTRef t4 >>= \r4 ->+ modifySTRef' t3 (\r3 -> modP (r3 - r4)) -- 7+ writeSTRef t4 (modP (y2 * z1))+ modifySTRef' t4 (\r4 -> modP (r4 + y1))+ writeSTRef y3 (modP (x2 * z1)) -- 10+ modifySTRef' y3 (\ry3 -> modP (ry3 + x1))+ readSTRef t0 >>= \r0 ->+ writeSTRef x3 (modP (r0 + r0))+ readSTRef x3 >>= \rx3 ->+ modifySTRef' t0 (\r0 -> modP (rx3 + r0)) -- 13+ t2 <- newSTRef (modP (b3 * z1))+ readSTRef t1 >>= \r1 ->+ readSTRef t2 >>= \r2 ->+ writeSTRef z3 (modP (r1 + r2))+ readSTRef t2 >>= \r2 ->+ modifySTRef' t1 (\r1 -> modP (r1 - r2)) -- 16+ modifySTRef' y3 (\ry3 -> modP (b3 * ry3))+ readSTRef t4 >>= \r4 ->+ readSTRef y3 >>= \ry3 ->+ writeSTRef x3 (modP (r4 * ry3))+ readSTRef t3 >>= \r3 ->+ readSTRef t1 >>= \r1 ->+ writeSTRef t2 (modP (r3 * r1)) -- 19+ readSTRef t2 >>= \r2 ->+ modifySTRef' x3 (\rx3 -> modP (r2 - rx3))+ readSTRef t0 >>= \r0 ->+ modifySTRef' y3 (\ry3 -> modP (ry3 * r0))+ readSTRef z3 >>= \rz3 ->+ modifySTRef' t1 (\r1 -> modP (r1 * rz3)) -- 22+ readSTRef t1 >>= \r1 ->+ modifySTRef' y3 (\ry3 -> modP (r1 + ry3))+ readSTRef t3 >>= \r3 ->+ modifySTRef' t0 (\r0 -> modP (r0 * r3))+ readSTRef t4 >>= \r4 ->+ modifySTRef' z3 (\rz3 -> modP (rz3 * r4)) -- 25+ readSTRef t0 >>= \r0 ->+ modifySTRef' z3 (\rz3 -> modP (rz3 + r0))+ Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3++-- algo 9, renes et al, 2015+double :: Projective -> Projective+double (Projective x y z) = runST $ do+ x3 <- newSTRef 0+ y3 <- newSTRef 0+ z3 <- newSTRef 0+ let b3 = remP (_CURVE_B * 3)+ t0 <- newSTRef (modP (y * y)) -- 1+ readSTRef t0 >>= \r0 ->+ writeSTRef z3 (modP (r0 + r0))+ modifySTRef' z3 (\rz3 -> modP (rz3 + rz3))+ modifySTRef' z3 (\rz3 -> modP (rz3 + rz3)) -- 4+ t1 <- newSTRef (modP (y * z))+ t2 <- newSTRef (modP (z * z))+ modifySTRef t2 (\r2 -> modP (b3 * r2)) -- 7+ readSTRef z3 >>= \rz3 ->+ readSTRef t2 >>= \r2 ->+ writeSTRef x3 (modP (r2 * rz3))+ readSTRef t0 >>= \r0 ->+ readSTRef t2 >>= \r2 ->+ writeSTRef y3 (modP (r0 + r2))+ readSTRef t1 >>= \r1 ->+ modifySTRef' z3 (\rz3 -> modP (r1 * rz3)) -- 10+ readSTRef t2 >>= \r2 ->+ writeSTRef t1 (modP (r2 + r2))+ readSTRef t1 >>= \r1 ->+ modifySTRef' t2 (\r2 -> modP (r1 + r2))+ readSTRef t2 >>= \r2 ->+ modifySTRef' t0 (\r0 -> modP (r0 - r2)) -- 13+ readSTRef t0 >>= \r0 ->+ modifySTRef' y3 (\ry3 -> modP (r0 * ry3))+ readSTRef x3 >>= \rx3 ->+ modifySTRef' y3 (\ry3 -> modP (rx3 + ry3))+ writeSTRef t1 (modP (x * y)) -- 16+ readSTRef t0 >>= \r0 ->+ readSTRef t1 >>= \r1 ->+ writeSTRef x3 (modP (r0 * r1))+ modifySTRef' x3 (\rx3 -> modP (rx3 + rx3))+ Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3++-- Timing-safe scalar multiplication of secp256k1 points.+mul :: Projective -> Integer -> Projective+mul p _SECRET+ | not (ge _SECRET) = error "ppad-secp256k1 (mul): scalar not in group"+ | otherwise = loop (0 :: Int) _ZERO _CURVE_G p _SECRET+ where+ loop !j !acc !f !d !m+ | j == _CURVE_Q_BITS = acc+ | otherwise =+ let nd = double d+ nm = I.integerShiftR m 1+ in if I.integerTestBit m 0+ then loop (succ j) (add acc d) f nd nm+ else loop (succ j) acc (add f d) nd nm+{-# NOINLINE mul #-}++-- Timing-unsafe scalar multiplication of secp256k1 points.+--+-- Don't use this function if the scalar could potentially be a secret.+mul_unsafe :: Projective -> Integer -> Projective+mul_unsafe p n+ | n == 0 = _ZERO+ | not (ge n) =+ error "ppad-secp256k1 (mul_unsafe): scalar not in group"+ | otherwise = loop _ZERO p n+ where+ loop !r !d m+ | m <= 0 = r+ | otherwise =+ let nd = double d+ nm = I.integerShiftR m 1+ nr = if I.integerTestBit m 0 then add r d else r+ in loop nr nd nm++-- | Derive a public key (i.e., a secp256k1 point) from the provided+-- secret.+--+-- >>> import qualified System.Entropy as E+-- >>> sk <- fmap parse_int256 (E.getEntropy 32)+-- >>> derive_pub sk+-- "<secp256k1 point>"+derive_pub :: Integer -> Pub+derive_pub _SECRET+ | not (ge _SECRET) =+ error "ppad-secp256k1 (derive_pub): invalid secret key"+ | otherwise =+ mul _CURVE_G _SECRET+{-# NOINLINE derive_pub #-}++-- parsing --------------------------------------------------------------------++-- | Parse a positive 256-bit 'Integer', /e.g./ a Schnorr or ECDSA+-- secret key.+--+-- >>> import qualified Data.ByteString as BS+-- >>> parse_int256 (BS.replicate 32 0xFF)+-- <2^256 - 1>+parse_int256 :: BS.ByteString -> Integer+parse_int256 bs+ | BS.length bs /= 32 =+ error "ppad-secp256k1 (parse_int256): requires exactly 32-byte input"+ | otherwise = roll32 bs++-- | Parse compressed secp256k1 point (33 bytes), uncompressed point (65+-- bytes), or BIP0340-style point (32 bytes).+--+-- >>> parse_point <33-byte compressed point>+-- Just <Pub>+-- >>> parse_point <65-byte uncompressed point>+-- Just <Pub>+-- >>> parse_point <32-byte bip0340 public key>+-- Just <Pub>+-- >>> parse_point <anything else>+-- Nothing+parse_point :: BS.ByteString -> Maybe Projective+parse_point bs+ | len == 32 = _parse_bip0340 bs+ | len == 33 = _parse_compressed h t+ | len == 65 = _parse_uncompressed h t+ | otherwise = Nothing+ where+ len = BS.length bs+ h = BU.unsafeIndex bs 0 -- lazy+ t = BS.drop 1 bs++-- input is guaranteed to be 32B in length+_parse_bip0340 :: BS.ByteString -> Maybe Projective+_parse_bip0340 = fmap projective . lift . roll32++-- bytestring input is guaranteed to be 32B in length+_parse_compressed :: Word8 -> BS.ByteString -> Maybe Projective+_parse_compressed h (roll32 -> x)+ | h /= 0x02 && h /= 0x03 = Nothing+ | not (fe x) = Nothing+ | otherwise = do+ y <- modsqrtP (weierstrass x)+ let yodd = I.integerTestBit y 0+ hodd = B.testBit h 0+ pure $!+ if hodd /= yodd+ then Projective x (modP (negate y)) 1+ else Projective x y 1++-- bytestring input is guaranteed to be 64B in length+_parse_uncompressed :: Word8 -> BS.ByteString -> Maybe Projective+_parse_uncompressed h (BS.splitAt _CURVE_Q_BYTES -> (roll32 -> x, roll32 -> y))+ | h /= 0x04 = Nothing+ | otherwise =+ let p = Projective x y 1+ in if valid p+ then Just $! p+ else Nothing++-- schnorr --------------------------------------------------------------------+-- see https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki++-- | Create a 64-byte Schnorr signature for the provided message, using+-- the provided secret key.+--+-- BIP0340 recommends that 32 bytes of fresh auxiliary entropy be+-- generated and added at signing time as additional protection+-- against side-channel attacks (namely, to thwart so-called "fault+-- injection" attacks). This entropy is /supplemental/ to security,+-- and the cryptographic security of the signature scheme itself does+-- not rely on it, so it is not strictly required; 32 zero bytes can+-- be used in its stead (and can be supplied via 'mempty').+--+-- >>> import qualified System.Entropy as E+-- >>> aux <- E.getEntropy 32+-- >>> sign_schnorr sec msg aux+-- "<64-byte schnorr signature>"+sign_schnorr+ :: Integer -- ^ secret key+ -> BS.ByteString -- ^ message+ -> BS.ByteString -- ^ 32 bytes of auxilliary random data+ -> BS.ByteString -- ^ 64-byte Schnorr signature+sign_schnorr _SECRET m a+ | not (ge _SECRET) = error "ppad-secp256k1 (sign_schnorr): invalid secret key"+ | otherwise =+ let p_proj = mul _CURVE_G _SECRET+ Affine x_p y_p = affine p_proj+ d | I.integerTestBit y_p 0 = _CURVE_Q - _SECRET+ | otherwise = _SECRET++ bytes_d = unroll32 d+ h_a = hash_tagged "BIP0340/aux" a+ t = xor bytes_d h_a++ bytes_p = unroll32 x_p+ rand = hash_tagged "BIP0340/nonce" (t <> bytes_p <> m)++ k' = modQ (roll32 rand)++ in if k' == 0 -- negligible probability+ then error "ppad-secp256k1 (sign_schnorr): invalid k"+ else+ let Affine x_r y_r = affine (mul _CURVE_G k')+ k | I.integerTestBit y_r 0 = _CURVE_Q - k'+ | otherwise = k'++ bytes_r = unroll32 x_r+ e = modQ . roll32 . hash_tagged "BIP0340/challenge"+ $ bytes_r <> bytes_p <> m++ bytes_ked = unroll32 (modQ (k + e * d))++ sig = bytes_r <> bytes_ked++ in if verify_schnorr m p_proj sig+ then sig+ else error "ppad-secp256k1 (sign_schnorr): invalid signature"++-- | Verify a 64-byte Schnorr signature for the provided message with+-- the supplied public key.+--+-- >>> verify_schnorr msg pub <valid signature>+-- True+-- >>> verify_schnorr msg pub <invalid signature>+-- False+verify_schnorr+ :: BS.ByteString -- ^ message+ -> Pub -- ^ public key+ -> BS.ByteString -- ^ 64-byte Schnorr signature+ -> Bool+verify_schnorr m (affine -> Affine x_p _) sig+ | BS.length sig /= 64 = False+ | otherwise = case lift x_p of+ Nothing -> False+ Just capP@(Affine x_P _) ->+ let (roll32 -> r, roll32 -> s) = BS.splitAt 32 sig+ in if r >= _CURVE_P || s >= _CURVE_Q+ then False+ else let e = modQ . roll32 $ hash_tagged "BIP0340/challenge"+ (unroll32 r <> unroll32 x_P <> m)+ dif = add (mul_unsafe _CURVE_G s)+ (neg (mul_unsafe (projective capP) e))+ in if dif == _ZERO+ then False+ else let Affine x_R y_R = affine dif+ in not (I.integerTestBit y_R 0 || x_R /= r)++-- ecdsa ----------------------------------------------------------------------+-- see https://www.rfc-editor.org/rfc/rfc6979, https://secg.org/sec1-v2.pdf++-- RFC6979 2.3.2+bits2int :: BS.ByteString -> Integer+bits2int bs =+ let (fi -> blen) = BS.length bs * 8+ (fi -> qlen) = _CURVE_Q_BITS+ del = blen - qlen+ in if del > 0+ then roll bs `I.integerShiftR` del+ else roll bs++-- RFC6979 2.3.3+int2octets :: Integer -> BS.ByteString+int2octets i = pad (unroll i) where+ pad bs+ | BS.length bs < _CURVE_Q_BYTES = pad (BS.cons 0 bs)+ | otherwise = bs++-- RFC6979 2.3.4+bits2octets :: BS.ByteString -> BS.ByteString+bits2octets bs =+ let z1 = bits2int bs+ z2 = modQ z1+ in int2octets z2++-- | An ECDSA signature.+data ECDSA = ECDSA {+ ecdsa_r :: !Integer+ , ecdsa_s :: !Integer+ }+ deriving (Eq, Generic)++instance Show ECDSA where+ show _ = "<ecdsa signature>"++-- ECDSA signature type.+data SigType =+ LowS+ | Unrestricted+ deriving Show++-- Indicates whether to hash the message or assume it has already been+-- hashed.+data HashFlag =+ Hash+ | NoHash+ deriving Show++-- | Produce an ECDSA signature for the provided message, using the+-- provided private key.+--+-- 'sign_ecdsa' produces a "low-s" signature, as is commonly required+-- in applications using secp256k1. If you need a generic ECDSA+-- signature, use 'sign_ecdsa_unrestricted'.+--+-- >>> sign_ecdsa sec msg+-- "<ecdsa signature>"+sign_ecdsa+ :: Integer -- ^ secret key+ -> BS.ByteString -- ^ message+ -> ECDSA+sign_ecdsa = _sign_ecdsa LowS Hash++-- | Produce an ECDSA signature for the provided message, using the+-- provided private key.+--+-- 'sign_ecdsa_unrestricted' produces an unrestricted ECDSA signature,+-- which is less common in applications using secp256k1 due to the+-- signature's inherent malleability. If you need a conventional+-- "low-s" signature, use 'sign_ecdsa'.+--+-- >>> sign_ecdsa_unrestricted sec msg+-- "<ecdsa signature>"+sign_ecdsa_unrestricted+ :: Integer -- ^ secret key+ -> BS.ByteString -- ^ message+ -> ECDSA+sign_ecdsa_unrestricted = _sign_ecdsa Unrestricted Hash++-- Produce a "low-s" ECDSA signature for the provided message, using+-- the provided private key. Assumes that the message has already been+-- pre-hashed.+--+-- (Useful for testing against noble-secp256k1's suite, in which messages+-- in the test vectors have already been hashed.)+_sign_ecdsa_no_hash+ :: Integer -- ^ secret key+ -> BS.ByteString -- ^ message digest+ -> ECDSA+_sign_ecdsa_no_hash = _sign_ecdsa LowS NoHash++_sign_ecdsa :: SigType -> HashFlag -> Integer -> BS.ByteString -> ECDSA+_sign_ecdsa ty hf _SECRET m+ | not (ge _SECRET) = error "ppad-secp256k1 (sign_ecdsa): invalid secret key"+ | otherwise = runST $ do+ -- RFC6979 sec 3.3a+ let entropy = int2octets _SECRET -- XX timing concern+ nonce = bits2octets h+ drbg <- DRBG.new SHA256.hmac entropy nonce mempty+ -- RFC6979 sec 2.4+ sign_loop drbg+ where+ h = case hf of+ Hash -> SHA256.hash m+ NoHash -> m++ h_modQ = remQ (bits2int h) -- bits2int yields nonnegative++ sign_loop g = do+ k <- gen_k g+ let kg = mul _CURVE_G k+ Affine (modQ -> r) _ = affine kg+ s = case modinv k (fi _CURVE_Q) of+ Nothing -> error "ppad-secp256k1 (sign_ecdsa): bad k value"+ Just kinv -> remQ (remQ (h_modQ + remQ (_SECRET * r)) * kinv)+ if r == 0 -- negligible probability+ then sign_loop g+ else let !sig = ECDSA r s+ in case ty of+ Unrestricted -> pure sig+ LowS -> pure (low sig)++-- RFC6979 sec 3.3b+gen_k :: DRBG.DRBG s -> ST s Integer+gen_k g = loop g where+ loop drbg = do+ bytes <- DRBG.gen mempty (fi _CURVE_Q_BYTES) drbg+ let can = bits2int bytes+ if can >= _CURVE_Q+ then loop drbg+ else pure can+{-# INLINE gen_k #-}++-- Convert an ECDSA signature to low-S form.+low :: ECDSA -> ECDSA+low (ECDSA r s) = ECDSA r ms where+ ms+ | s > B.unsafeShiftR _CURVE_Q 1 = modQ (negate s)+ | otherwise = s+{-# INLINE low #-}++-- | Verify a "low-s" ECDSA signature for the provided message and+-- public key,+--+-- Fails to verify otherwise-valid "high-s" signatures. If you need to+-- verify generic ECDSA signatures, use 'verify_ecdsa_unrestricted'.+--+-- >>> verify_ecdsa msg pub valid_sig+-- True+-- >>> verify_ecdsa msg pub invalid_sig+-- False+verify_ecdsa+ :: BS.ByteString -- ^ message+ -> Pub -- ^ public key+ -> ECDSA -- ^ signature+ -> Bool+verify_ecdsa m p sig@(ECDSA _ s)+ | s > B.unsafeShiftR _CURVE_Q 1 = False+ | otherwise = verify_ecdsa_unrestricted m p sig++-- | Verify an unrestricted ECDSA signature for the provided message and+-- public key.+--+-- >>> verify_ecdsa_unrestricted msg pub valid_sig+-- True+-- >>> verify_ecdsa_unrestricted msg pub invalid_sig+-- False+verify_ecdsa_unrestricted+ :: BS.ByteString -- ^ message+ -> Pub -- ^ public key+ -> ECDSA -- ^ signature+ -> Bool+verify_ecdsa_unrestricted (SHA256.hash -> h) p (ECDSA r s)+ -- SEC1-v2 4.1.4+ | not (ge r) || not (ge s) = False+ | otherwise =+ let e = remQ (bits2int h)+ s_inv = case modinv s (fi _CURVE_Q) of+ -- 'ge s' assures existence of inverse+ Nothing ->+ error "ppad-secp256k1 (verify_ecdsa_unrestricted): no inverse"+ Just si -> si+ u1 = remQ (e * s_inv)+ u2 = remQ (r * s_inv)+ capR = add (mul_unsafe _CURVE_G u1) (mul_unsafe p u2)+ in if capR == _ZERO+ then False+ else let Affine (modQ -> v) _ = affine capR+ in v == r+
+ ppad-secp256k1.cabal view
@@ -0,0 +1,74 @@+cabal-version: 3.0+name: ppad-secp256k1+version: 0.1.0+synopsis: Schnorr signatures & ECDSA on the elliptic curve secp256k1+license: MIT+license-file: LICENSE+author: Jared Tobin+maintainer: jared@ppad.tech+category: Cryptography+build-type: Simple+tested-with: GHC == { 9.8.1, 9.6.4 }+extra-doc-files: CHANGELOG+description:+ Pure BIP0340-style Schnorr signatures and deterministic RFC6979 ECDSA on+ the elliptic curve secp256k1.++source-repository head+ type: git+ location: git.ppad.tech/secp256k1.git++library+ default-language: Haskell2010+ hs-source-dirs: lib+ ghc-options:+ -Wall+ exposed-modules:+ Crypto.Curve.Secp256k1+ build-depends:+ base >= 4.9 && < 5+ , bytestring >= 0.9 && < 0.13+ , ppad-hmac-drbg >= 0.1 && < 0.2+ , ppad-sha256 >= 0.2 && < 0.3++test-suite secp256k1-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ BIP340+ , Noble+ , Wycheproof++ ghc-options:+ -rtsopts -Wall++ build-depends:+ aeson+ , attoparsec+ , base+ , base16-bytestring+ , bytestring+ , ppad-secp256k1+ , tasty+ , tasty-hunit+ , text++benchmark secp256k1-bench+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: Main.hs++ ghc-options:+ -rtsopts -O2 -Wall -fno-warn-orphans++ build-depends:+ base+ , base16-bytestring+ , bytestring+ , criterion+ , deepseq+ , ppad-secp256k1+
+ test/BIP340.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module BIP340 (+ cases+ , execute+ ) where++import Control.Applicative+import Crypto.Curve.Secp256k1+import qualified Data.Attoparsec.ByteString.Char8 as AT+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified GHC.Num.Integer as I+import Test.Tasty+import Test.Tasty.HUnit++-- XX make a test prelude instead of copying/pasting these things everywhere++fi :: (Integral a, Num b) => a -> b+fi = fromIntegral+{-# INLINE fi #-}++roll :: BS.ByteString -> Integer+roll = BS.foldl' unstep 0 where+ unstep a (fi -> b) = (a `I.integerShiftL` 8) `I.integerOr` b++data Case = Case {+ c_index :: !Int+ , c_sk :: !BS.ByteString+ , c_pk :: !BS.ByteString+ , c_aux :: !BS.ByteString+ , c_msg :: !BS.ByteString+ , c_sig :: !BS.ByteString+ , c_res :: !Bool+ , c_comment :: !BS.ByteString+ } deriving Show++execute :: Case -> TestTree+execute Case {..} = testCase ("bip0340 " <> show c_index) $+ case parse_point (B16.decodeLenient c_pk) of+ Nothing -> assertBool mempty (not c_res)+ Just pk -> do+ if c_sk == mempty+ then do -- no signature; test verification+ let ver = verify_schnorr c_msg pk c_sig+ if c_res+ then assertBool mempty ver+ else assertBool mempty (not ver)+ -- XX test pubkey derivation from sk+ else do -- signature present; test sig too+ let sk = roll c_sk+ sig = sign_schnorr sk c_msg c_aux+ ver = verify_schnorr c_msg pk sig+ assertEqual mempty c_sig sig+ if c_res+ then assertBool mempty ver+ else assertBool mempty (not ver)++header :: AT.Parser ()+header = do+ _ <- AT.string "index,secret key,public key,aux_rand,message,signature,verification result,comment"+ AT.endOfLine++test_case :: AT.Parser Case+test_case = do+ c_index <- AT.decimal AT.<?> "index"+ _ <- AT.char ','+ c_sk <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT.<?> "sk")+ _ <- AT.char ','+ c_pk <- AT.takeWhile1 (/= ',') AT.<?> "pk"+ _ <- AT.char ','+ c_aux <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT.<?> "aux")+ _ <- AT.char ','+ c_msg <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT.<?> "msg")+ _ <- AT.char ','+ c_sig <- fmap B16.decodeLenient (AT.takeWhile1 (/= ',') AT.<?> "sig")+ _ <- AT.char ','+ c_res <- (AT.string "TRUE" *> pure True) <|> (AT.string "FALSE" *> pure False)+ AT.<?> "res"+ _ <- AT.char ','+ c_comment <- AT.takeWhile (/= '\n') AT.<?> "comment"+ AT.endOfLine+ pure Case {..}++cases :: AT.Parser [Case]+cases = header *> AT.many1 test_case+
+ test/Main.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Crypto.Curve.Secp256k1+import qualified Data.Aeson as A+import qualified Data.Attoparsec.ByteString as AT+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import Test.Tasty+import Test.Tasty.HUnit+import qualified Data.Text.IO as TIO+import qualified Noble as N+import qualified Wycheproof as W+import qualified BIP340++fi :: (Integral a, Num b) => a -> b+fi = fromIntegral+{-# INLINE fi #-}++main :: IO ()+main = do+ wp_ecdsa_sha256 <- TIO.readFile "etc/ecdsa_secp256k1_sha256_test.json"+ wp_ecdsa_sha256_bitcoin <- TIO.readFile+ "etc/ecdsa_secp256k1_sha256_bitcoin_test.json"+ noble_ecdsa <- TIO.readFile "etc/noble_ecdsa.json"+ bip340 <- BS.readFile "etc/bip-0340-test-vectors.csv"+ let quar = do+ wp0 <- A.decodeStrictText wp_ecdsa_sha256 :: Maybe W.Wycheproof+ wp1 <- A.decodeStrictText wp_ecdsa_sha256_bitcoin :: Maybe W.Wycheproof+ nob <- A.decodeStrictText noble_ecdsa :: Maybe N.Ecdsa+ bip <- case AT.parseOnly BIP340.cases bip340 of+ Left _ -> Nothing+ Right b -> pure b+ pure (wp0, wp1, nob, bip)+ case quar of+ Nothing -> error "couldn't parse wycheproof vectors"+ Just (w0, w1, no, ip) -> defaultMain $ testGroup "ppad-secp256k1" [+ units+ , wycheproof_ecdsa_verify_tests "(ecdsa, sha256)" Unrestricted w0+ , wycheproof_ecdsa_verify_tests "(ecdsa, sha256, low-s)" LowS w1+ , N.execute_ecdsa no+ , testGroup "bip0340 vectors (schnorr)" (fmap BIP340.execute ip)+ ]++wycheproof_ecdsa_verify_tests :: String -> SigType -> W.Wycheproof -> TestTree+wycheproof_ecdsa_verify_tests msg ty W.Wycheproof {..} =+ testGroup ("wycheproof vectors " <> msg) $+ fmap (W.execute_group ty) wp_testGroups++units :: TestTree+units = testGroup "unit tests" [+ parse_point_tests+ , add_tests+ , dub_tests+ ]++parse_point_tests :: TestTree+parse_point_tests = testGroup "parse_point tests" [+ parse_point_test_p+ , parse_point_test_q+ , parse_point_test_r+ ]++render :: Show a => a -> String+render = filter (`notElem` ("\"" :: String)) . show++-- XX replace these with something non-stupid+parse_point_test_p :: TestTree+parse_point_test_p = testCase (render p_hex) $+ case parse_point (B16.decodeLenient p_hex) of+ Nothing -> assertFailure "bad parse"+ Just p -> assertEqual mempty p_pro p++parse_point_test_q :: TestTree+parse_point_test_q = testCase (render q_hex) $+ case parse_point (B16.decodeLenient q_hex) of+ Nothing -> assertFailure "bad parse"+ Just q -> assertEqual mempty q_pro q++parse_point_test_r :: TestTree+parse_point_test_r = testCase (render r_hex) $+ case parse_point (B16.decodeLenient r_hex) of+ Nothing -> assertFailure "bad parse"+ Just r -> assertEqual mempty r_pro r++-- XX also make less dumb+add_tests :: TestTree+add_tests = testGroup "ec addition" [+ add_test_pq+ , add_test_pr+ , add_test_qr+ ]++add_test_pq :: TestTree+add_test_pq = testCase "p + q" $+ assertEqual mempty pq_pro (p_pro `add` q_pro)++add_test_pr :: TestTree+add_test_pr = testCase "p + r" $+ assertEqual mempty pr_pro (p_pro `add` r_pro)++add_test_qr :: TestTree+add_test_qr = testCase "q + r" $+ assertEqual mempty qr_pro (q_pro `add` r_pro)++dub_tests :: TestTree+dub_tests = testGroup "ec doubling" [+ dub_test_p+ , dub_test_q+ , dub_test_r+ ]++dub_test_p :: TestTree+dub_test_p = testCase "2p" $+ assertEqual mempty (p_pro `add` p_pro) (double p_pro)++dub_test_q :: TestTree+dub_test_q = testCase "2q" $+ assertEqual mempty (q_pro `add` q_pro) (double q_pro)++dub_test_r :: TestTree+dub_test_r = testCase "2r" $+ assertEqual mempty (r_pro `add` r_pro) (double r_pro)++p_hex :: BS.ByteString+p_hex = "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"++p_pro :: Projective+p_pro = Projective {+ px = 55066263022277343669578718895168534326250603453777594175500187360389116729240+ , py = 32670510020758816978083085130507043184471273380659243275938904335757337482424+ , pz = 1+ }++q_hex :: BS.ByteString+q_hex = "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9"++q_pro :: Projective+q_pro = Projective {+ px = 112711660439710606056748659173929673102114977341539408544630613555209775888121+ , py = 25583027980570883691656905877401976406448868254816295069919888960541586679410+ , pz = 1+ }++r_hex :: BS.ByteString+r_hex = "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8"++r_pro :: Projective+r_pro = Projective {+ px = 73305138481390301074068425511419969342201196102229546346478796034582161436904+ , py = 77311080844824646227678701997218206005272179480834599837053144390237051080427+ , pz = 1+ }++pq_pro :: Projective+pq_pro = Projective {+ px = 52396973184413144605737087313078368553350360735730295164507742012595395307648+ , py = 81222895265056120475581324527268307707868393868711445371362592923687074369515+ , pz = 57410578768022213246260942140297839801661445014943088692963835122150180187279+ }++pr_pro :: Projective+pr_pro = Projective {+ px = 1348700846815225554023000535566992225745844759459188830982575724903956130228+ , py = 36170035245379023681754688218456726199360176620640420471087552839246039945572+ , pz = 92262311556350124501370727779827867637071338628440636251794554773617634796873+ }++qr_pro :: Projective+qr_pro = Projective {+ px = 98601662106226486891738184090788320295235665172235527697419658886981126285906+ , py = 18578813777775793862159229516827464252856752093683109113431170463916250542461+ , pz = 56555634785712334774735413904899958905472439323190450522613637299635410127585+ }+
+ test/Noble.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Noble (+ Ecdsa(..)+ , execute_ecdsa+ ) where++import Control.Exception+import Crypto.Curve.Secp256k1+import Data.Aeson ((.:))+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified GHC.Num.Integer as I+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertEqual, assertBool, assertFailure, testCase)++data Ecdsa = Ecdsa {+ ec_valid :: ![(Int, ValidTest)]+ , ec_invalid :: !InvalidTest+ } deriving Show++execute_ecdsa :: Ecdsa -> TestTree+execute_ecdsa Ecdsa {..} = testGroup "noble_ecdsa" [+ testGroup "valid" (fmap execute_valid ec_valid)+ , testGroup "invalid (sign)" (fmap execute_invalid_sign iv_sign)+ , testGroup "invalid (verify)" (fmap execute_invalid_verify iv_verify)+ ]+ where+ InvalidTest {..} = ec_invalid++execute_valid :: (Int, ValidTest) -> TestTree+execute_valid (label, ValidTest {..}) =+ testCase ("noble-secp256k1, valid (" <> show label <> ")") $ do+ let msg = vt_m+ x = vt_d+ pec = parse_compact vt_signature+ sig = _sign_ecdsa_no_hash x msg+ assertEqual mempty pec sig++execute_invalid_sign :: (Int, InvalidSignTest) -> TestTree+execute_invalid_sign (label, InvalidSignTest {..}) =+ testCase ("noble-secp256k1, invalid sign (" <> show label <> ")") $ do+ let x = ivs_d+ m = ivs_m+ err <- catch (pure (_sign_ecdsa_no_hash x m) >> pure False) handler+ if err+ then assertFailure "expected error not caught"+ else pure ()+ where+ handler :: ErrorCall -> IO Bool+ handler _ = pure True++execute_invalid_verify :: (Int, InvalidVerifyTest) -> TestTree+execute_invalid_verify (label, InvalidVerifyTest {..}) =+ testCase ("noble-secp256k1, invalid verify (" <> show label <> ")") $+ case parse_point (B16.decodeLenient ivv_Q) of+ Nothing -> assertBool "no parse" True+ Just pub -> do+ let sig = parse_compact ivv_signature+ ver = verify_ecdsa ivv_m pub sig+ assertBool mempty (not ver)++fi :: (Integral a, Num b) => a -> b+fi = fromIntegral+{-# INLINE fi #-}++-- parser helper+toBS :: T.Text -> BS.ByteString+toBS = B16.decodeLenient . TE.encodeUtf8++-- parser helper+toSecKey :: T.Text -> Integer+toSecKey = roll . toBS++-- big-endian bytestring decoding+roll :: BS.ByteString -> Integer+roll = BS.foldl' unstep 0 where+ unstep a (fi -> b) = (a `I.integerShiftL` 8) `I.integerOr` b++instance A.FromJSON Ecdsa where+ parseJSON = A.withObject "Ecdsa" $ \m -> Ecdsa+ <$> fmap (zip [0..]) (m .: "valid")+ <*> m .: "invalid"++data ValidTest = ValidTest {+ vt_d :: !Integer+ , vt_m :: !BS.ByteString+ , vt_signature :: !BS.ByteString+ } deriving Show++instance A.FromJSON ValidTest where+ parseJSON = A.withObject "ValidTest" $ \m -> ValidTest+ <$> fmap toSecKey (m .: "d")+ <*> fmap toBS (m .: "m")+ <*> fmap toBS (m .: "signature")++parse_compact :: BS.ByteString -> ECDSA+parse_compact bs =+ let (roll -> r, roll -> s) = BS.splitAt 32 bs+ in ECDSA r s++data InvalidTest = InvalidTest {+ iv_sign :: ![(Int, InvalidSignTest)]+ , iv_verify :: ![(Int, InvalidVerifyTest)]+ } deriving Show++instance A.FromJSON InvalidTest where+ parseJSON = A.withObject "InvalidTest" $ \m -> InvalidTest+ <$> fmap (zip [0..]) (m .: "sign")+ <*> fmap (zip [0..]) (m .: "verify")++data InvalidSignTest = InvalidSignTest {+ ivs_d :: !Integer+ , ivs_m :: !BS.ByteString+ } deriving Show++instance A.FromJSON InvalidSignTest where+ parseJSON = A.withObject "InvalidSignTest" $ \m -> InvalidSignTest+ <$> fmap toSecKey (m .: "d")+ <*> fmap toBS (m .: "m")++data InvalidVerifyTest = InvalidVerifyTest {+ ivv_Q :: !BS.ByteString+ , ivv_m :: !BS.ByteString+ , ivv_signature :: !BS.ByteString+ } deriving Show++instance A.FromJSON InvalidVerifyTest where+ parseJSON = A.withObject "InvalidVerifyTest" $ \m -> InvalidVerifyTest+ <$> fmap TE.encodeUtf8 (m .: "Q")+ <*> fmap toBS (m .: "m")+ <*> fmap toBS (m .: "signature")+
+ test/Wycheproof.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Wycheproof (+ Wycheproof(..)+ , execute_group+ ) where++import Crypto.Curve.Secp256k1+import Data.Aeson ((.:))+import qualified Data.Aeson as A+import qualified Data.Attoparsec.ByteString as AT+import qualified Data.Bits as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified GHC.Num.Integer as I+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase)++fi :: (Integral a, Num b) => a -> b+fi = fromIntegral+{-# INLINE fi #-}++-- big-endian bytestring decoding+roll :: BS.ByteString -> Integer+roll = BS.foldl' unstep 0 where+ unstep a (fi -> b) = (a `I.integerShiftL` 8) `I.integerOr` b++execute_group :: SigType -> EcdsaTestGroup -> TestTree+execute_group ty EcdsaTestGroup {..} =+ testGroup msg (fmap (execute ty pk_uncompressed) etg_tests)+ where+ msg = "wycheproof (" <> T.unpack etg_type <> ", " <> T.unpack etg_sha <> ")"+ PublicKey {..} = etg_publicKey++execute :: SigType -> Projective -> EcdsaVerifyTest -> TestTree+execute ty pub EcdsaVerifyTest {..} = testCase report $ do+ let msg = B16.decodeLenient (TE.encodeUtf8 t_msg)+ sig = toEcdsa t_sig+ case sig of+ Left _ -> assertBool mempty (t_result == "invalid")+ Right s -> do+ let ver = case ty of+ LowS -> verify_ecdsa msg pub s+ Unrestricted -> verify_ecdsa_unrestricted msg pub s+ if t_result == "invalid"+ then assertBool mempty (not ver)+ else assertBool mempty ver+ where+ report = "wycheproof (" <> show ty <> ") " <> show t_tcId++parse_der_sig :: AT.Parser ECDSA+parse_der_sig = do+ _ <- AT.word8 0x30+ len <- fmap fi AT.anyWord8+ content <- AT.take len+ etc <- AT.takeByteString+ if BS.length content /= len || etc /= mempty+ then fail "invalid content"+ else case AT.parseOnly (meat len) content of+ Left _ -> fail "invalid content"+ Right v -> pure v+ where+ meat len = do+ (lr, bs_r) <- parseAsnInt+ (ls, bs_s) <- parseAsnInt+ let r = fi (roll bs_r)+ s = fi (roll bs_s)+ checks = lr + ls == len+ rest <- AT.takeByteString+ if rest == mempty && checks+ then pure (ECDSA r s)+ else fail "input remaining or length mismatch"++parseAsnInt :: AT.Parser (Int, BS.ByteString)+parseAsnInt = do+ _ <- AT.word8 0x02+ len <- fmap fi AT.anyWord8+ content <- AT.take len+ if BS.length content /= len+ then fail "invalid length"+ else if len == 1+ then pure (len + 2, content) -- + tag byt + len byt+ else case BS.uncons content of+ Nothing -> fail "invalid content"+ Just (h0, t0)+ | B.testBit h0 7 -> fail "negative value"+ | otherwise -> case BS.uncons t0 of+ Nothing -> fail "invalid content"+ Just (h1, _)+ | h0 == 0x00 && not (B.testBit h1 7) -> fail "invalid padding"+ | otherwise -> case BS.unsnoc content of+ Nothing -> fail "invalid content"+ Just (_, tn)+ | tn == 0x00 -> fail "invalid padding"+ | otherwise -> pure (len + 2, content)++data Wycheproof = Wycheproof {+ wp_algorithm :: !T.Text+ , wp_generatorVersion :: !T.Text+ , wp_numberOfTests :: !Int+ , wp_testGroups :: ![EcdsaTestGroup]+ } deriving Show++instance A.FromJSON Wycheproof where+ parseJSON = A.withObject "Wycheproof" $ \m -> Wycheproof+ <$> m .: "algorithm"+ <*> m .: "generatorVersion"+ <*> m .: "numberOfTests"+ <*> m .: "testGroups"++data EcdsaTestGroup = EcdsaTestGroup {+ etg_type :: !T.Text+ , etg_publicKey :: !PublicKey+ , etg_sha :: !T.Text+ , etg_tests :: ![EcdsaVerifyTest]+ } deriving Show++instance A.FromJSON EcdsaTestGroup where+ parseJSON = A.withObject "EcdsaTestGroup" $ \m -> EcdsaTestGroup+ <$> m .: "type"+ <*> m .: "publicKey"+ <*> m .: "sha"+ <*> m .: "tests"++data PublicKey = PublicKey {+ pk_type :: !T.Text+ , pk_curve :: !T.Text+ , pk_keySize :: !Int+ , pk_uncompressed :: !Projective+ } deriving Show++toProjective :: T.Text -> Projective+toProjective (B16.decodeLenient . TE.encodeUtf8 -> bs) = case parse_point bs of+ Nothing -> error "wycheproof: couldn't parse pubkey"+ Just p -> p++instance A.FromJSON PublicKey where+ parseJSON = A.withObject "PublicKey" $ \m -> PublicKey+ <$> m .: "type"+ <*> m .: "curve"+ <*> m .: "keySize"+ <*> fmap toProjective (m .: "uncompressed")++toEcdsa :: T.Text -> Either String ECDSA+toEcdsa (B16.decodeLenient . TE.encodeUtf8 -> bs) =+ AT.parseOnly parse_der_sig bs++data EcdsaVerifyTest = EcdsaVerifyTest {+ t_tcId :: !Int+ , t_comment :: !T.Text+ , t_msg :: !T.Text+ , t_sig :: !T.Text+ , t_result :: !T.Text+ } deriving Show++instance A.FromJSON EcdsaVerifyTest where+ parseJSON = A.withObject "EcdsaVerifyTest" $ \m -> EcdsaVerifyTest+ <$> m .: "tcId"+ <*> m .: "comment"+ <*> m .: "msg"+ <*> m .: "sig"+ <*> m .: "result"+