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

Noble.hs (4689B)

      1 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
      2 {-# LANGUAGE BangPatterns #-}
      3 {-# LANGUAGE OverloadedStrings #-}
      4 {-# LANGUAGE RecordWildCards #-}
      5 {-# LANGUAGE ViewPatterns #-}
      6 
      7 module Noble (
      8     Ecdsa(..)
      9   , execute_ecdsa
     10   ) where
     11 
     12 import Control.Exception
     13 import Crypto.Curve.Secp256k1
     14 import Data.Aeson ((.:))
     15 import qualified Data.Aeson as A
     16 import qualified Data.ByteString as BS
     17 import qualified Data.ByteString.Base16 as B16
     18 import qualified Data.Text as T
     19 import qualified Data.Text.Encoding as TE
     20 import qualified GHC.Num.Integer as I
     21 import Test.Tasty (TestTree, testGroup)
     22 import Test.Tasty.HUnit (assertEqual, assertBool, assertFailure, testCase)
     23 
     24 data Ecdsa = Ecdsa {
     25     ec_valid   :: ![(Int, ValidTest)]
     26   , ec_invalid :: !InvalidTest
     27   } deriving Show
     28 
     29 execute_ecdsa :: Context -> Ecdsa -> TestTree
     30 execute_ecdsa tex Ecdsa {..} = testGroup "noble_ecdsa" [
     31       testGroup "valid" (fmap (execute_valid tex) ec_valid)
     32     , testGroup "invalid (sign)" (fmap (execute_invalid_sign tex) iv_sign)
     33     , testGroup "invalid (verify)" (fmap (execute_invalid_verify tex) iv_verify)
     34     ]
     35   where
     36     InvalidTest {..} = ec_invalid
     37 
     38 execute_valid :: Context -> (Int, ValidTest) -> TestTree
     39 execute_valid tex (label, ValidTest {..}) =
     40   testCase ("noble-secp256k1, valid (" <> show label <> ")") $ do
     41     let msg = vt_m
     42         x   = vt_d
     43         pec = parse_compact vt_signature
     44         Just sig = _sign_ecdsa_no_hash x msg
     45         Just sig' = _sign_ecdsa_no_hash' tex x msg
     46     assertEqual mempty sig sig'
     47     assertEqual mempty pec sig
     48 
     49 execute_invalid_sign :: Context -> (Int, InvalidSignTest) -> TestTree
     50 execute_invalid_sign tex (label, InvalidSignTest {..}) =
     51     testCase ("noble-secp256k1, invalid sign (" <> show label <> ")") $ do
     52       let x   = ivs_d
     53           m   = ivs_m
     54       err <- catch (pure (_sign_ecdsa_no_hash x m) >> pure False) handler
     55       err' <- catch (pure (_sign_ecdsa_no_hash' tex x m) >> pure False) handler
     56       if   err || err'
     57       then assertFailure "expected error not caught"
     58       else pure ()
     59   where
     60     handler :: ErrorCall -> IO Bool
     61     handler _ = pure True
     62 
     63 execute_invalid_verify :: Context -> (Int, InvalidVerifyTest) -> TestTree
     64 execute_invalid_verify tex (label, InvalidVerifyTest {..}) =
     65   testCase ("noble-secp256k1, invalid verify (" <> show label <> ")") $
     66     case parse_point (B16.decodeLenient ivv_Q) of
     67       Nothing -> assertBool "no parse" True
     68       Just pub -> do
     69         let sig = parse_compact ivv_signature
     70             ver = verify_ecdsa ivv_m pub sig
     71             ver' = verify_ecdsa' tex ivv_m pub sig
     72         assertBool mempty (not ver)
     73         assertBool mempty (not ver')
     74 
     75 fi :: (Integral a, Num b) => a -> b
     76 fi = fromIntegral
     77 {-# INLINE fi #-}
     78 
     79 -- parser helper
     80 toBS :: T.Text -> BS.ByteString
     81 toBS = B16.decodeLenient . TE.encodeUtf8
     82 
     83 -- parser helper
     84 toSecKey :: T.Text -> Integer
     85 toSecKey = roll . toBS
     86 
     87 -- big-endian bytestring decoding
     88 roll :: BS.ByteString -> Integer
     89 roll = BS.foldl' unstep 0 where
     90   unstep a (fi -> b) = (a `I.integerShiftL` 8) `I.integerOr` b
     91 
     92 instance A.FromJSON Ecdsa where
     93   parseJSON = A.withObject "Ecdsa" $ \m -> Ecdsa
     94     <$> fmap (zip [0..]) (m .: "valid")
     95     <*> m .: "invalid"
     96 
     97 data ValidTest = ValidTest {
     98     vt_d           :: !Integer
     99   , vt_m           :: !BS.ByteString
    100   , vt_signature   :: !BS.ByteString
    101   } deriving Show
    102 
    103 instance A.FromJSON ValidTest where
    104   parseJSON = A.withObject "ValidTest" $ \m -> ValidTest
    105     <$> fmap toSecKey (m .: "d")
    106     <*> fmap toBS (m .: "m")
    107     <*> fmap toBS (m .: "signature")
    108 
    109 parse_compact :: BS.ByteString -> ECDSA
    110 parse_compact bs = case parse_sig bs of
    111   Nothing -> error "bang"
    112   Just s -> s
    113 
    114 data InvalidTest = InvalidTest {
    115     iv_sign   :: ![(Int, InvalidSignTest)]
    116   , iv_verify :: ![(Int, InvalidVerifyTest)]
    117   } deriving Show
    118 
    119 instance A.FromJSON InvalidTest where
    120   parseJSON = A.withObject "InvalidTest" $ \m -> InvalidTest
    121     <$> fmap (zip [0..]) (m .: "sign")
    122     <*> fmap (zip [0..]) (m .: "verify")
    123 
    124 data InvalidSignTest = InvalidSignTest {
    125     ivs_d           :: !Integer
    126   , ivs_m           :: !BS.ByteString
    127   } deriving Show
    128 
    129 instance A.FromJSON InvalidSignTest where
    130   parseJSON = A.withObject "InvalidSignTest" $ \m -> InvalidSignTest
    131     <$> fmap toSecKey (m .: "d")
    132     <*> fmap toBS (m .: "m")
    133 
    134 data InvalidVerifyTest = InvalidVerifyTest {
    135     ivv_Q           :: !BS.ByteString
    136   , ivv_m           :: !BS.ByteString
    137   , ivv_signature   :: !BS.ByteString
    138   } deriving Show
    139 
    140 instance A.FromJSON InvalidVerifyTest where
    141   parseJSON = A.withObject "InvalidVerifyTest" $ \m -> InvalidVerifyTest
    142     <$> fmap TE.encodeUtf8 (m .: "Q")
    143     <*> fmap toBS (m .: "m")
    144     <*> fmap toBS (m .: "signature")
    145