diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,6 @@ +# Changelog + +- 0.1.0 (2024-10-19) + * Initial release, supporting public key derivation and Schnorr & + ECDSA signatures on secp256k1. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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" + diff --git a/lib/Crypto/Curve/Secp256k1.hs b/lib/Crypto/Curve/Secp256k1.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Curve/Secp256k1.hs @@ -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 +-- +-- 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 +-- "" +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 +-- >>> parse_point <65-byte uncompressed point> +-- Just +-- >>> parse_point <32-byte bip0340 public key> +-- Just +-- >>> parse_point +-- 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 +-- True +-- >>> verify_schnorr msg pub +-- 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 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 +-- "" +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 +-- "" +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 + diff --git a/ppad-secp256k1.cabal b/ppad-secp256k1.cabal new file mode 100644 --- /dev/null +++ b/ppad-secp256k1.cabal @@ -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 + diff --git a/test/BIP340.hs b/test/BIP340.hs new file mode 100644 --- /dev/null +++ b/test/BIP340.hs @@ -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 + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + } + diff --git a/test/Noble.hs b/test/Noble.hs new file mode 100644 --- /dev/null +++ b/test/Noble.hs @@ -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") + diff --git a/test/Wycheproof.hs b/test/Wycheproof.hs new file mode 100644 --- /dev/null +++ b/test/Wycheproof.hs @@ -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" +