Main.hs (6779B)
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 WycheproofEcdh as WE 18 import qualified BIP340 19 20 fi :: (Integral a, Num b) => a -> b 21 fi = fromIntegral 22 {-# INLINE fi #-} 23 24 main :: IO () 25 main = do 26 wp_ecdsa_sha256 <- TIO.readFile "etc/ecdsa_secp256k1_sha256_test.json" 27 wp_ecdsa_sha256_bitcoin <- TIO.readFile 28 "etc/ecdsa_secp256k1_sha256_bitcoin_test.json" 29 wp_ecdh <- TIO.readFile 30 "etc/ecdh_secp256k1_test.json" 31 noble_ecdsa <- TIO.readFile "etc/noble_ecdsa.json" 32 bip340 <- BS.readFile "etc/bip-0340-test-vectors.csv" 33 let !tex = precompute 34 pen = do 35 wp0 <- A.decodeStrictText wp_ecdsa_sha256 :: Maybe W.Wycheproof 36 wp1 <- A.decodeStrictText wp_ecdsa_sha256_bitcoin :: Maybe W.Wycheproof 37 wp2 <- A.decodeStrictText wp_ecdh :: Maybe WE.Wycheproof 38 nob <- A.decodeStrictText noble_ecdsa :: Maybe N.Ecdsa 39 bip <- case AT.parseOnly BIP340.cases bip340 of 40 Left _ -> Nothing 41 Right b -> pure b 42 pure (wp0, wp1, wp2, nob, bip) 43 case pen of 44 Nothing -> error "couldn't parse wycheproof vectors" 45 Just (w0, w1, w2, no, ip) -> defaultMain $ testGroup "ppad-secp256k1" [ 46 units 47 , wycheproof_ecdsa_verify_tests tex "(ecdsa, sha256)" Unrestricted w0 48 , wycheproof_ecdsa_verify_tests tex "(ecdsa, sha256, low-s)" LowS w1 49 , wycheproof_ecdh_tests "(ecdh)" w2 50 , N.execute_ecdsa tex no 51 , testGroup "bip0340 vectors (schnorr)" (fmap (BIP340.execute tex) ip) 52 ] 53 54 wycheproof_ecdsa_verify_tests 55 :: Context -> String -> SigType -> W.Wycheproof -> TestTree 56 wycheproof_ecdsa_verify_tests tex msg ty W.Wycheproof {..} = 57 testGroup ("wycheproof vectors " <> msg) $ 58 fmap (W.execute_group tex ty) wp_testGroups 59 60 wycheproof_ecdh_tests :: String -> WE.Wycheproof -> TestTree 61 wycheproof_ecdh_tests msg WE.Wycheproof {..} = 62 testGroup ("wycheproof vectors " <> msg) $ 63 fmap (WE.execute_group) wp_testGroups 64 65 units :: TestTree 66 units = testGroup "unit tests" [ 67 parse_point_tests 68 , serialize_point_tests 69 , add_tests 70 , dub_tests 71 ] 72 73 parse_point_tests :: TestTree 74 parse_point_tests = testGroup "parse_point tests" [ 75 parse_point_test_p 76 , parse_point_test_q 77 , parse_point_test_r 78 ] 79 80 serialize_point_tests :: TestTree 81 serialize_point_tests = testGroup "serialize_point tests" [ 82 serialize_point_test_p 83 , serialize_point_test_q 84 , serialize_point_test_r 85 ] 86 87 render :: Show a => a -> String 88 render = filter (`notElem` ("\"" :: String)) . show 89 90 parse_point_test_p :: TestTree 91 parse_point_test_p = testCase (render p_hex) $ 92 case parse_point (B16.decodeLenient p_hex) of 93 Nothing -> assertFailure "bad parse" 94 Just p -> assertEqual mempty p_pro p 95 96 parse_point_test_q :: TestTree 97 parse_point_test_q = testCase (render q_hex) $ 98 case parse_point (B16.decodeLenient q_hex) of 99 Nothing -> assertFailure "bad parse" 100 Just q -> assertEqual mempty q_pro q 101 102 parse_point_test_r :: TestTree 103 parse_point_test_r = testCase (render r_hex) $ 104 case parse_point (B16.decodeLenient r_hex) of 105 Nothing -> assertFailure "bad parse" 106 Just r -> assertEqual mempty r_pro r 107 108 serialize_point_test_p :: TestTree 109 serialize_point_test_p = testCase (render p_hex) $ 110 assertEqual mempty p_hex (B16.encode (serialize_point p_pro)) 111 112 serialize_point_test_q :: TestTree 113 serialize_point_test_q = testCase (render q_hex) $ 114 assertEqual mempty q_hex (B16.encode (serialize_point q_pro)) 115 116 serialize_point_test_r :: TestTree 117 serialize_point_test_r = testCase (render r_hex) $ 118 assertEqual mempty r_hex (B16.encode (serialize_point r_pro)) 119 120 add_tests :: TestTree 121 add_tests = testGroup "ec addition" [ 122 add_test_pq 123 , add_test_pr 124 , add_test_qr 125 ] 126 127 add_test_pq :: TestTree 128 add_test_pq = testCase "p + q" $ 129 assertEqual mempty pq_pro (p_pro `add` q_pro) 130 131 add_test_pr :: TestTree 132 add_test_pr = testCase "p + r" $ 133 assertEqual mempty pr_pro (p_pro `add` r_pro) 134 135 add_test_qr :: TestTree 136 add_test_qr = testCase "q + r" $ 137 assertEqual mempty qr_pro (q_pro `add` r_pro) 138 139 dub_tests :: TestTree 140 dub_tests = testGroup "ec doubling" [ 141 dub_test_p 142 , dub_test_q 143 , dub_test_r 144 ] 145 146 dub_test_p :: TestTree 147 dub_test_p = testCase "2p" $ 148 assertEqual mempty (p_pro `add` p_pro) (double p_pro) 149 150 dub_test_q :: TestTree 151 dub_test_q = testCase "2q" $ 152 assertEqual mempty (q_pro `add` q_pro) (double q_pro) 153 154 dub_test_r :: TestTree 155 dub_test_r = testCase "2r" $ 156 assertEqual mempty (r_pro `add` r_pro) (double r_pro) 157 158 p_hex :: BS.ByteString 159 p_hex = "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" 160 161 p_pro :: Projective 162 p_pro = Projective { 163 px = 55066263022277343669578718895168534326250603453777594175500187360389116729240 164 , py = 32670510020758816978083085130507043184471273380659243275938904335757337482424 165 , pz = 1 166 } 167 168 q_hex :: BS.ByteString 169 q_hex = "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9" 170 171 q_pro :: Projective 172 q_pro = Projective { 173 px = 112711660439710606056748659173929673102114977341539408544630613555209775888121 174 , py = 25583027980570883691656905877401976406448868254816295069919888960541586679410 175 , pz = 1 176 } 177 178 r_hex :: BS.ByteString 179 r_hex = "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8" 180 181 r_pro :: Projective 182 r_pro = Projective { 183 px = 73305138481390301074068425511419969342201196102229546346478796034582161436904 184 , py = 77311080844824646227678701997218206005272179480834599837053144390237051080427 185 , pz = 1 186 } 187 188 pq_pro :: Projective 189 pq_pro = Projective { 190 px = 52396973184413144605737087313078368553350360735730295164507742012595395307648 191 , py = 81222895265056120475581324527268307707868393868711445371362592923687074369515 192 , pz = 57410578768022213246260942140297839801661445014943088692963835122150180187279 193 } 194 195 pr_pro :: Projective 196 pr_pro = Projective { 197 px = 1348700846815225554023000535566992225745844759459188830982575724903956130228 198 , py = 36170035245379023681754688218456726199360176620640420471087552839246039945572 199 , pz = 92262311556350124501370727779827867637071338628440636251794554773617634796873 200 } 201 202 qr_pro :: Projective 203 qr_pro = Projective { 204 px = 98601662106226486891738184090788320295235665172235527697419658886981126285906 205 , py = 18578813777775793862159229516827464252856752093683109113431170463916250542461 206 , pz = 56555634785712334774735413904899958905472439323190450522613637299635410127585 207 } 208