diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,19 @@ # Changelog +- 0.5.0 (2025-12-21) + * We get a significant upgrade to all functionality by pulling in the + ppad-fixed library for large unsigned and Montgomery-form integers. + Constant-time and allocation properties are made much more rigorous + across the board, as we no longer depend on 'Integer' whatsoever. + + This version also improves performance radically throughout. A + summary of the speedups achieved: + + sign_schnorr: ~7.1x speedup + verify_schnorr: ~4.5x speedup + sign_ecdsa: ~1.5x speedup + verify_ecdsa: ~4.5x speedup + - 0.4.0 (2025-06-21) * Scalar multiplication, signing, verifying, and ECHD functions are now all total, returning 'Nothing' when supplied with invalid inputs. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-type-defaults #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,43 +6,43 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 +import qualified Data.Word.Wider as W import Control.DeepSeq import Criterion.Main import qualified Crypto.Curve.Secp256k1 as S +import qualified Numeric.Montgomery.Secp256k1.Curve as C + instance NFData S.Projective instance NFData S.Affine instance NFData S.ECDSA instance NFData S.Context +decodeLenient :: BS.ByteString -> BS.ByteString +decodeLenient bs = case B16.decode bs of + Nothing -> error "bang" + Just b -> b + main :: IO () main = defaultMain [ parse_point , add + , double , mul - , precompute + , mul_vartime , mul_wnaf + , precompute , derive_pub , schnorr , ecdsa , ecdh ] -parse_int256 :: BS.ByteString -> Integer +parse_int256 :: BS.ByteString -> W.Wider parse_int256 bs = case S.parse_int256 bs of Nothing -> error "bang" Just v -> v -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 . parse_int256 $ B16.decodeLenient - "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed" - parse_point :: Benchmark parse_point = bgroup "parse_point" [ bench "compressed" $ nf S.parse_point p_bs @@ -62,15 +62,31 @@ 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_fixed :: Benchmark +mul_fixed = bgroup "mul_fixed" [ + bench "curve: M(2) * M(2)" $ nf (C.mul 2) 2 + , bench "curve: M(2) * M(2 ^ 255 - 19)" $ nf (C.mul 2) (2 ^ 255 - 19) ] +add :: Benchmark +add = env setup $ \ ~(!pl, !ql, !rl, !sl) -> + bgroup "add" [ + bench "p + q (trivial projective points)" $ nf (S.add pl) ql + , bench "p + s (nontrivial mixed points)" $ nf (S.add pl) sl + , bench "s + r (nontrivial projective points)" $ nf (S.add sl) rl + ] + where + setup = pure (p, q, r, s) + +double :: Benchmark +double = env setup $ \ ~(!pl, !rl) -> + bgroup "double" [ + bench "2 p (double, trivial projective point)" $ nf (S.add pl) pl + , bench "2 r (double, nontrivial projective point)" $ nf (S.add rl) rl + ] + where + setup = pure (p, r) + mul :: Benchmark mul = env setup $ \x -> bgroup "mul" [ @@ -78,9 +94,19 @@ , bench "(2 ^ 255 - 19) G" $ nf (S.mul S._CURVE_G) x ] where - setup = pure . parse_int256 $ B16.decodeLenient + setup = pure . parse_int256 $ decodeLenient "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed" +mul_vartime :: Benchmark +mul_vartime = env setup $ \x -> + bgroup "mul_vartime" [ + bench "2 G" $ nf (S.mul_vartime S._CURVE_G) 2 + , bench "(2 ^ 255 - 19) G" $ nf (S.mul_vartime S._CURVE_G) x + ] + where + setup = pure . parse_int256 $ decodeLenient + "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed" + precompute :: Benchmark precompute = bench "precompute" $ nfIO (pure S.precompute) @@ -93,7 +119,7 @@ where setup = do let !tex = S.precompute - !int = parse_int256 $ B16.decodeLenient + !int = parse_int256 $ decodeLenient "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed" pure (tex, int) @@ -108,7 +134,7 @@ where setup = do let !tex = S.precompute - !int = parse_int256 $ B16.decodeLenient + !int = parse_int256 $ decodeLenient "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed" pure (tex, int) @@ -125,7 +151,7 @@ where setup = do let !tex = S.precompute - !int = parse_int256 $ B16.decodeLenient + !int = parse_int256 $ decodeLenient "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed" pure (tex, int) @@ -142,7 +168,7 @@ where setup = do let !tex = S.precompute - big = parse_int256 $ B16.decodeLenient + big = parse_int256 $ decodeLenient "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed" Just pub = S.derive_pub big msg = "i approve of this message" @@ -159,39 +185,43 @@ setup = do let !big = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed - !(Just !pub) = S.parse_point . B16.decodeLenient $ + !(Just !pub) = S.parse_point . decodeLenient $ "bd02b9dfc8ef760708950bd972f2dc244893b61b6b46c3b19be1b2da7b034ac5" pure (big, pub) -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 +p = S.Projective + 55066263022277343669578718895168534326250603453777594175500187360389116729240 + 32670510020758816978083085130507043184471273380659243275938904335757337482424 + 1 +q :: S.Projective +q = S.Projective + 112711660439710606056748659173929673102114977341539408544630613555209775888121 + 25583027980570883691656905877401976406448868254816295069919888960541586679410 + 1 + +r :: S.Projective +r = S.Projective + 73305138481390301074068425511419969342201196102229546346478796034582161436904 + 77311080844824646227678701997218206005272179480834599837053144390237051080427 + 1 + +p_bs :: BS.ByteString +p_bs = decodeLenient + "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" + q_bs :: BS.ByteString -q_bs = B16.decodeLenient +q_bs = 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 +r_bs = 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 +s_bs = decodeLenient "0306413898a49c93cccf3db6e9078c1b6a8e62568e4a4770e0d7d96792d1c580ad" s :: S.Projective @@ -200,22 +230,22 @@ Just !pt -> pt t_bs :: BS.ByteString -t_bs = B16.decodeLenient "04b838ff44e5bc177bf21189d0766082fc9d843226887fc9760371100b7ee20a6ff0c9d75bfba7b31a6bca1974496eeb56de357071955d83c4b1badaa0b21832e9" +t_bs = decodeLenient "04b838ff44e5bc177bf21189d0766082fc9d843226887fc9760371100b7ee20a6ff0c9d75bfba7b31a6bca1974496eeb56de357071955d83c4b1badaa0b21832e9" t :: S.Projective t = case S.parse_point t_bs of Nothing -> error "bang" Just !pt -> pt -s_sk :: Integer -s_sk = parse_int256 . B16.decodeLenient $ +s_sk :: W.Wider +s_sk = parse_int256 . decodeLenient $ "B7E151628AED2A6ABF7158809CF4F3C762E7160F38B4DA56A784D9045190CFEF" s_sig :: BS.ByteString -s_sig = B16.decodeLenient "6896BD60EEAE296DB48A229FF71DFE071BDE413E6D43F917DC8DCF8C78DE33418906D11AC976ABCCB20B091292BFF4EA897EFCB639EA871CFA95F6DE339E4B0A" +s_sig = decodeLenient "6896BD60EEAE296DB48A229FF71DFE071BDE413E6D43F917DC8DCF8C78DE33418906D11AC976ABCCB20B091292BFF4EA897EFCB639EA871CFA95F6DE339E4B0A" s_pk_raw :: BS.ByteString -s_pk_raw = B16.decodeLenient +s_pk_raw = decodeLenient "DFF1D77F2A671C5F36183726DB2341BE58FEAE1DA2DECED843240F7B502BA659" s_pk :: S.Projective @@ -224,13 +254,10 @@ Just !pt -> pt s_msg :: BS.ByteString -s_msg = B16.decodeLenient +s_msg = decodeLenient "243F6A8885A308D313198A2E03707344A4093822299F31D0082EFA98EC4E6C89" s_aux :: BS.ByteString -s_aux = B16.decodeLenient +s_aux = decodeLenient "0000000000000000000000000000000000000000000000000000000000000001" - --- e_msg = B16.decodeLenient "313233343030" --- e_sig = B16.decodeLenient "3045022100813ef79ccefa9a56f7ba805f0e478584fe5f0dd5f567bc09b5123ccbc983236502206ff18a52dcc0336f7af62400a6dd9b810732baf1ff758000d6f613a556eb31ba" diff --git a/bench/Weight.hs b/bench/Weight.hs --- a/bench/Weight.hs +++ b/bench/Weight.hs @@ -6,6 +6,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 +import Data.Maybe (fromJust) +import Data.Word.Wider (Wider(..)) import Control.DeepSeq import qualified Crypto.Curve.Secp256k1 as S import qualified Weigh as W @@ -15,160 +17,146 @@ instance NFData S.ECDSA instance NFData S.Context -parse_int :: BS.ByteString -> Integer +decodeLenient :: BS.ByteString -> BS.ByteString +decodeLenient bs = case B16.decode bs of + Nothing -> error "bang" + Just b -> b + +parse_int :: BS.ByteString -> Wider parse_int bs = case S.parse_int256 bs of Nothing -> error "bang" Just v -> v -big :: Integer -big = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed - -tex :: S.Context -tex = S.precompute - -- note that 'weigh' doesn't work properly in a repl main :: IO () main = W.mainWith $ do - remQ parse_int256 + ge add + double mul - mul_unsafe mul_wnaf derive_pub schnorr ecdsa ecdh -remQ :: W.Weigh () -remQ = W.wgroup "remQ" $ do - W.func "remQ 2" S.remQ 2 - W.func "remQ (2 ^ 255 - 19)" S.remQ big +ge :: W.Weigh () +ge = + let !t = 2 + !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed + in W.wgroup "ge" $ do + W.func' "small" S.ge t + W.func' "large" S.ge b parse_int256 :: W.Weigh () -parse_int256 = W.wgroup "parse_int256" $ do - W.func' "parse_int (small)" parse_int (BS.replicate 32 0x00) - W.func' "parse_int (big)" parse_int (BS.replicate 32 0xFF) +parse_int256 = + let !a = BS.replicate 32 0x00 + !b = BS.replicate 32 0xFF + in W.wgroup "parse_int256" $ do + W.func' "parse_int (small)" parse_int a + W.func' "parse_int (big)" parse_int b add :: W.Weigh () -add = W.wgroup " add" $ do - W.func "2 p (double, trivial projective point)" (S.add p) p - W.func "2 r (double, nontrivial projective point)" (S.add r) r - W.func "p + q (trivial projective points)" (S.add p) q - W.func "p + s (nontrivial mixed points)" (S.add p) s - W.func "s + r (nontrivial projective points)" (S.add s) r +add = + let !p = fromJust . S.parse_point . decodeLenient $ + "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" + !r = fromJust . S.parse_point . decodeLenient $ + "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8" + !q = fromJust . S.parse_point . decodeLenient $ + "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9" + !s = fromJust . S.parse_point . decodeLenient $ + "0306413898a49c93cccf3db6e9078c1b6a8e62568e4a4770e0d7d96792d1c580ad" + in W.wgroup "add" $ do + W.func' "p + q (trivial projective points)" (S.add p) q + W.func' "s + p (nontrivial mixed points)" (S.add s) p + W.func' "r + s (nontrivial projective points)" (S.add r) s -mul :: W.Weigh () -mul = W.wgroup "mul" $ do - W.func "2 G" (S.mul S._CURVE_G) 2 - W.func "(2 ^ 255 - 19) G" (S.mul S._CURVE_G) big +double :: W.Weigh () +double = + let !p = fromJust . S.parse_point . decodeLenient $ + "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" + !r = fromJust . S.parse_point . decodeLenient $ + "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8" + in W.wgroup "double" $ do + W.func' "2 p (double, trivial projective point)" S.double p + W.func' "2 r (double, nontrivial projective point)" S.double r -mul_unsafe :: W.Weigh () -mul_unsafe = W.wgroup "mul_unsafe" $ do - W.func "2 G" (S.mul_unsafe S._CURVE_G) 2 - W.func "(2 ^ 255 - 19) G" (S.mul_unsafe S._CURVE_G) big +mul :: W.Weigh () +mul = + let !g = S._CURVE_G + !t = 2 + !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed + in W.wgroup "mul" $ do + W.func' "2 G" (S.mul g) t + W.func' "(2 ^ 255 - 19) G" (S.mul g) b mul_wnaf :: W.Weigh () -mul_wnaf = W.wgroup "mul_wnaf" $ do - W.value "precompute" S.precompute - W.func "2 G" (S.mul_wnaf tex) 2 - W.func "(2 ^ 255 - 19) G" (S.mul_wnaf tex) big +mul_wnaf = + let !t = 2 + !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed + !con = S.precompute + in W.wgroup "mul_wnaf" $ do + W.func' "precompute" S._precompute (8 :: Int) + W.func' "2 G" (S.mul_wnaf con) t + W.func' "(2 ^ 255 - 19) G" (S.mul_wnaf con) b derive_pub :: W.Weigh () -derive_pub = W.wgroup "derive_pub" $ do - W.func "sk = 2" S.derive_pub 2 - W.func "sk = 2 ^ 255 - 19" S.derive_pub big - W.func "wnaf, sk = 2" (S.derive_pub' tex) 2 - W.func "wnaf, sk = 2 ^ 255 - 19" (S.derive_pub' tex) big +derive_pub = + let !t = 2 + !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed + !con = S.precompute + in W.wgroup "derive_pub" $ do + W.func' "sk = 2" S.derive_pub t + W.func' "sk = 2 ^ 255 - 19" S.derive_pub b + W.func' "wnaf, sk = 2" (S.derive_pub' con) t + W.func' "wnaf, sk = 2 ^ 255 - 19" (S.derive_pub' con) b schnorr :: W.Weigh () -schnorr = W.wgroup "schnorr" $ do - W.func "sign_schnorr (small)" (S.sign_schnorr 2 s_msg) s_aux - W.func "sign_schnorr (large)" (S.sign_schnorr big s_msg) s_aux - W.func "sign_schnorr' (small)" (S.sign_schnorr' tex 2 s_msg) s_aux - W.func "sign_schnorr' (large)" (S.sign_schnorr' tex big s_msg) s_aux - W.func "verify_schnorr" (S.verify_schnorr s_msg s_pk) s_sig - W.func "verify_schnorr'" (S.verify_schnorr' tex s_msg s_pk) s_sig +schnorr = + let !t = 2 + !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed + !con = S.precompute + !s_msg = decodeLenient + "243F6A8885A308D313198A2E03707344A4093822299F31D0082EFA98EC4E6C89" + !s_aux = decodeLenient + "0000000000000000000000000000000000000000000000000000000000000001" + !s_sig = decodeLenient + "6896BD60EEAE296DB48A229FF71DFE071BDE413E6D43F917DC8DCF8C78DE33418906D11AC976ABCCB20B091292BFF4EA897EFCB639EA871CFA95F6DE339E4B0A" + !(Just !s_pk) = S.parse_point . decodeLenient $ + "DFF1D77F2A671C5F36183726DB2341BE58FEAE1DA2DECED843240F7B502BA659" + in W.wgroup "schnorr" $ do + W.func "sign_schnorr (small)" (S.sign_schnorr t s_msg) s_aux + W.func "sign_schnorr (large)" (S.sign_schnorr b s_msg) s_aux + W.func "sign_schnorr' (small)" (S.sign_schnorr' con t s_msg) s_aux + W.func "sign_schnorr' (large)" (S.sign_schnorr' con b s_msg) s_aux + W.func "verify_schnorr" (S.verify_schnorr s_msg s_pk) s_sig + W.func "verify_schnorr'" (S.verify_schnorr' con s_msg s_pk) s_sig ecdsa :: W.Weigh () -ecdsa = W.wgroup "ecdsa" $ do - W.func "sign_ecdsa (small)" (S.sign_ecdsa 2) s_msg - W.func "sign_ecdsa (large)" (S.sign_ecdsa big) s_msg - W.func "sign_ecdsa' (small)" (S.sign_ecdsa' tex 2) s_msg - W.func "sign_ecdsa' (large)" (S.sign_ecdsa' tex big) s_msg - W.func "verify_ecdsa" (S.verify_ecdsa msg pub) sig - W.func "verify_ecdsa'" (S.verify_ecdsa' tex msg pub) sig - where - Just pub = S.derive_pub big - msg = "i approve of this message" - Just sig = S.sign_ecdsa big s_msg +ecdsa = + let !t = 2 + !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed + !con = S.precompute + !msg = "i approve of this message" + !s_msg = decodeLenient + "243F6A8885A308D313198A2E03707344A4093822299F31D0082EFA98EC4E6C89" + !(Just !pub) = S.derive_pub b + !(Just !sig) = S.sign_ecdsa b s_msg + in W.wgroup "ecdsa" $ do + W.func "sign_ecdsa (small)" (S.sign_ecdsa t) s_msg + W.func "sign_ecdsa (large)" (S.sign_ecdsa b) s_msg + W.func "sign_ecdsa' (small)" (S.sign_ecdsa' con t) s_msg + W.func "sign_ecdsa' (large)" (S.sign_ecdsa' con b) s_msg + W.func "verify_ecdsa" (S.verify_ecdsa msg pub) sig + W.func "verify_ecdsa'" (S.verify_ecdsa' con msg pub) sig ecdh :: W.Weigh () -ecdh = W.wgroup "ecdh" $ do - W.func "ecdh (small)" (S.ecdh pub) 2 - W.func "ecdh (large)" (S.ecdh pub) b - where - b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed - Just pub = S.parse_point . B16.decodeLenient $ - "bd02b9dfc8ef760708950bd972f2dc244893b61b6b46c3b19be1b2da7b034ac5" - -s_sk :: Integer -s_sk = parse_int . 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" - -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 +ecdh = + let !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed + !(Just !pub) = S.parse_point . decodeLenient $ + "bd02b9dfc8ef760708950bd972f2dc244893b61b6b46c3b19be1b2da7b034ac5" + in W.wgroup "ecdh" $ do + W.func "ecdh (small)" (S.ecdh pub) 2 + W.func "ecdh (large)" (S.ecdh pub) b diff --git a/lib/Crypto/Curve/Secp256k1.hs b/lib/Crypto/Curve/Secp256k1.hs --- a/lib/Crypto/Curve/Secp256k1.hs +++ b/lib/Crypto/Curve/Secp256k1.hs @@ -2,1254 +2,1367 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# 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, 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), and ECDH shared secret computation --- on the elliptic curve secp256k1. - -module Crypto.Curve.Secp256k1 ( - -- * Field and group parameters - _CURVE_Q - , _CURVE_P - , remQ - , modQ - - -- * secp256k1 points - , Pub - , derive_pub - , derive_pub' - , _CURVE_G - , _CURVE_ZERO - - -- * Parsing - , parse_int256 - , parse_point - , parse_sig - - -- * Serializing - , serialize_point - - -- * ECDH - , ecdh - - -- * BIP0340 Schnorr signatures - , sign_schnorr - , verify_schnorr - - -- * RFC6979 ECDSA - , ECDSA(..) - , SigType(..) - , sign_ecdsa - , sign_ecdsa_unrestricted - , verify_ecdsa - , verify_ecdsa_unrestricted - - -- * Fast variants - , Context - , precompute - , sign_schnorr' - , verify_schnorr' - , sign_ecdsa' - , sign_ecdsa_unrestricted' - , verify_ecdsa' - , verify_ecdsa_unrestricted' - - -- Elliptic curve group operations - , neg - , add - , double - , mul - , mul_unsafe - , mul_wnaf - - -- Coordinate systems and transformations - , Affine(..) - , Projective(..) - , affine - , projective - , valid - - -- for testing/benchmarking - , _sign_ecdsa_no_hash - , _sign_ecdsa_no_hash' - ) where - -import Control.Monad (guard, 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 qualified Data.Maybe as M (isJust) -import qualified Data.Primitive.Array as A -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 "ppad-secp256k1 (modexp): internal error" -{-# 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 - --- /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. --- --- 256-bit big-endian bytestring decoding. the input size is not checked! -roll32 :: BS.ByteString -> Integer -roll32 bs = go (0 :: Word64) (0 :: Word64) (0 :: Word64) (0 :: Word64) 0 where - go !acc0 !acc1 !acc2 !acc3 !j - | j == 32 = - (fi acc0 `B.unsafeShiftL` 192) - .|. (fi acc1 `B.unsafeShiftL` 128) - .|. (fi acc2 `B.unsafeShiftL` 64) - .|. fi acc3 - | j < 8 = - let b = fi (BU.unsafeIndex bs j) - in go ((acc0 `B.unsafeShiftL` 8) .|. b) acc1 acc2 acc3 (j + 1) - | j < 16 = - let b = fi (BU.unsafeIndex bs j) - in go acc0 ((acc1 `B.unsafeShiftL` 8) .|. b) acc2 acc3 (j + 1) - | j < 24 = - let b = fi (BU.unsafeIndex bs j) - in go acc0 acc1 ((acc2 `B.unsafeShiftL` 8) .|. b) acc3 (j + 1) - | otherwise = - let b = fi (BU.unsafeIndex bs j) - in go acc0 acc1 acc2 ((acc3 `B.unsafeShiftL` 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 - --- (bip0340) return point with x coordinate == x and with even y coordinate -lift :: Integer -> Maybe Affine -lift x = do - guard (fe x) - 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 - guard (c == modexp y 2 (fi _CURVE_P)) - pure $! 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 == _CURVE_ZERO = Affine 0 0 - | z == 1 = Affine x y - | otherwise = case modinv z (fi _CURVE_P) of - Nothing -> error "ppad-secp256k1 (affine): internal error" - Just iz -> Affine (modP (x * iz)) (modP (y * iz)) - --- Convert to projective coordinates. -projective :: Affine -> Projective -projective (Affine x y) - | x == 0 && y == 0 = _CURVE_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 - --- ~ 2^256 - 2^32 - 2^9 - 2^8 - 2^7 - 2^6 - 2^4 - 1 - --- | secp256k1 field prime. -_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 - --- ~ parse_point . B16.decode $ --- "0279BE667EF9DCBBAC55A06295CE870B07029BFCDB2DCE28D959F2815B16F81798" - --- | secp256k1 generator point. -_CURVE_G :: Projective -_CURVE_G = Projective x y 1 where - x = 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 - y = 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8 - --- | secp256k1 zero point, point at infinity, or monoidal identity. -_CURVE_ZERO :: Projective -_CURVE_ZERO = Projective 0 1 0 - --- secp256k1 zero point, point at infinity, or monoidal identity -_ZERO :: Projective -_ZERO = Projective 0 1 0 -{-# DEPRECATED _ZERO "use _CURVE_ZERO instead" #-} - --- 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. -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 -> remP (rv * numv)) - modifySTRef' num (\numv -> remP (numv * numv)) - modifySTRef' e (`I.integerShiftR` 1) - loop - - loop - rv <- readSTRef r - - pure $ do - guard (remP (rv * rv) == n) - Just $! rv - --- 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 (add_mixed): 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 -> Maybe Projective -mul p _SECRET = do - guard (ge _SECRET) - pure $! loop (0 :: Int) _CURVE_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 -{-# INLINE 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 -> Maybe Projective -mul_unsafe p n - | n == 0 = pure $! _CURVE_ZERO - | not (ge n) = Nothing - | otherwise = pure $! loop _CURVE_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 - --- | Precomputed multiples of the secp256k1 base or generator point. -data Context = Context { - ctxW :: {-# UNPACK #-} !Int - , ctxArray :: !(A.Array Projective) - } deriving (Eq, Generic) - -instance Show Context where - show Context {} = "" - --- | Create a secp256k1 context by precomputing multiples of the curve's --- generator point. --- --- This should be used once to create a 'Context' to be reused --- repeatedly afterwards. --- --- >>> let !tex = precompute --- >>> sign_ecdsa' tex sec msg --- >>> sign_schnorr' tex sec msg aux -precompute :: Context -precompute = _precompute 8 - --- dumb strict pair -data Pair a b = Pair !a !b - --- translation of noble-secp256k1's 'precompute' -_precompute :: Int -> Context -_precompute ctxW = Context {..} where - ctxArray = A.arrayFromListN size (loop_w mempty _CURVE_G 0) - capJ = (2 :: Int) ^ (ctxW - 1) - ws = 256 `quot` ctxW + 1 - size = ws * capJ - - loop_w !acc !p !w - | w == ws = reverse acc - | otherwise = - let b = p - !(Pair nacc nb) = loop_j p (b : acc) b 1 - np = double nb - in loop_w nacc np (succ w) - - loop_j !p !acc !b !j - | j == capJ = Pair acc b - | otherwise = - let nb = add b p - in loop_j p (nb : acc) nb (succ j) - --- Timing-safe wNAF (w-ary non-adjacent form) scalar multiplication of --- secp256k1 points. -mul_wnaf :: Context -> Integer -> Maybe Projective -mul_wnaf Context {..} _SECRET = do - guard (ge _SECRET) - pure $! loop 0 _CURVE_ZERO _CURVE_G _SECRET - where - wins = 256 `quot` ctxW + 1 - wsize = 2 ^ (ctxW - 1) - mask = 2 ^ ctxW - 1 - mnum = 2 ^ ctxW - - loop !w !acc !f !n - | w == wins = acc - | otherwise = - let !off0 = w * fi wsize - - !b0 = n `I.integerAnd` mask - !n0 = n `I.integerShiftR` fi ctxW - - !(Pair b1 n1) | b0 > wsize = Pair (b0 - mnum) (n0 + 1) - | otherwise = Pair b0 n0 - - !c0 = B.testBit w 0 - !c1 = b1 < 0 - - !off1 = off0 + fi (abs b1) - 1 - - in if b1 == 0 - then let !pr = A.indexArray ctxArray off0 - !pt | c0 = neg pr - | otherwise = pr - in loop (w + 1) acc (add f pt) n1 - else let !pr = A.indexArray ctxArray off1 - !pt | c1 = neg pr - | otherwise = pr - in loop (w + 1) (add acc pt) f n1 -{-# INLINE mul_wnaf #-} - --- | 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 --- Just "" -derive_pub :: Integer -> Maybe Pub -derive_pub = mul _CURVE_G -{-# NOINLINE derive_pub #-} - --- | The same as 'derive_pub', except uses a 'Context' to optimise --- internal calculations. --- --- >>> import qualified System.Entropy as E --- >>> sk <- fmap parse_int256 (E.getEntropy 32) --- >>> let !tex = precompute --- >>> derive_pub' tex sk --- Just "" -derive_pub' :: Context -> Integer -> Maybe Pub -derive_pub' = mul_wnaf -{-# 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) --- Just <2^256 - 1> -parse_int256 :: BS.ByteString -> Maybe Integer -parse_int256 bs = do - guard (BS.length bs == 32) - pure $! 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 = do - let p = Projective x y 1 - guard (valid p) - pure $! p - --- | Parse an ECDSA signature encoded in 64-byte "compact" form. --- --- >>> parse_sig <64-byte compact signature> --- Just "" -parse_sig :: BS.ByteString -> Maybe ECDSA -parse_sig bs - | BS.length bs /= 64 = Nothing - | otherwise = pure $ - let (roll -> r, roll -> s) = BS.splitAt 32 bs - in ECDSA r s - --- serializing ---------------------------------------------------------------- - --- | Serialize a secp256k1 point in 33-byte compressed form. --- --- >>> serialize_point pub --- "<33-byte compressed point>" -serialize_point :: Projective -> BS.ByteString -serialize_point (affine -> Affine x y) = BS.cons b (unroll32 x) where - b | I.integerTestBit y 0 = 0x03 - | otherwise = 0x02 - --- 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 --- Just "<64-byte schnorr signature>" -sign_schnorr - :: Integer -- ^ secret key - -> BS.ByteString -- ^ message - -> BS.ByteString -- ^ 32 bytes of auxilliary random data - -> Maybe BS.ByteString -- ^ 64-byte Schnorr signature -sign_schnorr = _sign_schnorr (mul _CURVE_G) - --- | The same as 'sign_schnorr', except uses a 'Context' to optimise --- internal calculations. --- --- You can expect about a 2x performance increase when using this --- function, compared to 'sign_schnorr'. --- --- >>> import qualified System.Entropy as E --- >>> aux <- E.getEntropy 32 --- >>> let !tex = precompute --- >>> sign_schnorr' tex sec msg aux --- Just "<64-byte schnorr signature>" -sign_schnorr' - :: Context -- ^ secp256k1 context - -> Integer -- ^ secret key - -> BS.ByteString -- ^ message - -> BS.ByteString -- ^ 32 bytes of auxilliary random data - -> Maybe BS.ByteString -- ^ 64-byte Schnorr signature -sign_schnorr' tex = _sign_schnorr (mul_wnaf tex) - -_sign_schnorr - :: (Integer -> Maybe Projective) -- partially-applied multiplication function - -> Integer -- secret key - -> BS.ByteString -- message - -> BS.ByteString -- 32 bytes of auxilliary random data - -> Maybe BS.ByteString -_sign_schnorr _mul _SECRET m a = do - p_proj <- _mul _SECRET - let 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_aux a - t = xor bytes_d h_a - - bytes_p = unroll32 x_p - rand = hash_nonce (t <> bytes_p <> m) - - k' = modQ (roll32 rand) - - if k' == 0 -- negligible probability - then Nothing -- XX handle me - else do - pt <- _mul k' - let Affine x_r y_r = affine pt - k | I.integerTestBit y_r 0 = _CURVE_Q - k' - | otherwise = k' - - bytes_r = unroll32 x_r - e = modQ . roll32 . hash_challenge - $ bytes_r <> bytes_p <> m - - bytes_ked = unroll32 (modQ (k + e * d)) - - sig = bytes_r <> bytes_ked - - guard (verify_schnorr m p_proj sig) - pure $! sig -{-# INLINE _sign_schnorr #-} - --- | 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 = _verify_schnorr (mul_unsafe _CURVE_G) - --- | The same as 'verify_schnorr', except uses a 'Context' to optimise --- internal calculations. --- --- You can expect about a 1.5x performance increase when using this --- function, compared to 'verify_schnorr'. --- --- >>> let !tex = precompute --- >>> verify_schnorr' tex msg pub --- True --- >>> verify_schnorr' tex msg pub --- False -verify_schnorr' - :: Context -- ^ secp256k1 context - -> BS.ByteString -- ^ message - -> Pub -- ^ public key - -> BS.ByteString -- ^ 64-byte Schnorr signature - -> Bool -verify_schnorr' tex = _verify_schnorr (mul_wnaf tex) - -_verify_schnorr - :: (Integer -> Maybe Projective) -- partially-applied multiplication function - -> BS.ByteString - -> Pub - -> BS.ByteString - -> Bool -_verify_schnorr _mul m (affine -> Affine x_p _) sig - | BS.length sig /= 64 = False - | otherwise = M.isJust $ do - capP@(Affine x_P _) <- lift x_p - let (roll32 -> r, roll32 -> s) = BS.splitAt 32 sig - guard (r < _CURVE_P && s < _CURVE_Q) - let e = modQ . roll32 $ hash_challenge - (unroll32 r <> unroll32 x_P <> m) - pt0 <- _mul s - pt1 <- mul_unsafe (projective capP) e - let dif = add pt0 (neg pt1) - guard (dif /= _CURVE_ZERO) - let Affine x_R y_R = affine dif - guard $ not (I.integerTestBit y_R 0 || x_R /= r) - pure () -{-# INLINE _verify_schnorr #-} - --- hardcoded tag of BIP0340/aux --- --- \x -> let h = SHA256.hash "BIP0340/aux" --- in SHA256.hash (h <> h <> x) -hash_aux :: BS.ByteString -> BS.ByteString -hash_aux x = SHA256.hash $ - "\241\239N^\192c\202\218m\148\202\250\157\152~\160i&X9\236\193\US\151-w\165.\216\193\204\144\241\239N^\192c\202\218m\148\202\250\157\152~\160i&X9\236\193\US\151-w\165.\216\193\204\144" <> x -{-# INLINE hash_aux #-} - --- hardcoded tag of BIP0340/nonce -hash_nonce :: BS.ByteString -> BS.ByteString -hash_nonce x = SHA256.hash $ - "\aIw4\167\155\203\&5[\155\140}\ETXO\DC2\FS\244\&4\215>\247-\218\EM\135\NULa\251R\191\235/\aIw4\167\155\203\&5[\155\140}\ETXO\DC2\FS\244\&4\215>\247-\218\EM\135\NULa\251R\191\235/" <> x -{-# INLINE hash_nonce #-} - --- hardcoded tag of BIP0340/challenge -hash_challenge :: BS.ByteString -> BS.ByteString -hash_challenge x = SHA256.hash $ - "{\181-z\159\239X2>\177\191z@}\179\130\210\243\242\216\ESC\177\"OI\254Q\143mH\211|{\181-z\159\239X2>\177\191z@}\179\130\210\243\242\216\ESC\177\"OI\254Q\143mH\211|" <> x -{-# INLINE hash_challenge #-} - --- 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 --- Just "" -sign_ecdsa - :: Integer -- ^ secret key - -> BS.ByteString -- ^ message - -> Maybe ECDSA -sign_ecdsa = _sign_ecdsa (mul _CURVE_G) LowS Hash - --- | The same as 'sign_ecdsa', except uses a 'Context' to optimise internal --- calculations. --- --- You can expect about a 10x performance increase when using this --- function, compared to 'sign_ecdsa'. --- --- >>> let !tex = precompute --- >>> sign_ecdsa' tex sec msg --- Just "" -sign_ecdsa' - :: Context -- ^ secp256k1 context - -> Integer -- ^ secret key - -> BS.ByteString -- ^ message - -> Maybe ECDSA -sign_ecdsa' tex = _sign_ecdsa (mul_wnaf tex) 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 --- Just "" -sign_ecdsa_unrestricted - :: Integer -- ^ secret key - -> BS.ByteString -- ^ message - -> Maybe ECDSA -sign_ecdsa_unrestricted = _sign_ecdsa (mul _CURVE_G) Unrestricted Hash - --- | The same as 'sign_ecdsa_unrestricted', except uses a 'Context' to --- optimise internal calculations. --- --- You can expect about a 10x performance increase when using this --- function, compared to 'sign_ecdsa_unrestricted'. --- --- >>> let !tex = precompute --- >>> sign_ecdsa_unrestricted' tex sec msg --- Just "" -sign_ecdsa_unrestricted' - :: Context -- ^ secp256k1 context - -> Integer -- ^ secret key - -> BS.ByteString -- ^ message - -> Maybe ECDSA -sign_ecdsa_unrestricted' tex = _sign_ecdsa (mul_wnaf tex) 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 - -> Maybe ECDSA -_sign_ecdsa_no_hash = _sign_ecdsa (mul _CURVE_G) LowS NoHash - -_sign_ecdsa_no_hash' - :: Context - -> Integer - -> BS.ByteString - -> Maybe ECDSA -_sign_ecdsa_no_hash' tex = _sign_ecdsa (mul_wnaf tex) LowS NoHash - -_sign_ecdsa - :: (Integer -> Maybe Projective) -- partially-applied multiplication function - -> SigType - -> HashFlag - -> Integer - -> BS.ByteString - -> Maybe ECDSA -_sign_ecdsa _mul ty hf _SECRET m = runST $ do - -- RFC6979 sec 3.3a - let entropy = int2octets _SECRET - 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 mpair = do - kg <- _mul k - let Affine (modQ -> r) _ = affine kg - kinv <- modinv k (fi _CURVE_Q) - let s = remQ (remQ (h_modQ + remQ (_SECRET * r)) * kinv) - pure $! (r, s) - case mpair of - Nothing -> pure Nothing - Just (r, s) - | r == 0 -> sign_loop g -- negligible probability - | otherwise -> - let !sig = Just $! ECDSA r s - in case ty of - Unrestricted -> pure sig - LowS -> pure (fmap low sig) -{-# INLINE _sign_ecdsa #-} - --- 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 - --- | The same as 'verify_ecdsa', except uses a 'Context' to optimise --- internal calculations. --- --- You can expect about a 2x performance increase when using this --- function, compared to 'verify_ecdsa'. --- --- >>> let !tex = precompute --- >>> verify_ecdsa' tex msg pub valid_sig --- True --- >>> verify_ecdsa' tex msg pub invalid_sig --- False -verify_ecdsa' - :: Context -- ^ secp256k1 context - -> BS.ByteString -- ^ message - -> Pub -- ^ public key - -> ECDSA -- ^ signature - -> Bool -verify_ecdsa' tex m p sig@(ECDSA _ s) - | s > B.unsafeShiftR _CURVE_Q 1 = False - | otherwise = verify_ecdsa_unrestricted' tex 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 = _verify_ecdsa_unrestricted (mul_unsafe _CURVE_G) - --- | The same as 'verify_ecdsa_unrestricted', except uses a 'Context' to --- optimise internal calculations. --- --- You can expect about a 2x performance increase when using this --- function, compared to 'verify_ecdsa_unrestricted'. --- --- >>> let !tex = precompute --- >>> verify_ecdsa_unrestricted' tex msg pub valid_sig --- True --- >>> verify_ecdsa_unrestricted' tex msg pub invalid_sig --- False -verify_ecdsa_unrestricted' - :: Context -- ^ secp256k1 context - -> BS.ByteString -- ^ message - -> Pub -- ^ public key - -> ECDSA -- ^ signature - -> Bool -verify_ecdsa_unrestricted' tex = _verify_ecdsa_unrestricted (mul_wnaf tex) - -_verify_ecdsa_unrestricted - :: (Integer -> Maybe Projective) -- partially-applied multiplication function - -> BS.ByteString - -> Pub - -> ECDSA - -> Bool -_verify_ecdsa_unrestricted _mul (SHA256.hash -> h) p (ECDSA r s) = M.isJust $ do - -- SEC1-v2 4.1.4 - guard (ge r && ge s) - let e = remQ (bits2int h) - s_inv <- modinv s (fi _CURVE_Q) - let u1 = remQ (e * s_inv) - u2 = remQ (r * s_inv) - pt0 <- _mul u1 - pt1 <- mul_unsafe p u2 - let capR = add pt0 pt1 - guard (capR /= _CURVE_ZERO) - let Affine (modQ -> v) _ = affine capR - guard (v == r) - pure () -{-# INLINE _verify_ecdsa_unrestricted #-} - --- ecdh ----------------------------------------------------------------------- - --- SEC1-v2 3.3.1, plus SHA256 hash - --- | Compute a shared secret, given a secret key and public secp256k1 point, --- via Elliptic Curve Diffie-Hellman (ECDH). --- --- The shared secret is the SHA256 hash of the x-coordinate of the --- point obtained by scalar multiplication. --- --- >>> let sec_alice = 0x03 -- contrived --- >>> let sec_bob = 2 ^ 128 - 1 -- contrived --- >>> let Just pub_alice = derive_pub sec_alice --- >>> let Just pub_bob = derive_pub sec_bob --- >>> let secret_as_computed_by_alice = ecdh pub_bob sec_alice --- >>> let secret_as_computed_by_bob = ecdh pub_alice sec_bob --- >>> secret_as_computed_by_alice == secret_as_computed_by_bob --- True -ecdh - :: Projective -- ^ public key - -> Integer -- ^ secret key - -> Maybe BS.ByteString -- ^ shared secret -ecdh pub _SECRET = do - pt <- mul pub _SECRET - guard (pt /= _CURVE_ZERO) - let Affine x _ = affine pt - pure $! SHA256.hash (unroll32 x) +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnboxedTuples #-} +{-# 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, 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), and ECDH shared secret computation +-- on the elliptic curve secp256k1. + +module Crypto.Curve.Secp256k1 ( + -- * Field and group parameters + _CURVE_Q + , _CURVE_P + + -- * secp256k1 points + , Pub + , derive_pub + , derive_pub' + , _CURVE_G + , _CURVE_ZERO + , ge + , fe + + -- * Parsing + , parse_int256 + , parse_point + , parse_sig + + -- * Serializing + , serialize_point + + -- * ECDH + , ecdh + + -- * BIP0340 Schnorr signatures + , sign_schnorr + , verify_schnorr + + -- * RFC6979 ECDSA + , ECDSA(..) + , SigType(..) + , sign_ecdsa + , sign_ecdsa_unrestricted + , verify_ecdsa + , verify_ecdsa_unrestricted + + -- * Fast variants + , Context + , precompute + , sign_schnorr' + , verify_schnorr' + , sign_ecdsa' + , sign_ecdsa_unrestricted' + , verify_ecdsa' + , verify_ecdsa_unrestricted' + + -- Elliptic curve group operations + , neg + , add + , add_mixed + , add_proj + , double + , mul + , mul_vartime + , mul_wnaf + + -- Coordinate systems and transformations + , Affine(..) + , Projective(..) + , affine + , projective + , valid + + -- for testing/benchmarking + , _precompute + , _sign_ecdsa_no_hash + , _sign_ecdsa_no_hash' + , roll32 + , unsafe_roll32 + , unroll32 + , select_proj + ) where + +import Control.Monad (guard) +import Control.Monad.ST +import qualified Crypto.DRBG.HMAC as DRBG +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.Bits as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Unsafe as BU +import qualified Data.Choice as CT +import qualified Data.Maybe as M +import Data.Primitive.ByteArray (ByteArray(..), MutableByteArray(..)) +import qualified Data.Primitive.ByteArray as BA +import Data.Word (Word8) +import Data.Word.Limb (Limb(..)) +import qualified Data.Word.Limb as L +import Data.Word.Wider (Wider(..)) +import qualified Data.Word.Wider as W +import qualified Foreign.Storable as Storable (pokeByteOff) +import qualified GHC.Exts as Exts +import GHC.Generics +import qualified GHC.Word (Word(..), Word8(..)) +import qualified Numeric.Montgomery.Secp256k1.Curve as C +import qualified Numeric.Montgomery.Secp256k1.Scalar as S +import Prelude hiding (sqrt) + +-- convenience synonyms ------------------------------------------------------- + +-- Unboxed Wider/Montgomery synonym. +type Limb4 = (# Limb, Limb, Limb, Limb #) + +-- Unboxed Projective synonym. +type Proj = (# Limb4, Limb4, Limb4 #) + +pattern Zero :: Wider +pattern Zero = Wider Z + +pattern Z :: Limb4 +pattern Z = (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) + +pattern P :: Limb4 -> Limb4 -> Limb4 -> Projective +pattern P x y z = + Projective (C.Montgomery x) (C.Montgomery y) (C.Montgomery z) +{-# COMPLETE P #-} + +-- utilities ------------------------------------------------------------------ + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral +{-# INLINE fi #-} + +-- convert a Word8 to a Limb +limb :: Word8 -> Limb +limb (GHC.Word.W8# (Exts.word8ToWord# -> w)) = Limb w +{-# INLINABLE limb #-} + +-- convert a Limb to a Word8 +word8 :: Limb -> Word8 +word8 (Limb w) = GHC.Word.W8# (Exts.wordToWord8# w) +{-# INLINABLE word8 #-} + +-- convert a Limb to a Word8 after right-shifting +word8s :: Limb -> Exts.Int# -> Word8 +word8s l s = + let !(Limb w) = L.shr# l s + in GHC.Word.W8# (Exts.wordToWord8# w) +{-# INLINABLE word8s #-} + +-- convert a Word8 to a Wider +word8_to_wider :: Word8 -> Wider +word8_to_wider w = Wider (# limb w, Limb 0##, Limb 0##, Limb 0## #) +{-# INLINABLE word8_to_wider #-} + +-- unsafely extract the first 64-bit word from a big-endian-encoded bytestring +unsafe_word0 :: BS.ByteString -> Limb +unsafe_word0 bs = + (limb (BU.unsafeIndex bs 00) `L.shl#` 56#) + `L.or#` (limb (BU.unsafeIndex bs 01) `L.shl#` 48#) + `L.or#` (limb (BU.unsafeIndex bs 02) `L.shl#` 40#) + `L.or#` (limb (BU.unsafeIndex bs 03) `L.shl#` 32#) + `L.or#` (limb (BU.unsafeIndex bs 04) `L.shl#` 24#) + `L.or#` (limb (BU.unsafeIndex bs 05) `L.shl#` 16#) + `L.or#` (limb (BU.unsafeIndex bs 06) `L.shl#` 08#) + `L.or#` (limb (BU.unsafeIndex bs 07)) +{-# INLINABLE unsafe_word0 #-} + +-- unsafely extract the second 64-bit word from a big-endian-encoded bytestring +unsafe_word1 :: BS.ByteString -> Limb +unsafe_word1 bs = + (limb (BU.unsafeIndex bs 08) `L.shl#` 56#) + `L.or#` (limb (BU.unsafeIndex bs 09) `L.shl#` 48#) + `L.or#` (limb (BU.unsafeIndex bs 10) `L.shl#` 40#) + `L.or#` (limb (BU.unsafeIndex bs 11) `L.shl#` 32#) + `L.or#` (limb (BU.unsafeIndex bs 12) `L.shl#` 24#) + `L.or#` (limb (BU.unsafeIndex bs 13) `L.shl#` 16#) + `L.or#` (limb (BU.unsafeIndex bs 14) `L.shl#` 08#) + `L.or#` (limb (BU.unsafeIndex bs 15)) +{-# INLINABLE unsafe_word1 #-} + +-- unsafely extract the third 64-bit word from a big-endian-encoded bytestring +unsafe_word2 :: BS.ByteString -> Limb +unsafe_word2 bs = + (limb (BU.unsafeIndex bs 16) `L.shl#` 56#) + `L.or#` (limb (BU.unsafeIndex bs 17) `L.shl#` 48#) + `L.or#` (limb (BU.unsafeIndex bs 18) `L.shl#` 40#) + `L.or#` (limb (BU.unsafeIndex bs 19) `L.shl#` 32#) + `L.or#` (limb (BU.unsafeIndex bs 20) `L.shl#` 24#) + `L.or#` (limb (BU.unsafeIndex bs 21) `L.shl#` 16#) + `L.or#` (limb (BU.unsafeIndex bs 22) `L.shl#` 08#) + `L.or#` (limb (BU.unsafeIndex bs 23)) +{-# INLINABLE unsafe_word2 #-} + +-- unsafely extract the fourth 64-bit word from a big-endian-encoded bytestring +unsafe_word3 :: BS.ByteString -> Limb +unsafe_word3 bs = + (limb (BU.unsafeIndex bs 24) `L.shl#` 56#) + `L.or#` (limb (BU.unsafeIndex bs 25) `L.shl#` 48#) + `L.or#` (limb (BU.unsafeIndex bs 26) `L.shl#` 40#) + `L.or#` (limb (BU.unsafeIndex bs 27) `L.shl#` 32#) + `L.or#` (limb (BU.unsafeIndex bs 28) `L.shl#` 24#) + `L.or#` (limb (BU.unsafeIndex bs 29) `L.shl#` 16#) + `L.or#` (limb (BU.unsafeIndex bs 30) `L.shl#` 08#) + `L.or#` (limb (BU.unsafeIndex bs 31)) +{-# INLINABLE unsafe_word3 #-} + +-- 256-bit big-endian bytestring decoding. the input size is not checked! +unsafe_roll32 :: BS.ByteString -> Wider +unsafe_roll32 bs = + let !w0 = unsafe_word0 bs + !w1 = unsafe_word1 bs + !w2 = unsafe_word2 bs + !w3 = unsafe_word3 bs + in Wider (# w3, w2, w1, w0 #) +{-# INLINABLE unsafe_roll32 #-} + +-- arbitrary-size big-endian bytestring decoding +roll32 :: BS.ByteString -> Maybe Wider +roll32 bs + | BS.length stripped > 32 = Nothing + | otherwise = Just $! BS.foldl' alg 0 stripped + where + stripped = BS.dropWhile (== 0) bs + alg !a (word8_to_wider -> !b) = (a `W.shl_limb` 8) `W.or` b +{-# INLINABLE roll32 #-} + +-- 256-bit big-endian bytestring encoding +unroll32 :: Wider -> BS.ByteString +unroll32 (Wider (# w0, w1, w2, w3 #)) = + BI.unsafeCreate 32 $ \ptr -> do + -- w0 + Storable.pokeByteOff ptr 00 (word8s w3 56#) + Storable.pokeByteOff ptr 01 (word8s w3 48#) + Storable.pokeByteOff ptr 02 (word8s w3 40#) + Storable.pokeByteOff ptr 03 (word8s w3 32#) + Storable.pokeByteOff ptr 04 (word8s w3 24#) + Storable.pokeByteOff ptr 05 (word8s w3 16#) + Storable.pokeByteOff ptr 06 (word8s w3 08#) + Storable.pokeByteOff ptr 07 (word8 w3) + -- w1 + Storable.pokeByteOff ptr 08 (word8s w2 56#) + Storable.pokeByteOff ptr 09 (word8s w2 48#) + Storable.pokeByteOff ptr 10 (word8s w2 40#) + Storable.pokeByteOff ptr 11 (word8s w2 32#) + Storable.pokeByteOff ptr 12 (word8s w2 24#) + Storable.pokeByteOff ptr 13 (word8s w2 16#) + Storable.pokeByteOff ptr 14 (word8s w2 08#) + Storable.pokeByteOff ptr 15 (word8 w2) + -- w2 + Storable.pokeByteOff ptr 16 (word8s w1 56#) + Storable.pokeByteOff ptr 17 (word8s w1 48#) + Storable.pokeByteOff ptr 18 (word8s w1 40#) + Storable.pokeByteOff ptr 19 (word8s w1 32#) + Storable.pokeByteOff ptr 20 (word8s w1 24#) + Storable.pokeByteOff ptr 21 (word8s w1 16#) + Storable.pokeByteOff ptr 22 (word8s w1 08#) + Storable.pokeByteOff ptr 23 (word8 w1) + -- w3 + Storable.pokeByteOff ptr 24 (word8s w0 56#) + Storable.pokeByteOff ptr 25 (word8s w0 48#) + Storable.pokeByteOff ptr 26 (word8s w0 40#) + Storable.pokeByteOff ptr 27 (word8s w0 32#) + Storable.pokeByteOff ptr 28 (word8s w0 24#) + Storable.pokeByteOff ptr 29 (word8s w0 16#) + Storable.pokeByteOff ptr 30 (word8s w0 08#) + Storable.pokeByteOff ptr 31 (word8 w0) +{-# INLINABLE unroll32 #-} + +-- cheeky montgomery-assisted modQ +modQ :: Wider -> Wider +modQ = S.from . S.to +{-# INLINABLE modQ #-} + +-- bytewise xor +xor :: BS.ByteString -> BS.ByteString -> BS.ByteString +xor = BS.packZipWith B.xor +{-# INLINABLE xor #-} + +-- constants ------------------------------------------------------------------ + +-- | secp256k1 field prime. +_CURVE_P :: Wider +_CURVE_P = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F + +-- | secp256k1 group order. +_CURVE_Q :: Wider +_CURVE_Q = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 + +-- | half of the secp256k1 group order. +_CURVE_QH :: Wider +_CURVE_QH = 0x7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF5D576E7357A4501DDFE92F46681B20A0 + +-- 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 weierstrass form, /b/ coefficient +_CURVE_B :: Wider +_CURVE_B = 7 + +-- secp256k1 weierstrass form, /b/ coefficient, montgomery form +_CURVE_Bm :: C.Montgomery +_CURVE_Bm = 7 + +-- _CURVE_Bm * 3 +_CURVE_Bm3 :: C.Montgomery +_CURVE_Bm3 = 21 + +-- Is field element? +fe :: Wider -> Bool +fe n = n > 0 && n < _CURVE_P +{-# INLINE fe #-} + +-- Is group element? +ge :: Wider -> Bool +ge (Wider n) = CT.decide (ge# n) +{-# INLINE ge #-} + +-- curve points --------------------------------------------------------------- + +-- curve point, affine coordinates +data Affine = Affine !C.Montgomery !C.Montgomery + deriving stock (Show, Generic) + +-- curve point, projective coordinates +data Projective = Projective { + px :: !C.Montgomery + , py :: !C.Montgomery + , pz :: !C.Montgomery + } + deriving stock (Show, Generic) + +instance Eq Projective where + Projective ax ay az == Projective bx by bz = + let !x1z2 = ax * bz + !x2z1 = bx * az + !y1z2 = ay * bz + !y2z1 = by * az + in CT.decide (CT.and# (C.eq x1z2 x2z1) (C.eq y1z2 y2z1)) + +-- | An ECC-flavoured alias for a secp256k1 point. +type Pub = Projective + +-- Convert to affine coordinates. +affine :: Projective -> Affine +affine (Projective x y z) = + let !iz = C.inv z + in Affine (x * iz) (y * iz) +{-# INLINABLE affine #-} + +-- Convert to projective coordinates. +projective :: Affine -> Projective +projective = \case + Affine 0 0 -> _CURVE_ZERO + Affine x y -> Projective x y 1 + +-- | secp256k1 generator point. +_CURVE_G :: Projective +_CURVE_G = Projective x y z where + !x = C.Montgomery + (# Limb 15507633332195041431##, Limb 2530505477788034779## + , Limb 10925531211367256732##, Limb 11061375339145502536## #) + !y = C.Montgomery + (# Limb 12780836216951778274##, Limb 10231155108014310989## + , Limb 8121878653926228278##, Limb 14933801261141951190## #) + !z = C.Montgomery + (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) + +-- | secp256k1 zero point, point at infinity, or monoidal identity. +_CURVE_ZERO :: Projective +_CURVE_ZERO = Projective 0 1 0 + +-- secp256k1 zero point, point at infinity, or monoidal identity +_ZERO :: Projective +_ZERO = Projective 0 1 0 +{-# DEPRECATED _ZERO "use _CURVE_ZERO instead" #-} + +-- secp256k1 in short weierstrass form (y ^ 2 = x ^ 3 + 7) +weierstrass :: C.Montgomery -> C.Montgomery +weierstrass x = C.sqr x * x + _CURVE_Bm +{-# INLINE weierstrass #-} + +-- Point is valid +valid :: Projective -> Bool +valid p = case affine p of + Affine x y + | C.sqr y /= weierstrass x -> False + | otherwise -> True + +-- (bip0340) return point with x coordinate == x and with even y coordinate +-- +-- conceptually: +-- y ^ 2 = x ^ 3 + 7 +-- y = "+-" sqrt (x ^ 3 + 7) +-- (n.b. for solution y, p - y is also a solution) +-- y + (p - y) = p (odd) +-- (n.b. sum is odd, so one of y and p - y must be odd, and the other even) +-- if y even, return (x, y) +-- else, return (x, p - y) +lift_vartime :: C.Montgomery -> Maybe Affine +lift_vartime x = do + let !c = weierstrass x + !y <- C.sqrt c + let !y_e | C.odd y = negate y + | otherwise = y + guard (C.sqr y_e == c) + pure $! Affine x y_e + +even_y_vartime :: Projective -> Projective +even_y_vartime p = case affine p of + Affine _ (C.retr -> y) + | CT.decide (W.odd y) -> neg p + | otherwise -> p + +-- Constant-time selection of Projective points. +select_proj :: Projective -> Projective -> CT.Choice -> Projective +select_proj (P ax ay az) (P bx by bz) c = + P (W.select# ax bx c) (W.select# ay by c) (W.select# az bz c) +{-# INLINE select_proj #-} + +-- unboxed internals ---------------------------------------------------------- + +-- algo 7, renes et al, 2015 +add_proj# :: Proj -> Proj -> Proj +add_proj# (# x1, y1, z1 #) (# x2, y2, z2 #) = + let !(C.Montgomery b3) = _CURVE_Bm3 + !t0a = C.mul# x1 x2 + !t1a = C.mul# y1 y2 + !t2a = C.mul# z1 z2 + !t3a = C.add# x1 y1 + !t4a = C.add# x2 y2 + !t3b = C.mul# t3a t4a + !t4b = C.add# t0a t1a + !t3c = C.sub# t3b t4b + !t4c = C.add# y1 z1 + !x3a = C.add# y2 z2 + !t4d = C.mul# t4c x3a + !x3b = C.add# t1a t2a + !t4e = C.sub# t4d x3b + !x3c = C.add# x1 z1 + !y3a = C.add# x2 z2 + !x3d = C.mul# x3c y3a + !y3b = C.add# t0a t2a + !y3c = C.sub# x3d y3b + !x3e = C.add# t0a t0a + !t0b = C.add# x3e t0a + !t2b = C.mul# b3 t2a + !z3a = C.add# t1a t2b + !t1b = C.sub# t1a t2b + !y3d = C.mul# b3 y3c + !x3f = C.mul# t4e y3d + !t2c = C.mul# t3c t1b + !x3g = C.sub# t2c x3f + !y3e = C.mul# y3d t0b + !t1c = C.mul# t1b z3a + !y3f = C.add# t1c y3e + !t0c = C.mul# t0b t3c + !z3b = C.mul# z3a t4e + !z3c = C.add# z3b t0c + in (# x3g, y3f, z3c #) +{-# INLINE add_proj# #-} + +-- algo 8, renes et al, 2015 +add_mixed# :: Proj -> Proj -> Proj +add_mixed# (# x1, y1, z1 #) (# x2, y2, _z2 #) = + let !(C.Montgomery b3) = _CURVE_Bm3 + !t0a = C.mul# x1 x2 + !t1a = C.mul# y1 y2 + !t3a = C.add# x2 y2 + !t4a = C.add# x1 y1 + !t3b = C.mul# t3a t4a + !t4b = C.add# t0a t1a + !t3c = C.sub# t3b t4b + !t4c = C.mul# y2 z1 + !t4d = C.add# t4c y1 + !y3a = C.mul# x2 z1 + !y3b = C.add# y3a x1 + !x3a = C.add# t0a t0a + !t0b = C.add# x3a t0a + !t2a = C.mul# b3 z1 + !z3a = C.add# t1a t2a + !t1b = C.sub# t1a t2a + !y3c = C.mul# b3 y3b + !x3b = C.mul# t4d y3c + !t2b = C.mul# t3c t1b + !x3c = C.sub# t2b x3b + !y3d = C.mul# y3c t0b + !t1c = C.mul# t1b z3a + !y3e = C.add# t1c y3d + !t0c = C.mul# t0b t3c + !z3b = C.mul# z3a t4d + !z3c = C.add# z3b t0c + in (# x3c, y3e, z3c #) +{-# INLINE add_mixed# #-} + +-- algo 9, renes et al, 2015 +double# :: Proj -> Proj +double# (# x, y, z #) = + let !(C.Montgomery b3) = _CURVE_Bm3 + !t0 = C.sqr# y + !z3a = C.add# t0 t0 + !z3b = C.add# z3a z3a + !z3c = C.add# z3b z3b + !t1 = C.mul# y z + !t2a = C.sqr# z + !t2b = C.mul# b3 t2a + !x3a = C.mul# t2b z3c + !y3a = C.add# t0 t2b + !z3d = C.mul# t1 z3c + !t1b = C.add# t2b t2b + !t2c = C.add# t1b t2b + !t0b = C.sub# t0 t2c + !y3b = C.mul# t0b y3a + !y3c = C.add# x3a y3b + !t1c = C.mul# x y + !x3b = C.mul# t0b t1c + !x3c = C.add# x3b x3b + in (# x3c, y3c, z3d #) +{-# INLINE double# #-} + +select_proj# :: Proj -> Proj -> CT.Choice -> Proj +select_proj# (# ax, ay, az #) (# bx, by, bz #) c = + (# W.select# ax bx c, W.select# ay by c, W.select# az bz c #) +{-# INLINE select_proj# #-} + +neg# :: Proj -> Proj +neg# (# x, y, z #) = (# x, C.neg# y, z #) +{-# INLINE neg# #-} + +mul# :: Proj -> Limb4 -> (# () | Proj #) +mul# (# px, py, pz #) s + | CT.decide (CT.not# (ge# s)) = (# () | #) + | otherwise = + let !(P gx gy gz) = _CURVE_G + !(C.Montgomery o) = C.one + in loop (0 :: Int) (# Z, o, Z #) (# gx, gy, gz #) (# px, py, pz #) s + where + loop !j !a !f !d !_SECRET + | j == _CURVE_Q_BITS = (# | a #) + | otherwise = + let !nd = double# d + !(# nm, lsb_set #) = W.shr1_c# _SECRET + !nacc = select_proj# a (add_proj# a d) lsb_set + !nf = select_proj# (add_proj# f d) f lsb_set + in loop (succ j) nacc nf nd nm +{-# INLINE mul# #-} + +ge# :: Limb4 -> CT.Choice +ge# n = + let !(Wider q) = _CURVE_Q + in CT.and# (W.gt# n Z) (W.lt# n q) +{-# INLINE ge# #-} + +mul_wnaf# :: ByteArray -> Int -> Limb4 -> (# () | Proj #) +mul_wnaf# ctxArray ctxW ls + | CT.decide (CT.not# (ge# ls)) = (# () | #) + | otherwise = + let !(P zx zy zz) = _CURVE_ZERO + !(P gx gy gz) = _CURVE_G + in (# | loop 0 (# zx, zy, zz #) (# gx, gy, gz #) ls #) + where + !one = (# Limb 1##, Limb 0##, Limb 0##, Limb 0## #) + !wins = fi (256 `quot` ctxW + 1) + !size@(GHC.Word.W# s) = 2 ^ (ctxW - 1) + !(GHC.Word.W# mask) = 2 ^ ctxW - 1 + !(GHC.Word.W# texW) = fi ctxW + !(GHC.Word.W# mnum) = 2 ^ ctxW + + loop !j@(GHC.Word.W# w) !acc !f !n@(# Limb lo, _, _, _ #) + | j == wins = acc + | otherwise = + let !(GHC.Word.W# off0) = j * size + !b0 = Exts.and# lo mask + !bor = CT.from_word_gt# b0 s + + !(# n0, _ #) = W.shr_limb# n (Exts.word2Int# texW) + !n0_plus_1 = W.add_w# n0 one + !n1 = W.select# n0 n0_plus_1 bor + + !abs_b = CT.select_word# b0 (Exts.minusWord# mnum b0) bor + !is_zero = CT.from_word_eq# b0 0## + !c0 = CT.from_word# (Exts.and# w 1##) + !off_nz = Exts.minusWord# (Exts.plusWord# off0 abs_b) 1## + !off = CT.select_word# off0 off_nz (CT.not# is_zero) + + !pr = index_proj# ctxArray (Exts.word2Int# off) + !neg_pr = neg# pr + !pt_zero = select_proj# pr neg_pr c0 + !pt_nonzero = select_proj# pr neg_pr bor + + !f_added = add_proj# f pt_zero + !acc_added = add_proj# acc pt_nonzero + !nacc = select_proj# acc_added acc is_zero + !nf = select_proj# f f_added is_zero + in loop (succ j) nacc nf n1 +{-# INLINE mul_wnaf# #-} + +-- retrieve a point (as an unboxed tuple) from a context array +index_proj# :: ByteArray -> Exts.Int# -> Proj +index_proj# (ByteArray arr#) i# = + let !base# = i# Exts.*# 12# + !x = (# Limb (Exts.indexWordArray# arr# base#) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 01#)) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 02#)) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 03#)) #) + !y = (# Limb (Exts.indexWordArray# arr# (base# Exts.+# 04#)) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 05#)) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 06#)) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 07#)) #) + !z = (# Limb (Exts.indexWordArray# arr# (base# Exts.+# 08#)) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 09#)) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 10#)) + , Limb (Exts.indexWordArray# arr# (base# Exts.+# 11#)) #) + in (# x, y, z #) +{-# INLINE index_proj# #-} + +-- ec arithmetic -------------------------------------------------------------- + +-- Negate secp256k1 point. +neg :: Projective -> Projective +neg (P x y z) = + let !(# px, py, pz #) = neg# (# x, y, z #) + in P px py pz +{-# INLINABLE neg #-} + +-- Elliptic curve addition on secp256k1. +add :: Projective -> Projective -> Projective +add p q = add_proj p q +{-# INLINABLE add #-} + +-- 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 (P ax ay az) (P bx by bz) = + let !(# x, y, z #) = add_proj# (# ax, ay, az #) (# bx, by, bz #) + in P x y z +{-# INLINABLE add_proj #-} + +-- algo 8, renes et al, 2015 +add_mixed :: Projective -> Projective -> Projective +add_mixed (P ax ay az) (P bx by bz) = + let !(# x, y, z #) = add_mixed# (# ax, ay, az #) (# bx, by, bz #) + in P x y z +{-# INLINABLE add_mixed #-} + +-- algo 9, renes et al, 2015 +double :: Projective -> Projective +double (Projective (C.Montgomery ax) (C.Montgomery ay) (C.Montgomery az)) = + let !(# x, y, z #) = double# (# ax, ay, az #) + in P x y z +{-# INLINABLE double #-} + +-- Timing-safe scalar multiplication of secp256k1 points. +mul :: Projective -> Wider -> Maybe Projective +mul (P x y z) (Wider s) = case mul# (# x, y, z #) s of + (# () | #) -> Nothing + (# | (# px, py, pz #) #) -> Just $! P px py pz +{-# INLINABLE mul #-} + +-- Timing-unsafe scalar multiplication of secp256k1 points. +-- +-- Don't use this function if the scalar could potentially be a secret. +mul_vartime :: Projective -> Wider -> Maybe Projective +mul_vartime p = \case + Zero -> pure _CURVE_ZERO + n | not (ge n) -> Nothing + | otherwise -> pure $! loop _CURVE_ZERO p n + where + loop !r !d = \case + Zero -> r + m -> + let !nd = double d + !(# nm, lsb_set #) = W.shr1_c m + !nr = if CT.decide lsb_set then add r d else r + in loop nr nd nm + +-- | Precomputed multiples of the secp256k1 base or generator point. +data Context = Context { + ctxW :: {-# UNPACK #-} !Int + , ctxArray :: {-# UNPACK #-} !ByteArray + } deriving Generic + +instance Show Context where + show Context {} = "" + +-- | Create a secp256k1 context by precomputing multiples of the curve's +-- generator point. +-- +-- This should be used once to create a 'Context' to be reused +-- repeatedly afterwards. +-- +-- >>> let !tex = precompute +-- >>> sign_ecdsa' tex sec msg +-- >>> sign_schnorr' tex sec msg aux +precompute :: Context +precompute = _precompute 8 + +-- This is a highly-optimized version of a function originally +-- translated from noble-secp256k1's "precompute". Points are stored in +-- a ByteArray by arranging each limb into slices of 12 consecutive +-- slots (each Projective point consists of three Montgomery values, +-- each of which consists of four limbs, summing to twelve limbs in +-- total). +-- +-- Each point takes 96 bytes to store in this fashion, so the total size of +-- the ByteArray is (size * 96) bytes. +_precompute :: Int -> Context +_precompute ctxW = Context {..} where + capJ = (2 :: Int) ^ (ctxW - 1) + ws = 256 `quot` ctxW + 1 + size = ws * capJ + + -- construct the context array + ctxArray = runST $ do + marr <- BA.newByteArray (size * 96) + loop_w marr _CURVE_G 0 + BA.unsafeFreezeByteArray marr + + -- write a point into the i^th 12-slot slice in the array + write :: MutableByteArray s -> Int -> Projective -> ST s () + write marr i + (P (# Limb x0, Limb x1, Limb x2, Limb x3 #) + (# Limb y0, Limb y1, Limb y2, Limb y3 #) + (# Limb z0, Limb z1, Limb z2, Limb z3 #)) = do + let !base = i * 12 + BA.writeByteArray marr (base + 00) (GHC.Word.W# x0) + BA.writeByteArray marr (base + 01) (GHC.Word.W# x1) + BA.writeByteArray marr (base + 02) (GHC.Word.W# x2) + BA.writeByteArray marr (base + 03) (GHC.Word.W# x3) + BA.writeByteArray marr (base + 04) (GHC.Word.W# y0) + BA.writeByteArray marr (base + 05) (GHC.Word.W# y1) + BA.writeByteArray marr (base + 06) (GHC.Word.W# y2) + BA.writeByteArray marr (base + 07) (GHC.Word.W# y3) + BA.writeByteArray marr (base + 08) (GHC.Word.W# z0) + BA.writeByteArray marr (base + 09) (GHC.Word.W# z1) + BA.writeByteArray marr (base + 10) (GHC.Word.W# z2) + BA.writeByteArray marr (base + 11) (GHC.Word.W# z3) + + -- loop over windows + loop_w :: MutableByteArray s -> Projective -> Int -> ST s () + loop_w !marr !p !w + | w == ws = pure () + | otherwise = do + nb <- loop_j marr p p (w * capJ) 0 + let np = double nb + loop_w marr np (succ w) + + -- loop within windows + loop_j + :: MutableByteArray s + -> Projective + -> Projective + -> Int + -> Int + -> ST s Projective + loop_j !marr !p !b !idx !j = do + write marr idx b + if j == capJ - 1 + then pure b + else do + let !nb = add b p + loop_j marr p nb (succ idx) (succ j) + +-- Timing-safe wNAF (w-ary non-adjacent form) scalar multiplication of +-- secp256k1 points. +mul_wnaf :: Context -> Wider -> Maybe Projective +mul_wnaf Context {..} (Wider s) = case mul_wnaf# ctxArray ctxW s of + (# () | #) -> Nothing + (# | (# px, py, pz #) #) -> Just $! P px py pz +{-# INLINABLE mul_wnaf #-} + +-- | 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 +-- Just "" +derive_pub :: Wider -> Maybe Pub +derive_pub = mul _CURVE_G +{-# NOINLINE derive_pub #-} + +-- | The same as 'derive_pub', except uses a 'Context' to optimise +-- internal calculations. +-- +-- >>> import qualified System.Entropy as E +-- >>> sk <- fmap parse_int256 (E.getEntropy 32) +-- >>> let !tex = precompute +-- >>> derive_pub' tex sk +-- Just "" +derive_pub' :: Context -> Wider -> Maybe Pub +derive_pub' = mul_wnaf +{-# NOINLINE derive_pub' #-} + +-- parsing -------------------------------------------------------------------- + +-- | Parse a 'Wider', /e.g./ a Schnorr or ECDSA secret key. +-- +-- >>> import qualified Data.ByteString as BS +-- >>> parse_int256 (BS.replicate 32 0xFF) +-- Just <2^256 - 1> +parse_int256 :: BS.ByteString -> Maybe Wider +parse_int256 bs = do + guard (BS.length bs == 32) + pure $! unsafe_roll32 bs +{-# INLINABLE parse_int256 #-} + +-- | 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_vartime . C.to . unsafe_roll32 + +-- bytestring input is guaranteed to be 32B in length +_parse_compressed :: Word8 -> BS.ByteString -> Maybe Projective +_parse_compressed h (unsafe_roll32 -> x) + | h /= 0x02 && h /= 0x03 = Nothing + | not (fe x) = Nothing + | otherwise = do + let !mx = C.to x + !my <- C.sqrt (weierstrass mx) + let !yodd = CT.decide (W.odd (C.retr my)) + !hodd = B.testBit h 0 + pure $! + if hodd /= yodd + then Projective mx (negate my) 1 + else Projective mx my 1 + +-- bytestring input is guaranteed to be 64B in length +_parse_uncompressed :: Word8 -> BS.ByteString -> Maybe Projective +_parse_uncompressed h bs = do + let (unsafe_roll32 -> x, unsafe_roll32 -> y) = BS.splitAt _CURVE_Q_BYTES bs + guard (h == 0x04) + let !p = Projective (C.to x) (C.to y) 1 + guard (valid p) + pure $! p + +-- | Parse an ECDSA signature encoded in 64-byte "compact" form. +-- +-- >>> parse_sig <64-byte compact signature> +-- Just "" +parse_sig :: BS.ByteString -> Maybe ECDSA +parse_sig bs = do + guard (BS.length bs == 64) + let (r0, s0) = BS.splitAt 32 bs + r <- roll32 r0 + s <- roll32 s0 + pure $! ECDSA r s + +-- serializing ---------------------------------------------------------------- + +-- | Serialize a secp256k1 point in 33-byte compressed form. +-- +-- >>> serialize_point pub +-- "<33-byte compressed point>" +serialize_point :: Projective -> BS.ByteString +serialize_point (affine -> Affine (C.from -> x) (C.from -> y)) = + let !(Wider (# Limb w, _, _, _ #)) = y + !b | B.testBit (GHC.Word.W# w) 0 = 0x03 + | otherwise = 0x02 + in BS.cons b (unroll32 x) + +-- ecdh ----------------------------------------------------------------------- + +-- SEC1-v2 3.3.1, plus SHA256 hash + +-- | Compute a shared secret, given a secret key and public secp256k1 point, +-- via Elliptic Curve Diffie-Hellman (ECDH). +-- +-- The shared secret is the SHA256 hash of the x-coordinate of the +-- point obtained by scalar multiplication. +-- +-- >>> let sec_alice = 0x03 +-- >>> let sec_bob = 2 ^ 128 - 1 +-- >>> let Just pub_alice = derive_pub sec_alice +-- >>> let Just pub_bob = derive_pub sec_bob +-- >>> let secret_as_computed_by_alice = ecdh pub_bob sec_alice +-- >>> let secret_as_computed_by_bob = ecdh pub_alice sec_bob +-- >>> secret_as_computed_by_alice == secret_as_computed_by_bob +-- True +ecdh + :: Projective -- ^ public key + -> Wider -- ^ secret key + -> Maybe BS.ByteString -- ^ shared secret +ecdh pub _SECRET = do + pt@(P _ _ (C.Montgomery -> z)) <- mul pub _SECRET + let !(Affine (C.retr -> x) _) = affine pt + !result = SHA256.hash (unroll32 x) + if CT.decide (C.eq z 0) then Nothing else Just result + +-- 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 +-- Just "<64-byte schnorr signature>" +sign_schnorr + :: Wider -- ^ secret key + -> BS.ByteString -- ^ message + -> BS.ByteString -- ^ 32 bytes of auxilliary random data + -> Maybe BS.ByteString -- ^ 64-byte Schnorr signature +sign_schnorr = _sign_schnorr (mul _CURVE_G) + +-- | The same as 'sign_schnorr', except uses a 'Context' to optimise +-- internal calculations. +-- +-- You can expect about a 2x performance increase when using this +-- function, compared to 'sign_schnorr'. +-- +-- >>> import qualified System.Entropy as E +-- >>> aux <- E.getEntropy 32 +-- >>> let !tex = precompute +-- >>> sign_schnorr' tex sec msg aux +-- Just "<64-byte schnorr signature>" +sign_schnorr' + :: Context -- ^ secp256k1 context + -> Wider -- ^ secret key + -> BS.ByteString -- ^ message + -> BS.ByteString -- ^ 32 bytes of auxilliary random data + -> Maybe BS.ByteString -- ^ 64-byte Schnorr signature +sign_schnorr' tex = _sign_schnorr (mul_wnaf tex) + +_sign_schnorr + :: (Wider -> Maybe Projective) -- partially-applied multiplication function + -> Wider -- secret key + -> BS.ByteString -- message + -> BS.ByteString -- 32 bytes of auxilliary random data + -> Maybe BS.ByteString +_sign_schnorr _mul _SECRET m a = do + p <- _mul _SECRET + let Affine (C.retr -> x_p) (C.retr -> y_p) = affine p + s = S.to _SECRET + d = S.select s (negate s) (W.odd y_p) + bytes_d = unroll32 (S.retr d) + bytes_p = unroll32 x_p + t = xor bytes_d (hash_aux a) + rand = hash_nonce (t <> bytes_p <> m) + k' = S.to (unsafe_roll32 rand) + guard (k' /= 0) -- negligible probability + pt <- _mul (S.retr k') + let Affine (C.retr -> x_r) (C.retr -> y_r) = affine pt + k = S.select k' (negate k') (W.odd y_r) + bytes_r = unroll32 x_r + rand' = hash_challenge (bytes_r <> bytes_p <> m) + e = S.to (unsafe_roll32 rand') + bytes_ked = unroll32 (S.retr (k + e * d)) + sig = bytes_r <> bytes_ked + -- NB for benchmarking we morally want to remove the precautionary + -- verification check here. + -- + -- guard (verify_schnorr m p sig) + pure $! sig +{-# INLINE _sign_schnorr #-} + +-- | 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 = _verify_schnorr (mul_vartime _CURVE_G) + +-- | The same as 'verify_schnorr', except uses a 'Context' to optimise +-- internal calculations. +-- +-- You can expect about a 1.5x performance increase when using this +-- function, compared to 'verify_schnorr'. +-- +-- >>> let !tex = precompute +-- >>> verify_schnorr' tex msg pub +-- True +-- >>> verify_schnorr' tex msg pub +-- False +verify_schnorr' + :: Context -- ^ secp256k1 context + -> BS.ByteString -- ^ message + -> Pub -- ^ public key + -> BS.ByteString -- ^ 64-byte Schnorr signature + -> Bool +verify_schnorr' tex = _verify_schnorr (mul_wnaf tex) + +_verify_schnorr + :: (Wider -> Maybe Projective) -- partially-applied multiplication function + -> BS.ByteString + -> Pub + -> BS.ByteString + -> Bool +_verify_schnorr _mul m p sig + | BS.length sig /= 64 = False + | otherwise = M.isJust $ do + let capP = even_y_vartime p + (unsafe_roll32 -> r, unsafe_roll32 -> s) = BS.splitAt 32 sig + guard (fe r && ge s) + let Affine (C.retr -> x_P) _ = affine capP + e = modQ . unsafe_roll32 $ + hash_challenge (unroll32 r <> unroll32 x_P <> m) + pt0 <- _mul s + pt1 <- mul_vartime capP e + let dif = add pt0 (neg pt1) + guard (dif /= _CURVE_ZERO) + let Affine (C.from -> x_R) (C.from -> y_R) = affine dif + guard $ not (CT.decide (W.odd y_R) || x_R /= r) -- XX +{-# INLINE _verify_schnorr #-} + +-- hardcoded tag of BIP0340/aux +-- +-- \x -> let h = SHA256.hash "BIP0340/aux" +-- in SHA256.hash (h <> h <> x) +hash_aux :: BS.ByteString -> BS.ByteString +hash_aux x = SHA256.hash $ + "\241\239N^\192c\202\218m\148\202\250\157\152~\160i&X9\236\193\US\151-w\165.\216\193\204\144\241\239N^\192c\202\218m\148\202\250\157\152~\160i&X9\236\193\US\151-w\165.\216\193\204\144" <> x +{-# INLINE hash_aux #-} + +-- hardcoded tag of BIP0340/nonce +hash_nonce :: BS.ByteString -> BS.ByteString +hash_nonce x = SHA256.hash $ + "\aIw4\167\155\203\&5[\155\140}\ETXO\DC2\FS\244\&4\215>\247-\218\EM\135\NULa\251R\191\235/\aIw4\167\155\203\&5[\155\140}\ETXO\DC2\FS\244\&4\215>\247-\218\EM\135\NULa\251R\191\235/" <> x +{-# INLINE hash_nonce #-} + +-- hardcoded tag of BIP0340/challenge +hash_challenge :: BS.ByteString -> BS.ByteString +hash_challenge x = SHA256.hash $ + "{\181-z\159\239X2>\177\191z@}\179\130\210\243\242\216\ESC\177\"OI\254Q\143mH\211|{\181-z\159\239X2>\177\191z@}\179\130\210\243\242\216\ESC\177\"OI\254Q\143mH\211|" <> x +{-# INLINE hash_challenge #-} + +-- ecdsa ---------------------------------------------------------------------- +-- see https://www.rfc-editor.org/rfc/rfc6979, https://secg.org/sec1-v2.pdf + +-- RFC6979 2.3.2 +bits2int :: BS.ByteString -> Wider +bits2int = unsafe_roll32 +{-# INLINABLE bits2int #-} + +-- RFC6979 2.3.3 +int2octets :: Wider -> BS.ByteString +int2octets = unroll32 +{-# INLINABLE int2octets #-} + +-- 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 :: !Wider + , ecdsa_s :: !Wider + } + 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 + +-- Convert an ECDSA signature to low-S form. +low :: ECDSA -> ECDSA +low (ECDSA r s) = ECDSA r (W.select s (_CURVE_Q - s) (W.gt s _CURVE_QH)) +{-# INLINE low #-} + +-- | 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 +-- Just "" +sign_ecdsa + :: Wider -- ^ secret key + -> BS.ByteString -- ^ message + -> Maybe ECDSA +sign_ecdsa = _sign_ecdsa (mul _CURVE_G) LowS Hash + +-- | The same as 'sign_ecdsa', except uses a 'Context' to optimise internal +-- calculations. +-- +-- You can expect about a 10x performance increase when using this +-- function, compared to 'sign_ecdsa'. +-- +-- >>> let !tex = precompute +-- >>> sign_ecdsa' tex sec msg +-- Just "" +sign_ecdsa' + :: Context -- ^ secp256k1 context + -> Wider -- ^ secret key + -> BS.ByteString -- ^ message + -> Maybe ECDSA +sign_ecdsa' tex = _sign_ecdsa (mul_wnaf tex) 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 +-- Just "" +sign_ecdsa_unrestricted + :: Wider -- ^ secret key + -> BS.ByteString -- ^ message + -> Maybe ECDSA +sign_ecdsa_unrestricted = _sign_ecdsa (mul _CURVE_G) Unrestricted Hash + +-- | The same as 'sign_ecdsa_unrestricted', except uses a 'Context' to +-- optimise internal calculations. +-- +-- You can expect about a 10x performance increase when using this +-- function, compared to 'sign_ecdsa_unrestricted'. +-- +-- >>> let !tex = precompute +-- >>> sign_ecdsa_unrestricted' tex sec msg +-- Just "" +sign_ecdsa_unrestricted' + :: Context -- ^ secp256k1 context + -> Wider -- ^ secret key + -> BS.ByteString -- ^ message + -> Maybe ECDSA +sign_ecdsa_unrestricted' tex = _sign_ecdsa (mul_wnaf tex) 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 + :: Wider -- ^ secret key + -> BS.ByteString -- ^ message digest + -> Maybe ECDSA +_sign_ecdsa_no_hash = _sign_ecdsa (mul _CURVE_G) LowS NoHash + +_sign_ecdsa_no_hash' + :: Context + -> Wider + -> BS.ByteString + -> Maybe ECDSA +_sign_ecdsa_no_hash' tex = _sign_ecdsa (mul_wnaf tex) LowS NoHash + +_sign_ecdsa + :: (Wider -> Maybe Projective) -- partially-applied multiplication function + -> SigType + -> HashFlag + -> Wider + -> BS.ByteString + -> Maybe ECDSA +_sign_ecdsa _mul ty hf _SECRET m = runST $ do + -- RFC6979 sec 3.3a + let entropy = int2octets _SECRET + nonce = bits2octets h + drbg <- DRBG.new SHA256.hmac entropy nonce mempty + -- RFC6979 sec 2.4 + sign_loop drbg + where + d = S.to _SECRET + hm = S.to (bits2int h) + h = case hf of + Hash -> SHA256.hash m + NoHash -> m + + sign_loop g = do + k <- gen_k g + let mpair = do + kg <- _mul k + let Affine (S.to . C.retr -> r) _ = affine kg + ki = S.inv (S.to k) + s = (hm + d * r) * ki + pure $! (S.retr r, S.retr s) + case mpair of + Nothing -> pure Nothing + Just (r, s) + | r == 0 -> sign_loop g -- negligible probability + | otherwise -> + let !sig = Just $! ECDSA r s + in case ty of + Unrestricted -> pure sig + LowS -> pure (fmap low sig) +{-# INLINE _sign_ecdsa #-} + +-- RFC6979 sec 3.3b +gen_k :: DRBG.DRBG s -> ST s Wider +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 #-} + +-- | 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 > _CURVE_QH = False + | otherwise = verify_ecdsa_unrestricted m p sig + +-- | The same as 'verify_ecdsa', except uses a 'Context' to optimise +-- internal calculations. +-- +-- You can expect about a 2x performance increase when using this +-- function, compared to 'verify_ecdsa'. +-- +-- >>> let !tex = precompute +-- >>> verify_ecdsa' tex msg pub valid_sig +-- True +-- >>> verify_ecdsa' tex msg pub invalid_sig +-- False +verify_ecdsa' + :: Context -- ^ secp256k1 context + -> BS.ByteString -- ^ message + -> Pub -- ^ public key + -> ECDSA -- ^ signature + -> Bool +verify_ecdsa' tex m p sig@(ECDSA _ s) + | s > _CURVE_QH = False + | otherwise = verify_ecdsa_unrestricted' tex 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 = _verify_ecdsa_unrestricted (mul_vartime _CURVE_G) + +-- | The same as 'verify_ecdsa_unrestricted', except uses a 'Context' to +-- optimise internal calculations. +-- +-- You can expect about a 2x performance increase when using this +-- function, compared to 'verify_ecdsa_unrestricted'. +-- +-- >>> let !tex = precompute +-- >>> verify_ecdsa_unrestricted' tex msg pub valid_sig +-- True +-- >>> verify_ecdsa_unrestricted' tex msg pub invalid_sig +-- False +verify_ecdsa_unrestricted' + :: Context -- ^ secp256k1 context + -> BS.ByteString -- ^ message + -> Pub -- ^ public key + -> ECDSA -- ^ signature + -> Bool +verify_ecdsa_unrestricted' tex = _verify_ecdsa_unrestricted (mul_wnaf tex) + +_verify_ecdsa_unrestricted + :: (Wider -> Maybe Projective) -- partially-applied multiplication function + -> BS.ByteString + -> Pub + -> ECDSA + -> Bool +_verify_ecdsa_unrestricted _mul m p (ECDSA r0 s0) = M.isJust $ do + -- SEC1-v2 4.1.4 + let h = SHA256.hash m + guard (ge r0 && ge s0) + let r = S.to r0 + s = S.to s0 + e = S.to (bits2int h) + si = S.inv s + u1 = S.retr (e * si) + u2 = S.retr (r * si) + pt0 <- _mul u1 + pt1 <- mul_vartime p u2 + let capR = add pt0 pt1 + guard (capR /= _CURVE_ZERO) + let Affine (S.to . C.retr -> v) _ = affine capR + guard (v == r) +{-# INLINE _verify_ecdsa_unrestricted #-} diff --git a/ppad-secp256k1.cabal b/ppad-secp256k1.cabal --- a/ppad-secp256k1.cabal +++ b/ppad-secp256k1.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-secp256k1 -version: 0.4.0 +version: 0.5.0 synopsis: Schnorr signatures, ECDSA, and ECDH on the elliptic curve secp256k1 license: MIT @@ -15,6 +15,11 @@ Pure BIP0340-style Schnorr signatures, deterministic RFC6979 ECDSA, and ECDH shared secret computation on the elliptic curve secp256k1. +flag llvm + description: Use GHC's LLVM backend. + default: False + manual: True + source-repository head type: git location: git.ppad.tech/secp256k1.git @@ -24,6 +29,8 @@ hs-source-dirs: lib ghc-options: -Wall + if flag(llvm) + ghc-options: -fllvm -O2 exposed-modules: Crypto.Curve.Secp256k1 build-depends: @@ -31,6 +38,7 @@ , bytestring >= 0.9 && < 0.13 , ppad-hmac-drbg >= 0.1 && < 0.2 , ppad-sha256 >= 0.2 && < 0.3 + , ppad-fixed >= 0.1 && < 0.2 , primitive >= 0.8 && < 0.10 test-suite secp256k1-tests @@ -51,8 +59,9 @@ aeson , attoparsec , base - , base16-bytestring , bytestring + , ppad-base16 + , ppad-fixed , ppad-secp256k1 , ppad-sha256 , tasty @@ -70,10 +79,11 @@ build-depends: base - , base16-bytestring , bytestring , criterion , deepseq + , ppad-base16 + , ppad-fixed , ppad-secp256k1 benchmark secp256k1-weigh @@ -87,9 +97,10 @@ build-depends: base - , base16-bytestring , bytestring , deepseq + , ppad-base16 + , ppad-fixed , ppad-secp256k1 , weigh diff --git a/test/BIP340.hs b/test/BIP340.hs --- a/test/BIP340.hs +++ b/test/BIP340.hs @@ -13,19 +13,13 @@ 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 +decodeLenient :: BS.ByteString -> BS.ByteString +decodeLenient bs = case B16.decode bs of + Nothing -> error "bang" + Just b -> b data Case = Case { c_index :: !Int @@ -40,7 +34,7 @@ execute :: Context -> Case -> TestTree execute tex Case {..} = testCase ("bip0340 " <> show c_index) $ - case parse_point (B16.decodeLenient c_pk) of + case parse_point (decodeLenient c_pk) of Nothing -> assertBool mempty (not c_res) Just pk -> do if c_sk == mempty @@ -56,7 +50,7 @@ assertBool mempty (not ver') -- XX test pubkey derivation from sk else do -- signature present; test sig too - let sk = roll c_sk + let sk = unsafe_roll32 c_sk Just sig = sign_schnorr sk c_msg c_aux Just sig' = sign_schnorr' tex sk c_msg c_aux ver = verify_schnorr c_msg pk sig @@ -80,15 +74,15 @@ test_case = do c_index <- AT.decimal AT. "index" _ <- AT.char ',' - c_sk <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT. "sk") + c_sk <- fmap decodeLenient (AT.takeWhile (/= ',') AT. "sk") _ <- AT.char ',' c_pk <- AT.takeWhile1 (/= ',') AT. "pk" _ <- AT.char ',' - c_aux <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT. "aux") + c_aux <- fmap decodeLenient (AT.takeWhile (/= ',') AT. "aux") _ <- AT.char ',' - c_msg <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT. "msg") + c_msg <- fmap decodeLenient (AT.takeWhile (/= ',') AT. "msg") _ <- AT.char ',' - c_sig <- fmap B16.decodeLenient (AT.takeWhile1 (/= ',') AT. "sig") + c_sig <- fmap decodeLenient (AT.takeWhile1 (/= ',') AT. "sig") _ <- AT.char ',' c_res <- (AT.string "TRUE" *> pure True) <|> (AT.string "FALSE" *> pure False) AT. "res" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -21,6 +21,11 @@ fi = fromIntegral {-# INLINE fi #-} +decodeLenient :: BS.ByteString -> BS.ByteString +decodeLenient bs = case B16.decode bs of + Nothing -> error "bang" + Just b -> b + main :: IO () main = do wp_ecdsa_sha256 <- TIO.readFile "etc/ecdsa_secp256k1_sha256_test.json" @@ -89,19 +94,19 @@ parse_point_test_p :: TestTree parse_point_test_p = testCase (render p_hex) $ - case parse_point (B16.decodeLenient p_hex) of + case parse_point (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 + case parse_point (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 + case parse_point (decodeLenient r_hex) of Nothing -> assertFailure "bad parse" Just r -> assertEqual mempty r_pro r diff --git a/test/Noble.hs b/test/Noble.hs --- a/test/Noble.hs +++ b/test/Noble.hs @@ -17,10 +17,15 @@ 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 Data.Word.Wider (Wider(..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertEqual, assertBool, assertFailure, testCase) +decodeLenient :: BS.ByteString -> BS.ByteString +decodeLenient bs = case B16.decode bs of + Nothing -> error "bang" + Just b -> b + data Ecdsa = Ecdsa { ec_valid :: ![(Int, ValidTest)] , ec_invalid :: !InvalidTest @@ -63,7 +68,7 @@ execute_invalid_verify :: Context -> (Int, InvalidVerifyTest) -> TestTree execute_invalid_verify tex (label, InvalidVerifyTest {..}) = testCase ("noble-secp256k1, invalid verify (" <> show label <> ")") $ - case parse_point (B16.decodeLenient ivv_Q) of + case parse_point (decodeLenient ivv_Q) of Nothing -> assertBool "no parse" True Just pub -> do let sig = parse_compact ivv_signature @@ -72,22 +77,13 @@ assertBool mempty (not ver) 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 +toBS = 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 +toSecKey :: T.Text -> Wider +toSecKey = unsafe_roll32 . toBS instance A.FromJSON Ecdsa where parseJSON = A.withObject "Ecdsa" $ \m -> Ecdsa @@ -95,7 +91,7 @@ <*> m .: "invalid" data ValidTest = ValidTest { - vt_d :: !Integer + vt_d :: !Wider , vt_m :: !BS.ByteString , vt_signature :: !BS.ByteString } deriving Show @@ -122,7 +118,7 @@ <*> fmap (zip [0..]) (m .: "verify") data InvalidSignTest = InvalidSignTest { - ivs_d :: !Integer + ivs_d :: !Wider , ivs_m :: !BS.ByteString } deriving Show diff --git a/test/Wycheproof.hs b/test/Wycheproof.hs --- a/test/Wycheproof.hs +++ b/test/Wycheproof.hs @@ -17,19 +17,18 @@ 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) +decodeLenient :: BS.ByteString -> BS.ByteString +decodeLenient bs = case B16.decode bs of + Nothing -> error "bang" + Just b -> b + 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 :: Context -> SigType -> EcdsaTestGroup -> TestTree execute_group tex ty EcdsaTestGroup {..} = testGroup msg (fmap (execute tex ty pk_uncompressed) etg_tests) @@ -39,7 +38,7 @@ execute :: Context -> SigType -> Projective -> EcdsaVerifyTest -> TestTree execute tex ty pub EcdsaVerifyTest {..} = testCase report $ do - let msg = B16.decodeLenient (TE.encodeUtf8 t_msg) + let msg = decodeLenient (TE.encodeUtf8 t_msg) sig = toEcdsa t_sig case sig of Left _ -> assertBool mempty (t_result == "invalid") @@ -69,13 +68,18 @@ 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" + let rs = do + r <- roll32 bs_r + s <- roll32 bs_s + pure (r, s) + case rs of + Nothing -> fail "signature components too large" + Just (r, s) -> do + let 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 @@ -136,7 +140,7 @@ } deriving Show toProjective :: T.Text -> Projective -toProjective (B16.decodeLenient . TE.encodeUtf8 -> bs) = case parse_point bs of +toProjective (decodeLenient . TE.encodeUtf8 -> bs) = case parse_point bs of Nothing -> error "wycheproof: couldn't parse pubkey" Just p -> p @@ -148,7 +152,7 @@ <*> fmap toProjective (m .: "uncompressed") toEcdsa :: T.Text -> Either String ECDSA -toEcdsa (B16.decodeLenient . TE.encodeUtf8 -> bs) = +toEcdsa (decodeLenient . TE.encodeUtf8 -> bs) = AT.parseOnly parse_der_sig bs data EcdsaVerifyTest = EcdsaVerifyTest { diff --git a/test/WycheproofEcdh.hs b/test/WycheproofEcdh.hs --- a/test/WycheproofEcdh.hs +++ b/test/WycheproofEcdh.hs @@ -13,14 +13,19 @@ import Data.Aeson ((.:)) import qualified Data.Aeson as A import qualified Data.Attoparsec.ByteString as AT -import Data.Bits ((.<<.), (.>>.), (.|.)) 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 Data.Word.Wider (Wider(..)) import Test.Tasty (TestTree, testGroup) import qualified Test.Tasty.HUnit as H (assertBool, assertEqual, testCase) +decodeLenient :: BS.ByteString -> BS.ByteString +decodeLenient bs = case B16.decode bs of + Nothing -> error "bang" + Just b -> b + fi :: (Integral a, Num b) => a -> b fi = fromIntegral {-# INLINE fi #-} @@ -129,32 +134,13 @@ Just pt -> pure pt der_to_pub :: T.Text -> Either String Projective -der_to_pub (B16.decodeLenient . TE.encodeUtf8 -> bs) = +der_to_pub (decodeLenient . TE.encodeUtf8 -> bs) = AT.parseOnly parse_der_pub bs -parse_bigint :: T.Text -> Integer -parse_bigint (B16.decodeLenient . TE.encodeUtf8 -> bs) = roll bs where - roll :: BS.ByteString -> Integer - roll = BS.foldl' alg 0 where - alg !a (fi -> !b) = (a .<<. 8) .|. b - --- 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 .>>. 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 +parse_bigint :: T.Text -> Wider +parse_bigint (decodeLenient . TE.encodeUtf8 -> bs) = case roll32 bs of + Nothing -> error "couldn't parse_bigint" + Just v -> v data Wycheproof = Wycheproof { wp_testGroups :: ![EcdhTestGroup]