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 (4811B)


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