Main.hs (10710B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 {-# LANGUAGE RecordWildCards #-} 4 5 module Main where 6 7 import Crypto.Curve.Secp256k1 8 import qualified Crypto.Hash.SHA256 as SHA256 9 import qualified Data.Aeson as A 10 import qualified Data.Attoparsec.ByteString as AT 11 import qualified Data.ByteString as BS 12 import qualified Data.ByteString.Base16 as B16 13 import qualified Data.Maybe as M 14 import qualified Numeric.Montgomery.Secp256k1.Scalar as S 15 import Test.Tasty 16 import Test.Tasty.HUnit 17 import qualified Data.Text.IO as TIO 18 import qualified Noble as N 19 import qualified Wycheproof as W 20 import qualified WycheproofEcdh as WE 21 import qualified BIP340 22 23 fi :: (Integral a, Num b) => a -> b 24 fi = fromIntegral 25 {-# INLINE fi #-} 26 27 decodeLenient :: BS.ByteString -> BS.ByteString 28 decodeLenient bs = case B16.decode bs of 29 Nothing -> error "bang" 30 Just b -> b 31 32 main :: IO () 33 main = do 34 wp_ecdsa_sha256 <- TIO.readFile "etc/ecdsa_secp256k1_sha256_test.json" 35 wp_ecdsa_sha256_bitcoin <- TIO.readFile 36 "etc/ecdsa_secp256k1_sha256_bitcoin_test.json" 37 wp_ecdh <- TIO.readFile 38 "etc/ecdh_secp256k1_test.json" 39 noble_ecdsa <- TIO.readFile "etc/noble_ecdsa.json" 40 bip340 <- BS.readFile "etc/bip-0340-test-vectors.csv" 41 let !tex = precompute 42 pen = do 43 wp0 <- A.decodeStrictText wp_ecdsa_sha256 :: Maybe W.Wycheproof 44 wp1 <- A.decodeStrictText wp_ecdsa_sha256_bitcoin :: Maybe W.Wycheproof 45 wp2 <- A.decodeStrictText wp_ecdh :: Maybe WE.Wycheproof 46 nob <- A.decodeStrictText noble_ecdsa :: Maybe N.Ecdsa 47 bip <- case AT.parseOnly BIP340.cases bip340 of 48 Left _ -> Nothing 49 Right b -> pure b 50 pure (wp0, wp1, wp2, nob, bip) 51 case pen of 52 Nothing -> error "couldn't parse wycheproof vectors" 53 Just (w0, w1, w2, no, ip) -> defaultMain $ testGroup "ppad-secp256k1" [ 54 units tex 55 , wycheproof_ecdsa_verify_tests tex "(ecdsa, sha256)" Unrestricted w0 56 , wycheproof_ecdsa_verify_tests tex "(ecdsa, sha256, low-s)" LowS w1 57 , wycheproof_ecdh_tests "(ecdh)" w2 58 , N.execute_ecdsa tex no 59 , testGroup "bip0340 vectors (schnorr)" (fmap (BIP340.execute tex) ip) 60 ] 61 62 wycheproof_ecdsa_verify_tests 63 :: Context -> String -> SigType -> W.Wycheproof -> TestTree 64 wycheproof_ecdsa_verify_tests tex msg ty W.Wycheproof {..} = 65 testGroup ("wycheproof vectors " <> msg) $ 66 fmap (W.execute_group tex ty) wp_testGroups 67 68 wycheproof_ecdh_tests :: String -> WE.Wycheproof -> TestTree 69 wycheproof_ecdh_tests msg WE.Wycheproof {..} = 70 testGroup ("wycheproof vectors " <> msg) $ 71 fmap (WE.execute_group) wp_testGroups 72 73 units :: Context -> TestTree 74 units tex = testGroup "unit tests" [ 75 parse_point_tests 76 , serialize_point_tests 77 , add_tests 78 , dub_tests 79 , identity_pubkey_tests tex 80 ] 81 82 -- A public key at infinity annihilates the term carrying the challenge 83 -- (schnorr) or the key (ecdsa), leaving a verification equation an 84 -- attacker can satisfy for any message. 85 identity_pubkey_tests :: Context -> TestTree 86 identity_pubkey_tests tex = testGroup "identity public key" [ 87 schnorr_identity_test tex 88 , ecdsa_identity_test tex 89 ] 90 91 forgery_msg :: BS.ByteString 92 forgery_msg = "arbitrary attacker-chosen message" 93 94 -- The recovered point is s * G - e * O = s * G for every challenge e, 95 -- so (x(s * G), s) satisfies the equation whenever s * G has even y. 96 schnorr_forgery :: Maybe (Projective, BS.ByteString) 97 schnorr_forgery = do 98 let sec_bytes = decodeLenient 99 "b7e151628aed2a6abf7158809cf4f3c762e7160f38b4da56a784d9045190cfef" 100 sec <- parse_int256 sec_bytes 101 pub <- derive_pub sec 102 pure (pub, BS.drop 1 (serialize_point pub) <> sec_bytes) 103 104 schnorr_identity_test :: Context -> TestTree 105 schnorr_identity_test tex = 106 testCase "schnorr verification rejects the identity" $ 107 case schnorr_forgery of 108 Nothing -> assertFailure "couldn't construct forgery" 109 Just (pub, sig) -> do 110 assertEqual "forgery is well-formed (even y)" 111 "\002" (BS.take 1 (serialize_point pub)) 112 assertBool mempty (not (verify_schnorr forgery_msg _CURVE_ZERO sig)) 113 assertBool mempty 114 (not (verify_schnorr' tex forgery_msg _CURVE_ZERO sig)) 115 116 -- Verification reduces to x(u1 * G) == r for u1 = e / s, so choosing 117 -- u1 freely and setting s = e / u1 satisfies it for any message. 118 ecdsa_forgery :: Maybe ECDSA 119 ecdsa_forgery = do 120 e <- parse_int256 (SHA256.hash forgery_msg) 121 u1 <- parse_int256 (BS.replicate 32 0x22) 122 cap <- derive_pub u1 123 r <- parse_int256 (BS.drop 1 (serialize_point cap)) 124 pure (ECDSA r (S.retr (S.to e * S.inv (S.to u1)))) 125 126 ecdsa_identity_test :: Context -> TestTree 127 ecdsa_identity_test tex = 128 testCase "ecdsa verification rejects the identity" $ 129 case ecdsa_forgery of 130 Nothing -> assertFailure "couldn't construct forgery" 131 Just sig@(ECDSA r s) -> do 132 assertBool "forgery is well-formed (r in range)" (ge r) 133 assertBool "forgery is well-formed (s in range)" (ge s) 134 assertBool mempty 135 (not (verify_ecdsa_unrestricted forgery_msg _CURVE_ZERO sig)) 136 assertBool mempty 137 (not (verify_ecdsa_unrestricted' tex forgery_msg _CURVE_ZERO sig)) 138 139 parse_point_tests :: TestTree 140 parse_point_tests = testGroup "parse_point tests" [ 141 parse_point_test_p 142 , parse_point_test_q 143 , parse_point_test_r 144 , noncanonical_tests 145 ] 146 147 -- The field prime is within 2 ^ 32 of 2 ^ 256, so a coordinate in 148 -- [p, 2 ^ 256) reduces to a small one, giving a second encoding of a 149 -- point with a small x. x = 1 is such a point. 150 noncanonical_tests :: TestTree 151 noncanonical_tests = testGroup "non-canonical coordinates" [ 152 testCase "32-byte x-only, x = 1" $ 153 assertBool mempty (M.isJust (parse_point (decodeLenient x1_hex))) 154 , testCase "32-byte x-only, x = p + 1" $ 155 assertEqual mempty Nothing 156 (fmap serialize_point (parse_point (decodeLenient p1_hex))) 157 , testCase "65-byte uncompressed, x = 1" $ 158 assertBool mempty 159 (M.isJust (parse_point (decodeLenient ("04" <> x1_hex <> y1_hex)))) 160 , testCase "65-byte uncompressed, x = p + 1" $ 161 assertEqual mempty Nothing 162 (fmap serialize_point 163 (parse_point (decodeLenient ("04" <> p1_hex <> y1_hex)))) 164 ] 165 166 -- x-coordinate of a curve point, and the field prime plus that 167 -- coordinate, which must not parse 168 x1_hex, p1_hex, y1_hex :: BS.ByteString 169 x1_hex = "0000000000000000000000000000000000000000000000000000000000000001" 170 p1_hex = "fffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc30" 171 y1_hex = "4218f20ae6c646b363db68605822fb14264ca8d2587fdd6fbc750d587e76a7ee" 172 173 serialize_point_tests :: TestTree 174 serialize_point_tests = testGroup "serialize_point tests" [ 175 serialize_point_test_p 176 , serialize_point_test_q 177 , serialize_point_test_r 178 ] 179 180 render :: Show a => a -> String 181 render = filter (`notElem` ("\"" :: String)) . show 182 183 parse_point_test_p :: TestTree 184 parse_point_test_p = testCase (render p_hex) $ 185 case parse_point (decodeLenient p_hex) of 186 Nothing -> assertFailure "bad parse" 187 Just p -> assertEqual mempty p_pro p 188 189 parse_point_test_q :: TestTree 190 parse_point_test_q = testCase (render q_hex) $ 191 case parse_point (decodeLenient q_hex) of 192 Nothing -> assertFailure "bad parse" 193 Just q -> assertEqual mempty q_pro q 194 195 parse_point_test_r :: TestTree 196 parse_point_test_r = testCase (render r_hex) $ 197 case parse_point (decodeLenient r_hex) of 198 Nothing -> assertFailure "bad parse" 199 Just r -> assertEqual mempty r_pro r 200 201 serialize_point_test_p :: TestTree 202 serialize_point_test_p = testCase (render p_hex) $ 203 assertEqual mempty p_hex (B16.encode (serialize_point p_pro)) 204 205 serialize_point_test_q :: TestTree 206 serialize_point_test_q = testCase (render q_hex) $ 207 assertEqual mempty q_hex (B16.encode (serialize_point q_pro)) 208 209 serialize_point_test_r :: TestTree 210 serialize_point_test_r = testCase (render r_hex) $ 211 assertEqual mempty r_hex (B16.encode (serialize_point r_pro)) 212 213 add_tests :: TestTree 214 add_tests = testGroup "ec addition" [ 215 add_test_pq 216 , add_test_pr 217 , add_test_qr 218 ] 219 220 add_test_pq :: TestTree 221 add_test_pq = testCase "p + q" $ 222 assertEqual mempty pq_pro (p_pro `add` q_pro) 223 224 add_test_pr :: TestTree 225 add_test_pr = testCase "p + r" $ 226 assertEqual mempty pr_pro (p_pro `add` r_pro) 227 228 add_test_qr :: TestTree 229 add_test_qr = testCase "q + r" $ 230 assertEqual mempty qr_pro (q_pro `add` r_pro) 231 232 dub_tests :: TestTree 233 dub_tests = testGroup "ec doubling" [ 234 dub_test_p 235 , dub_test_q 236 , dub_test_r 237 ] 238 239 dub_test_p :: TestTree 240 dub_test_p = testCase "2p" $ 241 assertEqual mempty (p_pro `add` p_pro) (double p_pro) 242 243 dub_test_q :: TestTree 244 dub_test_q = testCase "2q" $ 245 assertEqual mempty (q_pro `add` q_pro) (double q_pro) 246 247 dub_test_r :: TestTree 248 dub_test_r = testCase "2r" $ 249 assertEqual mempty (r_pro `add` r_pro) (double r_pro) 250 251 p_hex :: BS.ByteString 252 p_hex = "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" 253 254 p_pro :: Projective 255 p_pro = Projective { 256 px = 55066263022277343669578718895168534326250603453777594175500187360389116729240 257 , py = 32670510020758816978083085130507043184471273380659243275938904335757337482424 258 , pz = 1 259 } 260 261 q_hex :: BS.ByteString 262 q_hex = "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9" 263 264 q_pro :: Projective 265 q_pro = Projective { 266 px = 112711660439710606056748659173929673102114977341539408544630613555209775888121 267 , py = 25583027980570883691656905877401976406448868254816295069919888960541586679410 268 , pz = 1 269 } 270 271 r_hex :: BS.ByteString 272 r_hex = "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8" 273 274 r_pro :: Projective 275 r_pro = Projective { 276 px = 73305138481390301074068425511419969342201196102229546346478796034582161436904 277 , py = 77311080844824646227678701997218206005272179480834599837053144390237051080427 278 , pz = 1 279 } 280 281 pq_pro :: Projective 282 pq_pro = Projective { 283 px = 52396973184413144605737087313078368553350360735730295164507742012595395307648 284 , py = 81222895265056120475581324527268307707868393868711445371362592923687074369515 285 , pz = 57410578768022213246260942140297839801661445014943088692963835122150180187279 286 } 287 288 pr_pro :: Projective 289 pr_pro = Projective { 290 px = 1348700846815225554023000535566992225745844759459188830982575724903956130228 291 , py = 36170035245379023681754688218456726199360176620640420471087552839246039945572 292 , pz = 92262311556350124501370727779827867637071338628440636251794554773617634796873 293 } 294 295 qr_pro :: Projective 296 qr_pro = Projective { 297 px = 98601662106226486891738184090788320295235665172235527697419658886981126285906 298 , py = 18578813777775793862159229516827464252856752093683109113431170463916250542461 299 , pz = 56555634785712334774735413904899958905472439323190450522613637299635410127585 300 } 301