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

BIP340.hs (3107B)

      1 {-# LANGUAGE OverloadedStrings #-}
      2 {-# LANGUAGE RecordWildCards #-}
      3 {-# LANGUAGE ViewPatterns #-}
      4 
      5 module BIP340 (
      6     cases
      7   , execute
      8   ) where
      9 
     10 import Control.Applicative
     11 import Crypto.Curve.Secp256k1
     12 import qualified Data.Attoparsec.ByteString.Char8 as AT
     13 import qualified Data.ByteString as BS
     14 import qualified Data.ByteString.Base16 as B16
     15 import qualified GHC.Num.Integer as I
     16 import Test.Tasty
     17 import Test.Tasty.HUnit
     18 
     19 -- XX make a test prelude instead of copying/pasting these things everywhere
     20 
     21 fi :: (Integral a, Num b) => a -> b
     22 fi = fromIntegral
     23 {-# INLINE fi #-}
     24 
     25 roll :: BS.ByteString -> Integer
     26 roll = BS.foldl' unstep 0 where
     27   unstep a (fi -> b) = (a `I.integerShiftL` 8) `I.integerOr` b
     28 
     29 data Case = Case {
     30     c_index   :: !Int
     31   , c_sk      :: !BS.ByteString
     32   , c_pk      :: !BS.ByteString
     33   , c_aux     :: !BS.ByteString
     34   , c_msg     :: !BS.ByteString
     35   , c_sig     :: !BS.ByteString
     36   , c_res     :: !Bool
     37   , c_comment :: !BS.ByteString
     38   } deriving Show
     39 
     40 execute :: Context -> Case -> TestTree
     41 execute tex Case {..} = testCase ("bip0340 " <> show c_index) $
     42   case parse_point (B16.decodeLenient c_pk) of
     43     Nothing -> assertBool mempty (not c_res)
     44     Just pk -> do
     45       if   c_sk == mempty
     46       then do -- no signature; test verification
     47         let ver  = verify_schnorr c_msg pk c_sig
     48             ver' = verify_schnorr' tex c_msg pk c_sig
     49         if   c_res
     50         then do
     51           assertBool mempty ver
     52           assertBool mempty ver'
     53         else do
     54           assertBool mempty (not ver)
     55           assertBool mempty (not ver')
     56       -- XX test pubkey derivation from sk
     57       else do -- signature present; test sig too
     58         let sk = roll c_sk
     59             sig  = sign_schnorr sk c_msg c_aux
     60             sig' = sign_schnorr' tex sk c_msg c_aux
     61             ver  = verify_schnorr c_msg pk sig
     62             ver' = verify_schnorr' tex c_msg pk sig
     63         assertEqual mempty c_sig sig
     64         assertEqual mempty c_sig sig'
     65         if   c_res
     66         then do
     67           assertBool mempty ver
     68           assertBool mempty ver'
     69         else do
     70           assertBool mempty (not ver)
     71           assertBool mempty (not ver')
     72 
     73 header :: AT.Parser ()
     74 header = do
     75   _ <- AT.string "index,secret key,public key,aux_rand,message,signature,verification result,comment"
     76   AT.endOfLine
     77 
     78 test_case :: AT.Parser Case
     79 test_case = do
     80   c_index <- AT.decimal AT.<?> "index"
     81   _ <- AT.char ','
     82   c_sk <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT.<?> "sk")
     83   _ <- AT.char ','
     84   c_pk <- AT.takeWhile1 (/= ',') AT.<?> "pk"
     85   _ <- AT.char ','
     86   c_aux <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT.<?> "aux")
     87   _ <- AT.char ','
     88   c_msg <- fmap B16.decodeLenient (AT.takeWhile (/= ',') AT.<?> "msg")
     89   _ <- AT.char ','
     90   c_sig <- fmap B16.decodeLenient (AT.takeWhile1 (/= ',') AT.<?> "sig")
     91   _ <- AT.char ','
     92   c_res <- (AT.string "TRUE" *> pure True) <|> (AT.string "FALSE" *> pure False)
     93             AT.<?> "res"
     94   _ <- AT.char ','
     95   c_comment <- AT.takeWhile (/= '\n') AT.<?> "comment"
     96   AT.endOfLine
     97   pure Case {..}
     98 
     99 cases :: AT.Parser [Case]
    100 cases = header *> AT.many1 test_case
    101