secp256k1

Pure Haskell Schnorr, ECDSA on the elliptic curve secp256k1 (docs.ppad.tech/secp256k1).
git clone git://git.ppad.tech/secp256k1.git
Log | Files | Refs | README | LICENSE

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