Main.hs (6369B)
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 , serialize_point_tests 59 , add_tests 60 , dub_tests 61 ] 62 63 parse_point_tests :: TestTree 64 parse_point_tests = testGroup "parse_point tests" [ 65 parse_point_test_p 66 , parse_point_test_q 67 , parse_point_test_r 68 ] 69 70 serialize_point_tests :: TestTree 71 serialize_point_tests = testGroup "serialize_point tests" [ 72 serialize_point_test_p 73 , serialize_point_test_q 74 , serialize_point_test_r 75 ] 76 77 render :: Show a => a -> String 78 render = filter (`notElem` ("\"" :: String)) . show 79 80 parse_point_test_p :: TestTree 81 parse_point_test_p = testCase (render p_hex) $ 82 case parse_point (B16.decodeLenient p_hex) of 83 Nothing -> assertFailure "bad parse" 84 Just p -> assertEqual mempty p_pro p 85 86 parse_point_test_q :: TestTree 87 parse_point_test_q = testCase (render q_hex) $ 88 case parse_point (B16.decodeLenient q_hex) of 89 Nothing -> assertFailure "bad parse" 90 Just q -> assertEqual mempty q_pro q 91 92 parse_point_test_r :: TestTree 93 parse_point_test_r = testCase (render r_hex) $ 94 case parse_point (B16.decodeLenient r_hex) of 95 Nothing -> assertFailure "bad parse" 96 Just r -> assertEqual mempty r_pro r 97 98 serialize_point_test_p :: TestTree 99 serialize_point_test_p = testCase (render p_hex) $ 100 assertEqual mempty p_hex (B16.encode (serialize_point p_pro)) 101 102 serialize_point_test_q :: TestTree 103 serialize_point_test_q = testCase (render q_hex) $ 104 assertEqual mempty q_hex (B16.encode (serialize_point q_pro)) 105 106 serialize_point_test_r :: TestTree 107 serialize_point_test_r = testCase (render r_hex) $ 108 assertEqual mempty r_hex (B16.encode (serialize_point r_pro)) 109 110 add_tests :: TestTree 111 add_tests = testGroup "ec addition" [ 112 add_test_pq 113 , add_test_pr 114 , add_test_qr 115 ] 116 117 add_test_pq :: TestTree 118 add_test_pq = testCase "p + q" $ 119 assertEqual mempty pq_pro (p_pro `add` q_pro) 120 121 add_test_pr :: TestTree 122 add_test_pr = testCase "p + r" $ 123 assertEqual mempty pr_pro (p_pro `add` r_pro) 124 125 add_test_qr :: TestTree 126 add_test_qr = testCase "q + r" $ 127 assertEqual mempty qr_pro (q_pro `add` r_pro) 128 129 dub_tests :: TestTree 130 dub_tests = testGroup "ec doubling" [ 131 dub_test_p 132 , dub_test_q 133 , dub_test_r 134 ] 135 136 dub_test_p :: TestTree 137 dub_test_p = testCase "2p" $ 138 assertEqual mempty (p_pro `add` p_pro) (double p_pro) 139 140 dub_test_q :: TestTree 141 dub_test_q = testCase "2q" $ 142 assertEqual mempty (q_pro `add` q_pro) (double q_pro) 143 144 dub_test_r :: TestTree 145 dub_test_r = testCase "2r" $ 146 assertEqual mempty (r_pro `add` r_pro) (double r_pro) 147 148 p_hex :: BS.ByteString 149 p_hex = "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" 150 151 p_pro :: Projective 152 p_pro = Projective { 153 px = 55066263022277343669578718895168534326250603453777594175500187360389116729240 154 , py = 32670510020758816978083085130507043184471273380659243275938904335757337482424 155 , pz = 1 156 } 157 158 q_hex :: BS.ByteString 159 q_hex = "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9" 160 161 q_pro :: Projective 162 q_pro = Projective { 163 px = 112711660439710606056748659173929673102114977341539408544630613555209775888121 164 , py = 25583027980570883691656905877401976406448868254816295069919888960541586679410 165 , pz = 1 166 } 167 168 r_hex :: BS.ByteString 169 r_hex = "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8" 170 171 r_pro :: Projective 172 r_pro = Projective { 173 px = 73305138481390301074068425511419969342201196102229546346478796034582161436904 174 , py = 77311080844824646227678701997218206005272179480834599837053144390237051080427 175 , pz = 1 176 } 177 178 pq_pro :: Projective 179 pq_pro = Projective { 180 px = 52396973184413144605737087313078368553350360735730295164507742012595395307648 181 , py = 81222895265056120475581324527268307707868393868711445371362592923687074369515 182 , pz = 57410578768022213246260942140297839801661445014943088692963835122150180187279 183 } 184 185 pr_pro :: Projective 186 pr_pro = Projective { 187 px = 1348700846815225554023000535566992225745844759459188830982575724903956130228 188 , py = 36170035245379023681754688218456726199360176620640420471087552839246039945572 189 , pz = 92262311556350124501370727779827867637071338628440636251794554773617634796873 190 } 191 192 qr_pro :: Projective 193 qr_pro = Projective { 194 px = 98601662106226486891738184090788320295235665172235527697419658886981126285906 195 , py = 18578813777775793862159229516827464252856752093683109113431170463916250542461 196 , pz = 56555634785712334774735413904899958905472439323190450522613637299635410127585 197 } 198