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

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