Secp256k1.hs (24550B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DeriveGeneric #-} 4 {-# LANGUAGE DerivingStrategies #-} 5 {-# LANGUAGE MagicHash #-} 6 {-# LANGUAGE OverloadedStrings #-} 7 {-# LANGUAGE UnboxedSums #-} 8 {-# LANGUAGE ViewPatterns #-} 9 10 -- | 11 -- Module: Crypto.Curve.Secp256k1 12 -- Copyright: (c) 2024 Jared Tobin 13 -- License: MIT 14 -- Maintainer: Jared Tobin <jared@ppad.tech> 15 -- 16 -- Pure [BIP0340](https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki) 17 -- Schnorr signatures and deterministic 18 -- [RFC6979](https://www.rfc-editor.org/rfc/rfc6979) ECDSA (with 19 -- [BIP0146](https://github.com/bitcoin/bips/blob/master/bip-0146.mediawiki)-style 20 -- "low-S" signatures) on the elliptic curve secp256k1. 21 22 module Crypto.Curve.Secp256k1 ( 23 -- * BIP0340 Schnorr signatures 24 sign_schnorr 25 , verify_schnorr 26 27 -- * RFC6979 ECDSA 28 , ECDSA(..) 29 , SigType(..) 30 , sign_ecdsa 31 , sign_ecdsa_unrestricted 32 , verify_ecdsa 33 , verify_ecdsa_unrestricted 34 35 -- * Parsing 36 , parse_integer 37 , parse_point 38 39 -- Elliptic curve group operations 40 , neg 41 , add 42 , double 43 , mul 44 45 -- Coordinate systems and transformations 46 , Affine(..) 47 , Projective(..) 48 , Pub 49 , affine 50 , projective 51 , valid 52 53 -- for testing 54 , _sign_ecdsa_no_hash 55 ) where 56 57 import Control.Monad (when) 58 import Control.Monad.ST 59 import qualified Crypto.DRBG.HMAC as DRBG 60 import qualified Crypto.Hash.SHA256 as SHA256 61 import qualified Data.Bits as B 62 import qualified Data.ByteString as BS 63 import qualified Data.ByteString.Base16 as B16 -- XX kill this dep 64 import Data.Int (Int64) 65 import Data.STRef 66 import GHC.Generics 67 import GHC.Natural 68 import qualified GHC.Num.Integer as I 69 70 -- keystroke savers & other utilities ----------------------------------------- 71 72 fi :: (Integral a, Num b) => a -> b 73 fi = fromIntegral 74 {-# INLINE fi #-} 75 76 -- generic modular exponentiation 77 -- https://gist.github.com/trevordixon/6788535 78 modexp :: Integer -> Integer -> Integer -> Integer 79 modexp b e m 80 | e == 0 = 1 81 | otherwise = 82 let t = if B.testBit e 0 then b `mod` m else 1 83 in t * modexp ((b * b) `mod` m) (B.shiftR e 1) m `mod` m 84 {-# INLINE modexp #-} 85 86 -- generic modular inverse 87 -- for a, m return x such that ax = 1 mod m 88 modinv :: Integer -> Natural -> Maybe Integer 89 modinv a m = case I.integerRecipMod# a m of 90 (# fi -> n | #) -> Just $! n 91 (# | _ #) -> Nothing 92 {-# INLINE modinv #-} 93 94 -- bytewise xor 95 xor :: BS.ByteString -> BS.ByteString -> BS.ByteString 96 xor = BS.packZipWith B.xor 97 98 -- big-endian bytestring decoding 99 roll :: BS.ByteString -> Integer 100 roll = BS.foldl' alg 0 where 101 alg a (fi -> b) = (a `I.integerShiftL` 8) `I.integerOr` b 102 103 -- big-endian bytestring encoding 104 unroll :: Integer -> BS.ByteString 105 unroll i = case i of 106 0 -> BS.singleton 0 107 _ -> BS.reverse $ BS.unfoldr step i -- XX looks slow 108 where 109 step 0 = Nothing 110 step m = Just (fi m, m `I.integerShiftR` 8) 111 112 -- big-endian bytestring encoding for 256-bit ints, left-padding with 113 -- zeros if necessary. the size of the integer is not checked. 114 unroll32 :: Integer -> BS.ByteString 115 unroll32 (unroll -> u) 116 | l < 32 = BS.replicate (32 - l) 0 <> u 117 | otherwise = u 118 where 119 l = BS.length u 120 121 -- (bip0340) tagged hash function 122 hash_tagged :: BS.ByteString -> BS.ByteString -> BS.ByteString 123 hash_tagged tag x = 124 let !h = SHA256.hash tag 125 in SHA256.hash (h <> h <> x) 126 127 -- (bip0340) return point with x coordinate == x and with even y coordinate 128 lift :: Integer -> Maybe Affine 129 lift x 130 | not (fe x) = Nothing 131 | otherwise = 132 let c = modP (modexp x 3 _CURVE_P + 7) 133 y = modexp c ((_CURVE_P + 1) `div` 4) _CURVE_P 134 y_p 135 | y `rem` 2 == 0 = y 136 | otherwise = _CURVE_P - y 137 in if c /= modexp y 2 _CURVE_P 138 then Nothing 139 else Just $! (Affine x y_p) 140 141 -- coordinate systems & transformations --------------------------------------- 142 143 -- curve point, affine coordinates 144 data Affine = Affine !Integer !Integer 145 deriving stock (Show, Generic) 146 147 instance Eq Affine where 148 Affine x1 y1 == Affine x2 y2 = 149 modP x1 == modP x2 && modP y1 == modP y2 150 151 -- curve point, projective coordinates 152 data Projective = Projective { 153 px :: !Integer 154 , py :: !Integer 155 , pz :: !Integer 156 } 157 deriving stock (Show, Generic) 158 159 instance Eq Projective where 160 Projective ax ay az == Projective bx by bz = 161 let x1z2 = modP (ax * bz) 162 x2z1 = modP (bx * az) 163 y1z2 = modP (ay * bz) 164 y2z1 = modP (by * az) 165 in x1z2 == x2z1 && y1z2 == y2z1 166 167 -- | A Schnorr and ECDSA-flavoured alias for a secp256k1 point. 168 type Pub = Projective 169 170 -- Convert to affine coordinates. 171 affine :: Projective -> Affine 172 affine p@(Projective x y z) 173 | p == _ZERO = Affine 0 0 174 | z == 1 = Affine x y 175 | otherwise = case modinv z (fi _CURVE_P) of 176 Nothing -> error "ppad-secp256k1 (affine): impossible point" 177 Just iz -> Affine (modP (x * iz)) (modP (y * iz)) 178 179 -- Convert to projective coordinates. 180 projective :: Affine -> Projective 181 projective (Affine x y) 182 | x == 0 && y == 0 = _ZERO 183 | otherwise = Projective x y 1 184 185 -- Point is valid 186 valid :: Projective -> Bool 187 valid p = case affine p of 188 Affine x y 189 | not (fe x) || not (fe y) -> False 190 | modP (y * y) /= weierstrass x -> False 191 | otherwise -> True 192 193 -- curve parameters ----------------------------------------------------------- 194 -- see https://www.secg.org/sec2-v2.pdf for parameter specs 195 196 -- secp256k1 field prime 197 -- 198 -- = 2^256 - 2^32 - 2^9 - 2^8 - 2^7 - 2^6 - 2^4 - 1 199 _CURVE_P :: Integer 200 _CURVE_P = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F 201 202 -- secp256k1 group order 203 _CURVE_Q :: Integer 204 _CURVE_Q = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 205 206 -- bitlength of group order 207 -- 208 -- = smallest integer such that _CURVE_Q < 2 ^ _CURVE_Q_BITS 209 _CURVE_Q_BITS :: Int64 210 _CURVE_Q_BITS = 256 211 212 -- bytelength of _CURVE_Q 213 -- 214 -- = _CURVE_Q_BITS / 8 215 _CURVE_Q_BYTES :: Int64 216 _CURVE_Q_BYTES = 32 217 218 -- secp256k1 short weierstrass form, /a/ coefficient 219 _CURVE_A :: Integer 220 _CURVE_A = 0 221 222 -- secp256k1 weierstrass form, /b/ coefficient 223 _CURVE_B :: Integer 224 _CURVE_B = 7 225 226 -- secp256k1 generator 227 -- 228 -- = parse_point 229 -- "0279BE667EF9DCBBAC55A06295CE870B07029BFCDB2DCE28D959F2815B16F81798" 230 _CURVE_G :: Projective 231 _CURVE_G = Projective x y 1 where 232 x = 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 233 y = 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8 234 235 -- secp256k1 zero point 236 _ZERO :: Projective 237 _ZERO = Projective 0 1 0 238 239 -- secp256k1 in prime order j-invariant 0 form (i.e. a == 0). 240 weierstrass :: Integer -> Integer 241 weierstrass x = modP (modP (x * x) * x + _CURVE_B) 242 {-# INLINE weierstrass #-} 243 244 -- field, group operations ---------------------------------------------------- 245 246 -- Division modulo secp256k1 field prime. 247 modP :: Integer -> Integer 248 modP a = I.integerMod a _CURVE_P 249 {-# INLINE modP #-} 250 251 -- Division modulo secp256k1 group order. 252 modQ :: Integer -> Integer 253 modQ a = I.integerMod a _CURVE_Q 254 {-# INLINE modQ #-} 255 256 -- Is field element? 257 fe :: Integer -> Bool 258 fe n = 0 < n && n < _CURVE_P 259 {-# INLINE fe #-} 260 261 -- Is group element? 262 ge :: Integer -> Bool 263 ge n = 0 < n && n < _CURVE_Q 264 {-# INLINE ge #-} 265 266 -- Square root (Shanks-Tonelli) modulo secp256k1 field prime. 267 -- 268 -- For a, return x such that a = x x mod _CURVE_P. 269 modsqrt :: Integer -> Maybe Integer 270 modsqrt n = runST $ do 271 r <- newSTRef 1 272 num <- newSTRef n 273 e <- newSTRef ((_CURVE_P + 1) `div` 4) 274 loop r num e 275 rr <- readSTRef r 276 pure $ 277 if modP (rr * rr) == n 278 then Just $! rr 279 else Nothing 280 where 281 loop sr snum se = do 282 e <- readSTRef se 283 when (e > 0) $ do 284 when (I.integerTestBit e 0) $ do 285 num <- readSTRef snum 286 modifySTRef' sr (\lr -> (lr * num) `rem` _CURVE_P) 287 modifySTRef' snum (\ln -> (ln * ln) `rem` _CURVE_P) 288 modifySTRef' se (`I.integerShiftR` 1) 289 loop sr snum se 290 291 -- ec point operations -------------------------------------------------------- 292 293 -- Negate secp256k1 point. 294 neg :: Projective -> Projective 295 neg (Projective x y z) = Projective x (modP (negate y)) z 296 297 -- Elliptic curve addition on secp256k1. 298 add :: Projective -> Projective -> Projective 299 add p q@(Projective _ _ z) 300 | p == q = double p -- algo 9 301 | z == 1 = add_mixed p q -- algo 8 302 | otherwise = add_proj p q -- algo 7 303 304 -- algo 7, "complete addition formulas for prime order elliptic curves," 305 -- renes et al, 2015 306 -- 307 -- https://eprint.iacr.org/2015/1060.pdf 308 add_proj :: Projective -> Projective -> Projective 309 add_proj (Projective x1 y1 z1) (Projective x2 y2 z2) = runST $ do 310 x3 <- newSTRef 0 311 y3 <- newSTRef 0 312 z3 <- newSTRef 0 313 let b3 = modP (_CURVE_B * 3) 314 t0 <- newSTRef (modP (x1 * x2)) -- 1 315 t1 <- newSTRef (modP (y1 * y2)) 316 t2 <- newSTRef (modP (z1 * z2)) 317 t3 <- newSTRef (modP (x1 + y1)) -- 4 318 t4 <- newSTRef (modP (x2 + y2)) 319 readSTRef t4 >>= \r4 -> 320 modifySTRef' t3 (\r3 -> modP (r3 * r4)) 321 readSTRef t0 >>= \r0 -> 322 readSTRef t1 >>= \r1 -> 323 writeSTRef t4 (modP (r0 + r1)) 324 readSTRef t4 >>= \r4 -> 325 modifySTRef' t3 (\r3 -> modP (r3 - r4)) -- 8 326 writeSTRef t4 (modP (y1 + z1)) 327 writeSTRef x3 (modP (y2 + z2)) 328 readSTRef x3 >>= \rx3 -> 329 modifySTRef' t4 (\r4 -> modP (r4 * rx3)) 330 readSTRef t1 >>= \r1 -> 331 readSTRef t2 >>= \r2 -> 332 writeSTRef x3 (modP (r1 + r2)) -- 12 333 readSTRef x3 >>= \rx3 -> 334 modifySTRef' t4 (\r4 -> modP (r4 - rx3)) 335 writeSTRef x3 (modP (x1 + z1)) 336 writeSTRef y3 (modP (x2 + z2)) 337 readSTRef y3 >>= \ry3 -> 338 modifySTRef' x3 (\rx3 -> modP (rx3 * ry3)) -- 16 339 readSTRef t0 >>= \r0 -> 340 readSTRef t2 >>= \r2 -> 341 writeSTRef y3 (modP (r0 + r2)) 342 readSTRef x3 >>= \rx3 -> 343 modifySTRef' y3 (\ry3 -> modP (rx3 - ry3)) 344 readSTRef t0 >>= \r0 -> 345 writeSTRef x3 (modP (r0 + r0)) 346 readSTRef x3 >>= \rx3 -> 347 modifySTRef t0 (\r0 -> modP (rx3 + r0)) -- 20 348 modifySTRef' t2 (\r2 -> modP (b3 * r2)) 349 readSTRef t1 >>= \r1 -> 350 readSTRef t2 >>= \r2 -> 351 writeSTRef z3 (modP (r1 + r2)) 352 readSTRef t2 >>= \r2 -> 353 modifySTRef' t1 (\r1 -> modP (r1 - r2)) 354 modifySTRef' y3 (\ry3 -> modP (b3 * ry3)) -- 24 355 readSTRef t4 >>= \r4 -> 356 readSTRef y3 >>= \ry3 -> 357 writeSTRef x3 (modP (r4 * ry3)) 358 readSTRef t3 >>= \r3 -> 359 readSTRef t1 >>= \r1 -> 360 writeSTRef t2 (modP (r3 * r1)) 361 readSTRef t2 >>= \r2 -> 362 modifySTRef' x3 (\rx3 -> modP (r2 - rx3)) 363 readSTRef t0 >>= \r0 -> 364 modifySTRef' y3 (\ry3 -> modP (ry3 * r0)) -- 28 365 readSTRef z3 >>= \rz3 -> 366 modifySTRef' t1 (\r1 -> modP (r1 * rz3)) 367 readSTRef t1 >>= \r1 -> 368 modifySTRef' y3 (\ry3 -> modP (r1 + ry3)) 369 readSTRef t3 >>= \r3 -> 370 modifySTRef' t0 (\r0 -> modP (r0 * r3)) 371 readSTRef t4 >>= \r4 -> 372 modifySTRef' z3 (\rz3 -> modP (rz3 * r4)) -- 32 373 readSTRef t0 >>= \r0 -> 374 modifySTRef' z3 (\rz3 -> modP (rz3 + r0)) 375 Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3 376 377 -- algo 8, renes et al, 2015 378 add_mixed :: Projective -> Projective -> Projective 379 add_mixed (Projective x1 y1 z1) (Projective x2 y2 z2) 380 | z2 /= 1 = error "ppad-secp256k1: internal error" 381 | otherwise = runST $ do 382 x3 <- newSTRef 0 383 y3 <- newSTRef 0 384 z3 <- newSTRef 0 385 let b3 = modP (_CURVE_B * 3) 386 t0 <- newSTRef (modP (x1 * x2)) -- 1 387 t1 <- newSTRef (modP (y1 * y2)) 388 t3 <- newSTRef (modP (x2 + y2)) 389 t4 <- newSTRef (modP (x1 + y1)) -- 4 390 readSTRef t4 >>= \r4 -> 391 modifySTRef' t3 (\r3 -> modP (r3 * r4)) 392 readSTRef t0 >>= \r0 -> 393 readSTRef t1 >>= \r1 -> 394 writeSTRef t4 (modP (r0 + r1)) 395 readSTRef t4 >>= \r4 -> 396 modifySTRef' t3 (\r3 -> modP (r3 - r4)) -- 7 397 writeSTRef t4 (modP (y2 * z1)) 398 modifySTRef' t4 (\r4 -> modP (r4 + y1)) 399 writeSTRef y3 (modP (x2 * z1)) -- 10 400 modifySTRef' y3 (\ry3 -> modP (ry3 + x1)) 401 readSTRef t0 >>= \r0 -> 402 writeSTRef x3 (modP (r0 + r0)) 403 readSTRef x3 >>= \rx3 -> 404 modifySTRef' t0 (\r0 -> modP (rx3 + r0)) -- 13 405 t2 <- newSTRef (modP (b3 * z1)) 406 readSTRef t1 >>= \r1 -> 407 readSTRef t2 >>= \r2 -> 408 writeSTRef z3 (modP (r1 + r2)) 409 readSTRef t2 >>= \r2 -> 410 modifySTRef' t1 (\r1 -> modP (r1 - r2)) -- 16 411 modifySTRef' y3 (\ry3 -> modP (b3 * ry3)) 412 readSTRef t4 >>= \r4 -> 413 readSTRef y3 >>= \ry3 -> 414 writeSTRef x3 (modP (r4 * ry3)) 415 readSTRef t3 >>= \r3 -> 416 readSTRef t1 >>= \r1 -> 417 writeSTRef t2 (modP (r3 * r1)) -- 19 418 readSTRef t2 >>= \r2 -> 419 modifySTRef' x3 (\rx3 -> modP (r2 - rx3)) 420 readSTRef t0 >>= \r0 -> 421 modifySTRef' y3 (\ry3 -> modP (ry3 * r0)) 422 readSTRef z3 >>= \rz3 -> 423 modifySTRef' t1 (\r1 -> modP (r1 * rz3)) -- 22 424 readSTRef t1 >>= \r1 -> 425 modifySTRef' y3 (\ry3 -> modP (r1 + ry3)) 426 readSTRef t3 >>= \r3 -> 427 modifySTRef' t0 (\r0 -> modP (r0 * r3)) 428 readSTRef t4 >>= \r4 -> 429 modifySTRef' z3 (\rz3 -> modP (rz3 * r4)) -- 25 430 readSTRef t0 >>= \r0 -> 431 modifySTRef' z3 (\rz3 -> modP (rz3 + r0)) 432 Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3 433 434 -- algo 9, renes et al, 2015 435 double :: Projective -> Projective 436 double (Projective x y z) = runST $ do 437 x3 <- newSTRef 0 438 y3 <- newSTRef 0 439 z3 <- newSTRef 0 440 let b3 = modP (_CURVE_B * 3) 441 t0 <- newSTRef (modP (y * y)) -- 1 442 readSTRef t0 >>= \r0 -> 443 writeSTRef z3 (modP (r0 + r0)) 444 modifySTRef' z3 (\rz3 -> modP (rz3 + rz3)) 445 modifySTRef' z3 (\rz3 -> modP (rz3 + rz3)) -- 4 446 t1 <- newSTRef (modP (y * z)) 447 t2 <- newSTRef (modP (z * z)) 448 modifySTRef t2 (\r2 -> modP (b3 * r2)) -- 7 449 readSTRef z3 >>= \rz3 -> 450 readSTRef t2 >>= \r2 -> 451 writeSTRef x3 (modP (r2 * rz3)) 452 readSTRef t0 >>= \r0 -> 453 readSTRef t2 >>= \r2 -> 454 writeSTRef y3 (modP (r0 + r2)) 455 readSTRef t1 >>= \r1 -> 456 modifySTRef' z3 (\rz3 -> modP (r1 * rz3)) -- 10 457 readSTRef t2 >>= \r2 -> 458 writeSTRef t1 (modP (r2 + r2)) 459 readSTRef t1 >>= \r1 -> 460 modifySTRef' t2 (\r2 -> modP (r1 + r2)) 461 readSTRef t2 >>= \r2 -> 462 modifySTRef' t0 (\r0 -> modP (r0 - r2)) -- 13 463 readSTRef t0 >>= \r0 -> 464 modifySTRef' y3 (\ry3 -> modP (r0 * ry3)) 465 readSTRef x3 >>= \rx3 -> 466 modifySTRef' y3 (\ry3 -> modP (rx3 + ry3)) 467 writeSTRef t1 (modP (x * y)) -- 16 468 readSTRef t0 >>= \r0 -> 469 readSTRef t1 >>= \r1 -> 470 writeSTRef x3 (modP (r0 * r1)) 471 modifySTRef' x3 (\rx3 -> modP (rx3 + rx3)) 472 Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3 473 474 -- Scalar multiplication of secp256k1 points. 475 mul :: Projective -> Integer -> Projective 476 mul p n 477 | n == 0 = _ZERO 478 | not (ge n) = error "ppad-secp256k1 (mul): scalar not in group" 479 | otherwise = loop _ZERO p n 480 where 481 loop !r !d m 482 | m <= 0 = r 483 | otherwise = 484 let nd = double d 485 nm = I.integerShiftR m 1 486 nr = if I.integerTestBit m 0 then add r d else r 487 in loop nr nd nm 488 489 -- parsing -------------------------------------------------------------------- 490 491 -- | Parse a hex-encoded integer. 492 parse_integer :: BS.ByteString -> Integer 493 parse_integer = roll . B16.decodeLenient 494 495 -- | Parse hex-encoded compressed point (33 bytes), uncompressed point 496 -- (65 bytes), or BIP0340-style point (32 bytes). 497 parse_point :: BS.ByteString -> Maybe Projective 498 parse_point (B16.decode -> ebs) = case ebs of 499 Left _ -> Nothing 500 Right bs 501 | BS.length bs == 32 -> -- bip0340 public key 502 fmap projective (lift (roll bs)) 503 | otherwise -> case BS.uncons bs of 504 Nothing -> Nothing 505 Just (fi -> h, t) -> 506 let (roll -> x, etc) = BS.splitAt (fi _CURVE_Q_BYTES) t 507 len = BS.length bs 508 in if len == 33 && (h == 0x02 || h == 0x03) -- compressed 509 then if not (fe x) 510 then Nothing 511 else do 512 y <- modsqrt (weierstrass x) 513 let yodd = I.integerTestBit y 0 514 hodd = I.integerTestBit h 0 515 pure $ 516 if hodd /= yodd 517 then Projective x (modP (negate y)) 1 518 else Projective x y 1 519 else 520 if len == 65 && h == 0x04 -- uncompressed 521 then let (roll -> y, _) = BS.splitAt (fi _CURVE_Q_BYTES) etc 522 p = Projective x y 1 523 in if valid p 524 then Just p 525 else Nothing 526 else Nothing 527 528 -- schnorr -------------------------------------------------------------------- 529 -- see https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki 530 531 -- | Create a 64-byte Schnorr signature for the provided message, using 532 -- the provided secret key. 533 -- 534 -- BIP0340 recommends that 32 bytes of fresh auxiliary entropy be 535 -- generated and added at signing time as additional protection 536 -- against side-channel attacks (namely, to thwart so-called "fault 537 -- injection" attacks). This entropy is /supplemental/ to security, 538 -- and the cryptographic security of the signature scheme itself does 539 -- not rely on it, so it is not strictly required; 32 zero bytes can 540 -- be used in its stead (and can be supplied via 'mempty'). 541 sign_schnorr 542 :: Integer -- ^ secret key 543 -> BS.ByteString -- ^ message 544 -> BS.ByteString -- ^ 32 bytes of auxilliary random data 545 -> BS.ByteString -- ^ 64-byte Schnorr signature 546 sign_schnorr d' m a 547 | not (ge d') = error "ppad-secp256k1 (sign_schnorr): invalid secret key" 548 | otherwise = 549 let p_proj = mul _CURVE_G d' 550 Affine x_p y_p = affine p_proj 551 d | y_p `rem` 2 == 0 = d' -- d' group element assures p nonzero 552 | otherwise = _CURVE_Q - d' 553 554 bytes_d = unroll32 d 555 h_a = hash_tagged "BIP0340/aux" a 556 t = xor bytes_d h_a 557 558 bytes_p = unroll32 x_p 559 rand = hash_tagged "BIP0340/nonce" (t <> bytes_p <> m) 560 561 k' = modQ (roll rand) 562 563 in if k' == 0 -- negligible probability 564 then error "ppad-secp256k1 (sign_schnorr): invalid k" 565 else 566 let Affine x_r y_r = affine (mul _CURVE_G k') 567 k | y_r `rem` 2 == 0 = k' -- k' nonzero per above 568 | otherwise = _CURVE_Q - k' 569 570 bytes_r = unroll32 x_r 571 e = modQ . roll . hash_tagged "BIP0340/challenge" 572 $ bytes_r <> bytes_p <> m 573 574 bytes_ked = unroll32 (modQ (k + e * d)) 575 576 sig = bytes_r <> bytes_ked 577 578 in if verify_schnorr m p_proj sig 579 then sig 580 else error "ppad-secp256k1 (sign_schnorr): invalid signature" 581 582 -- | Verify a 64-byte Schnorr signature for the provided message with 583 -- the supplied public key. 584 verify_schnorr 585 :: BS.ByteString -- ^ message 586 -> Pub -- ^ public key 587 -> BS.ByteString -- ^ 64-byte Schnorr signature 588 -> Bool 589 verify_schnorr m (affine -> Affine x_p _) sig = case lift x_p of 590 Nothing -> False 591 Just capP@(Affine x_P _) -> 592 let (roll -> r, roll -> s) = BS.splitAt 32 sig 593 in if r >= _CURVE_P || s >= _CURVE_Q 594 then False 595 else let e = modQ . roll $ hash_tagged "BIP0340/challenge" 596 (unroll32 r <> unroll32 x_P <> m) 597 dif = add (mul _CURVE_G s) (neg (mul (projective capP) e)) 598 in if dif == _ZERO 599 then False 600 else let Affine x_R y_R = affine dif 601 in not (y_R `rem` 2 /= 0 || x_R /= r) 602 603 -- ecdsa ---------------------------------------------------------------------- 604 -- see https://www.rfc-editor.org/rfc/rfc6979, https://secg.org/sec1-v2.pdf 605 606 -- RFC6979 2.3.2 607 bits2int :: BS.ByteString -> Integer 608 bits2int bs = 609 let (fi -> blen) = BS.length bs * 8 610 (fi -> qlen) = _CURVE_Q_BITS 611 del = blen - qlen 612 in if del > 0 613 then roll bs `I.integerShiftR` del 614 else roll bs 615 616 -- RFC6979 2.3.3 617 int2octets :: Integer -> BS.ByteString 618 int2octets i = pad (unroll i) where 619 pad bs 620 | BS.length bs < fi _CURVE_Q_BYTES = pad (BS.cons 0 bs) 621 | otherwise = bs 622 623 -- RFC6979 2.3.4 624 bits2octets :: BS.ByteString -> BS.ByteString 625 bits2octets bs = 626 let z1 = bits2int bs 627 z2 = modQ z1 628 in int2octets z2 629 630 -- | An ECDSA signature. 631 data ECDSA = ECDSA { 632 ecdsa_r :: !Integer 633 , ecdsa_s :: !Integer 634 } 635 deriving (Eq, Show, Generic) 636 637 -- ECDSA signature type. 638 data SigType = 639 LowS 640 | Unrestricted 641 deriving Show 642 643 -- Indicates whether to hash the message or assume it has already been 644 -- hashed. 645 data HashFlag = 646 Hash 647 | NoHash 648 deriving Show 649 650 -- | Produce an ECDSA signature for the provided message, using the 651 -- provided private key. 652 -- 653 -- 'sign_ecdsa' produces a "low-s" signature, as is commonly required 654 -- in applications. If you need a generic ECDSA signature, use 655 -- 'sign_ecdsa_unrestricted'. 656 sign_ecdsa 657 :: Integer -- ^ secret key 658 -> BS.ByteString -- ^ message 659 -> ECDSA 660 sign_ecdsa = _sign_ecdsa LowS Hash 661 662 -- | Produce an ECDSA signature for the provided message, using the 663 -- provided private key. 664 -- 665 -- 'sign_ecdsa_unrestricted' produces an unrestricted ECDSA signature, which 666 -- is less common in applications. If you need a conventional "low-s" 667 -- signature, use 'sign_ecdsa'. 668 sign_ecdsa_unrestricted 669 :: Integer -- ^ secret key 670 -> BS.ByteString -- ^ message 671 -> ECDSA 672 sign_ecdsa_unrestricted = _sign_ecdsa Unrestricted Hash 673 674 -- Produce a "low-s" ECDSA signature for the provided message, using 675 -- the provided private key. Assumes that the message has already been 676 -- pre-hashed. 677 -- 678 -- (Useful for testing against noble-secp256k1's suite, in which messages 679 -- in the test vectors have already been hashed.) 680 _sign_ecdsa_no_hash 681 :: Integer -- ^ secret key 682 -> BS.ByteString -- ^ message digest 683 -> ECDSA 684 _sign_ecdsa_no_hash = _sign_ecdsa LowS NoHash 685 686 _sign_ecdsa :: SigType -> HashFlag -> Integer -> BS.ByteString -> ECDSA 687 _sign_ecdsa ty hf x m 688 | not (ge x) = error "ppad-secp256k1 (sign_ecdsa): invalid secret key" 689 | otherwise = runST $ do 690 -- RFC6979 sec 3.3a 691 let entropy = int2octets x 692 nonce = bits2octets h 693 drbg <- DRBG.new SHA256.hmac entropy nonce mempty 694 -- RFC6979 sec 2.4 695 sign_loop drbg 696 where 697 h = case hf of 698 Hash -> SHA256.hash m 699 NoHash -> m 700 701 h_modQ = modQ (bits2int h) 702 703 sign_loop g = do 704 k <- gen_k g 705 let kg = mul _CURVE_G k 706 Affine (modQ -> r) _ = affine kg 707 s = case modinv k (fi _CURVE_Q) of 708 Nothing -> error "ppad-secp256k1 (sign_ecdsa): bad k value" 709 Just kinv -> modQ (modQ (h_modQ + modQ (x * r)) * kinv) 710 if r == 0 -- negligible probability 711 then sign_loop g 712 else let !sig = ECDSA r s 713 in case ty of 714 Unrestricted -> pure sig 715 LowS -> pure (low sig) 716 717 -- RFC6979 sec 3.3b 718 gen_k :: DRBG.DRBG s -> ST s Integer 719 gen_k g = loop g where 720 loop drbg = do 721 bytes <- DRBG.gen mempty (fi _CURVE_Q_BYTES) drbg 722 let can = bits2int bytes 723 if can >= _CURVE_Q 724 then loop drbg 725 else pure can 726 {-# INLINE gen_k #-} 727 728 -- Convert an ECDSA signature to low-S form. 729 low :: ECDSA -> ECDSA 730 low (ECDSA r s) = ECDSA r ms where 731 ms 732 | s > B.unsafeShiftR _CURVE_Q 1 = modQ (negate s) 733 | otherwise = s 734 {-# INLINE low #-} 735 736 -- | Verify a "low-s" ECDSA signature for the provided message and 737 -- public key. 738 verify_ecdsa 739 :: BS.ByteString -- ^ message 740 -> Pub -- ^ public key 741 -> ECDSA -- ^ signature 742 -> Bool 743 verify_ecdsa m p sig@(ECDSA _ s) 744 | s > B.unsafeShiftR _CURVE_Q 1 = False 745 | otherwise = verify_ecdsa_unrestricted m p sig 746 747 -- | Verify an unrestricted ECDSA signature for the provided message and 748 -- public key. 749 verify_ecdsa_unrestricted 750 :: BS.ByteString -- ^ message 751 -> Pub -- ^ public key 752 -> ECDSA -- ^ signature 753 -> Bool 754 verify_ecdsa_unrestricted (SHA256.hash -> h) p (ECDSA r s) 755 -- SEC1-v2 4.1.4 756 | not (ge r) || not (ge s) = False 757 | otherwise = 758 let e = modQ (bits2int h) 759 s_inv = case modinv s (fi _CURVE_Q) of 760 -- 'ge s' assures existence of inverse 761 Nothing -> 762 error "ppad-secp256k1 (verify_ecdsa_unrestricted): no inverse" 763 Just si -> si 764 u1 = modQ (e * s_inv) 765 u2 = modQ (r * s_inv) 766 capR = add (mul _CURVE_G u1) (mul p u2) 767 in if capR == _ZERO 768 then False 769 else let Affine (modQ -> v) _ = affine capR 770 in v == r 771