Main.hs (5782B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 {-# LANGUAGE RecordWildCards #-} 4 5 module Main where 6 7 import Crypto.Curve.Secp256k1 8 import qualified Data.Aeson as A 9 import qualified Data.Attoparsec.ByteString as AT 10 import qualified Data.ByteString as BS 11 import qualified Data.ByteString.Base16 as B16 12 import Test.Tasty 13 import Test.Tasty.HUnit 14 import qualified Data.Text.IO as TIO 15 import qualified Noble as N 16 import qualified Wycheproof as W 17 import qualified BIP340 18 19 fi :: (Integral a, Num b) => a -> b 20 fi = fromIntegral 21 {-# INLINE fi #-} 22 23 main :: IO () 24 main = do 25 wp_ecdsa_sha256 <- TIO.readFile "etc/ecdsa_secp256k1_sha256_test.json" 26 wp_ecdsa_sha256_bitcoin <- TIO.readFile 27 "etc/ecdsa_secp256k1_sha256_bitcoin_test.json" 28 noble_ecdsa <- TIO.readFile "etc/noble_ecdsa.json" 29 bip340 <- BS.readFile "etc/bip-0340-test-vectors.csv" 30 let !tex = precompute 31 quar = do 32 wp0 <- A.decodeStrictText wp_ecdsa_sha256 :: Maybe W.Wycheproof 33 wp1 <- A.decodeStrictText wp_ecdsa_sha256_bitcoin :: Maybe W.Wycheproof 34 nob <- A.decodeStrictText noble_ecdsa :: Maybe N.Ecdsa 35 bip <- case AT.parseOnly BIP340.cases bip340 of 36 Left _ -> Nothing 37 Right b -> pure b 38 pure (wp0, wp1, nob, bip) 39 case quar of 40 Nothing -> error "couldn't parse wycheproof vectors" 41 Just (w0, w1, no, ip) -> defaultMain $ testGroup "ppad-secp256k1" [ 42 units 43 , wycheproof_ecdsa_verify_tests tex "(ecdsa, sha256)" Unrestricted w0 44 , wycheproof_ecdsa_verify_tests tex "(ecdsa, sha256, low-s)" LowS w1 45 , N.execute_ecdsa tex no 46 , testGroup "bip0340 vectors (schnorr)" (fmap (BIP340.execute tex) ip) 47 ] 48 49 wycheproof_ecdsa_verify_tests 50 :: Context -> String -> SigType -> W.Wycheproof -> TestTree 51 wycheproof_ecdsa_verify_tests tex msg ty W.Wycheproof {..} = 52 testGroup ("wycheproof vectors " <> msg) $ 53 fmap (W.execute_group tex ty) wp_testGroups 54 55 units :: TestTree 56 units = testGroup "unit tests" [ 57 parse_point_tests 58 , add_tests 59 , dub_tests 60 ] 61 62 parse_point_tests :: TestTree 63 parse_point_tests = testGroup "parse_point tests" [ 64 parse_point_test_p 65 , parse_point_test_q 66 , parse_point_test_r 67 ] 68 69 render :: Show a => a -> String 70 render = filter (`notElem` ("\"" :: String)) . show 71 72 -- XX replace these with something non-stupid 73 parse_point_test_p :: TestTree 74 parse_point_test_p = testCase (render p_hex) $ 75 case parse_point (B16.decodeLenient p_hex) of 76 Nothing -> assertFailure "bad parse" 77 Just p -> assertEqual mempty p_pro p 78 79 parse_point_test_q :: TestTree 80 parse_point_test_q = testCase (render q_hex) $ 81 case parse_point (B16.decodeLenient q_hex) of 82 Nothing -> assertFailure "bad parse" 83 Just q -> assertEqual mempty q_pro q 84 85 parse_point_test_r :: TestTree 86 parse_point_test_r = testCase (render r_hex) $ 87 case parse_point (B16.decodeLenient r_hex) of 88 Nothing -> assertFailure "bad parse" 89 Just r -> assertEqual mempty r_pro r 90 91 -- XX also make less dumb 92 add_tests :: TestTree 93 add_tests = testGroup "ec addition" [ 94 add_test_pq 95 , add_test_pr 96 , add_test_qr 97 ] 98 99 add_test_pq :: TestTree 100 add_test_pq = testCase "p + q" $ 101 assertEqual mempty pq_pro (p_pro `add` q_pro) 102 103 add_test_pr :: TestTree 104 add_test_pr = testCase "p + r" $ 105 assertEqual mempty pr_pro (p_pro `add` r_pro) 106 107 add_test_qr :: TestTree 108 add_test_qr = testCase "q + r" $ 109 assertEqual mempty qr_pro (q_pro `add` r_pro) 110 111 dub_tests :: TestTree 112 dub_tests = testGroup "ec doubling" [ 113 dub_test_p 114 , dub_test_q 115 , dub_test_r 116 ] 117 118 dub_test_p :: TestTree 119 dub_test_p = testCase "2p" $ 120 assertEqual mempty (p_pro `add` p_pro) (double p_pro) 121 122 dub_test_q :: TestTree 123 dub_test_q = testCase "2q" $ 124 assertEqual mempty (q_pro `add` q_pro) (double q_pro) 125 126 dub_test_r :: TestTree 127 dub_test_r = testCase "2r" $ 128 assertEqual mempty (r_pro `add` r_pro) (double r_pro) 129 130 p_hex :: BS.ByteString 131 p_hex = "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" 132 133 p_pro :: Projective 134 p_pro = Projective { 135 px = 55066263022277343669578718895168534326250603453777594175500187360389116729240 136 , py = 32670510020758816978083085130507043184471273380659243275938904335757337482424 137 , pz = 1 138 } 139 140 q_hex :: BS.ByteString 141 q_hex = "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9" 142 143 q_pro :: Projective 144 q_pro = Projective { 145 px = 112711660439710606056748659173929673102114977341539408544630613555209775888121 146 , py = 25583027980570883691656905877401976406448868254816295069919888960541586679410 147 , pz = 1 148 } 149 150 r_hex :: BS.ByteString 151 r_hex = "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8" 152 153 r_pro :: Projective 154 r_pro = Projective { 155 px = 73305138481390301074068425511419969342201196102229546346478796034582161436904 156 , py = 77311080844824646227678701997218206005272179480834599837053144390237051080427 157 , pz = 1 158 } 159 160 pq_pro :: Projective 161 pq_pro = Projective { 162 px = 52396973184413144605737087313078368553350360735730295164507742012595395307648 163 , py = 81222895265056120475581324527268307707868393868711445371362592923687074369515 164 , pz = 57410578768022213246260942140297839801661445014943088692963835122150180187279 165 } 166 167 pr_pro :: Projective 168 pr_pro = Projective { 169 px = 1348700846815225554023000535566992225745844759459188830982575724903956130228 170 , py = 36170035245379023681754688218456726199360176620640420471087552839246039945572 171 , pz = 92262311556350124501370727779827867637071338628440636251794554773617634796873 172 } 173 174 qr_pro :: Projective 175 qr_pro = Projective { 176 px = 98601662106226486891738184090788320295235665172235527697419658886981126285906 177 , py = 18578813777775793862159229516827464252856752093683109113431170463916250542461 178 , pz = 56555634785712334774735413904899958905472439323190450522613637299635410127585 179 } 180