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