Noble.hs (4859B)
1 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-} 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 Crypto.Curve.Secp256k1 13 import Data.Aeson ((.:)) 14 import qualified Data.Aeson as A 15 import qualified Data.ByteString as BS 16 import qualified Data.ByteString.Base16 as B16 17 import qualified Data.Text as T 18 import qualified Data.Text.Encoding as TE 19 import Data.Word.Wider (Wider(..)) 20 import qualified Data.Word.Wider as Wider 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 instance Eq ECDSA where 30 ECDSA r0 s0 == ECDSA r1 s1 = Wider.eq_vartime r0 r1 && Wider.eq_vartime s0 s1 31 32 data Ecdsa = Ecdsa { 33 ec_valid :: ![(Int, ValidTest)] 34 , ec_invalid :: !InvalidTest 35 } deriving Show 36 37 execute_ecdsa :: Context -> Ecdsa -> TestTree 38 execute_ecdsa tex Ecdsa {..} = testGroup "noble_ecdsa" [ 39 testGroup "valid" (fmap (execute_valid tex) ec_valid) 40 , testGroup "invalid (sign)" (fmap (execute_invalid_sign tex) iv_sign) 41 , testGroup "invalid (verify)" (fmap (execute_invalid_verify tex) iv_verify) 42 ] 43 where 44 InvalidTest {..} = ec_invalid 45 46 execute_valid :: Context -> (Int, ValidTest) -> TestTree 47 execute_valid tex (label, ValidTest {..}) = 48 testCase ("noble-secp256k1, valid (" <> show label <> ")") $ do 49 let msg = vt_m 50 x = vt_d 51 pec = parse_compact vt_signature 52 Just sig = _sign_ecdsa_no_hash x msg 53 Just sig' = _sign_ecdsa_no_hash' tex x msg 54 Just pub = derive_pub x 55 assertEqual mempty sig sig' 56 assertEqual mempty pec sig 57 assertBool mempty (_verify_ecdsa_no_hash msg pub sig) 58 assertBool mempty (_verify_ecdsa_no_hash' tex msg pub sig) 59 60 execute_invalid_sign :: Context -> (Int, InvalidSignTest) -> TestTree 61 execute_invalid_sign tex (label, InvalidSignTest {..}) = 62 testCase ("noble-secp256k1, invalid sign (" <> show label <> ")") $ do 63 expect_nothing (_sign_ecdsa_no_hash ivs_d ivs_m) 64 expect_nothing (_sign_ecdsa_no_hash' tex ivs_d ivs_m) 65 where 66 expect_nothing :: Maybe ECDSA -> IO () 67 expect_nothing Nothing = pure () 68 expect_nothing (Just _) = 69 assertFailure "signed with an out-of-range secret key" 70 71 execute_invalid_verify :: Context -> (Int, InvalidVerifyTest) -> TestTree 72 execute_invalid_verify tex (label, InvalidVerifyTest {..}) = 73 testCase ("noble-secp256k1, invalid verify (" <> show label <> ")") $ 74 -- every vector in this group must be rejected, whether by the 75 -- point parser or by verification itself 76 assertBool mempty (not accepted) 77 where 78 accepted = case parse_point (decodeLenient ivv_Q) of 79 Nothing -> False 80 Just pub -> 81 let sig = parse_compact ivv_signature 82 in verify_ecdsa ivv_m pub sig || verify_ecdsa' tex ivv_m pub sig 83 84 -- parser helper 85 toBS :: T.Text -> BS.ByteString 86 toBS = decodeLenient . TE.encodeUtf8 87 88 -- parser helper 89 toSecKey :: T.Text -> Wider 90 toSecKey = unsafe_roll32 . toBS 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 :: !Wider 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 :: !Wider 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