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