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