Secp256k1.hs (45252B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE CPP #-} 4 {-# LANGUAGE DeriveGeneric #-} 5 {-# LANGUAGE DerivingStrategies #-} 6 {-# LANGUAGE LambdaCase #-} 7 {-# LANGUAGE MagicHash #-} 8 {-# LANGUAGE OverloadedStrings #-} 9 {-# LANGUAGE PatternSynonyms #-} 10 {-# LANGUAGE RecordWildCards #-} 11 {-# LANGUAGE UnboxedTuples #-} 12 {-# LANGUAGE ViewPatterns #-} 13 14 #include "MachDeps.h" 15 #if WORD_SIZE_IN_BITS != 64 16 #error "ppad-secp256k1 requires a 64-bit architecture" 17 #endif 18 19 -- | 20 -- Module: Crypto.Curve.Secp256k1 21 -- Copyright: (c) 2024 Jared Tobin 22 -- License: MIT 23 -- Maintainer: Jared Tobin <jared@ppad.tech> 24 -- 25 -- Pure [BIP0340](https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki) 26 -- Schnorr signatures, deterministic 27 -- [RFC6979](https://www.rfc-editor.org/rfc/rfc6979) ECDSA (with 28 -- [BIP0146](https://github.com/bitcoin/bips/blob/master/bip-0146.mediawiki)-style 29 -- "low-S" signatures), and ECDH shared secret computation 30 -- on the elliptic curve secp256k1. 31 32 module Crypto.Curve.Secp256k1 ( 33 -- * Field and group parameters 34 _CURVE_Q 35 , _CURVE_P 36 37 -- * secp256k1 points 38 , Pub 39 , derive_pub 40 , derive_pub' 41 , _CURVE_G 42 , _CURVE_ZERO 43 , ge 44 , fe 45 46 -- * Parsing 47 , parse_int256 48 , parse_point 49 , parse_sig 50 51 -- * Serializing 52 , serialize_point 53 54 -- * ECDH 55 , ecdh 56 57 -- * BIP0340 Schnorr signatures 58 , sign_schnorr 59 , verify_schnorr 60 61 -- * RFC6979 ECDSA 62 , ECDSA(..) 63 , SigType(..) 64 , sign_ecdsa 65 , sign_ecdsa_unrestricted 66 , verify_ecdsa 67 , verify_ecdsa_unrestricted 68 69 -- * Fast variants 70 , Context 71 , precompute 72 , sign_schnorr' 73 , verify_schnorr' 74 , sign_ecdsa' 75 , sign_ecdsa_unrestricted' 76 , verify_ecdsa' 77 , verify_ecdsa_unrestricted' 78 79 -- Elliptic curve group operations 80 , neg 81 , add 82 , add_mixed 83 , add_proj 84 , double 85 , mul 86 , mul_vartime 87 , mul_wnaf 88 89 -- Coordinate systems and transformations 90 , Affine(..) 91 , Projective(..) 92 , affine 93 , projective 94 , valid 95 96 -- for testing/benchmarking 97 , _precompute 98 , _sign_ecdsa_no_hash 99 , _sign_ecdsa_no_hash' 100 , roll32 101 , unsafe_roll32 102 , unroll32 103 , select_proj 104 ) where 105 106 import Control.Monad (guard) 107 import Control.Monad.ST 108 import qualified Crypto.DRBG.HMAC as DRBG 109 import qualified Crypto.Hash.SHA256 as SHA256 110 import qualified Data.Bits as B 111 import qualified Data.ByteString as BS 112 import qualified Data.ByteString.Internal as BI 113 import qualified Data.ByteString.Unsafe as BU 114 import qualified Data.Choice as CT 115 import qualified Data.Maybe as M 116 import Data.Primitive.ByteArray (ByteArray(..), MutableByteArray(..)) 117 import qualified Data.Primitive.ByteArray as BA 118 import Data.Word (Word8) 119 import Data.Word.Limb (Limb(..)) 120 import qualified Data.Word.Limb as L 121 import Data.Word.Wider (Wider(..)) 122 import qualified Data.Word.Wider as W 123 import qualified Foreign.Storable as Storable (pokeByteOff) 124 import qualified GHC.Exts as Exts 125 import GHC.Generics 126 import qualified GHC.Word (Word(..), Word8(..)) 127 import qualified Numeric.Montgomery.Secp256k1.Curve as C 128 import qualified Numeric.Montgomery.Secp256k1.Scalar as S 129 import Prelude hiding (sqrt) 130 131 -- convenience synonyms ------------------------------------------------------- 132 133 -- Unboxed Wider/Montgomery synonym. 134 type Limb4 = (# Limb, Limb, Limb, Limb #) 135 136 -- Unboxed Projective synonym. 137 type Proj = (# Limb4, Limb4, Limb4 #) 138 139 pattern Zero :: Wider 140 pattern Zero = Wider Z 141 142 pattern Z :: Limb4 143 pattern Z = (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) 144 145 pattern P :: Limb4 -> Limb4 -> Limb4 -> Projective 146 pattern P x y z = Projective (C.Montgomery x) (C.Montgomery y) (C.Montgomery z) 147 {-# COMPLETE P #-} 148 149 -- utilities ------------------------------------------------------------------ 150 151 fi :: (Integral a, Num b) => a -> b 152 fi = fromIntegral 153 {-# INLINE fi #-} 154 155 -- convert a Word8 to a Limb 156 limb :: Word8 -> Limb 157 limb (GHC.Word.W8# (Exts.word8ToWord# -> w)) = Limb w 158 {-# INLINABLE limb #-} 159 160 -- convert a Limb to a Word8 161 word8 :: Limb -> Word8 162 word8 (Limb w) = GHC.Word.W8# (Exts.wordToWord8# w) 163 {-# INLINABLE word8 #-} 164 165 -- convert a Limb to a Word8 after right-shifting 166 word8s :: Limb -> Exts.Int# -> Word8 167 word8s l s = 168 let !(Limb w) = L.shr# l s 169 in GHC.Word.W8# (Exts.wordToWord8# w) 170 {-# INLINABLE word8s #-} 171 172 -- convert a Word8 to a Wider 173 word8_to_wider :: Word8 -> Wider 174 word8_to_wider w = Wider (# limb w, Limb 0##, Limb 0##, Limb 0## #) 175 {-# INLINABLE word8_to_wider #-} 176 177 -- unsafely extract the first 64-bit word from a big-endian-encoded bytestring 178 unsafe_word0 :: BS.ByteString -> Limb 179 unsafe_word0 bs = 180 (limb (BU.unsafeIndex bs 00) `L.shl#` 56#) 181 `L.or#` (limb (BU.unsafeIndex bs 01) `L.shl#` 48#) 182 `L.or#` (limb (BU.unsafeIndex bs 02) `L.shl#` 40#) 183 `L.or#` (limb (BU.unsafeIndex bs 03) `L.shl#` 32#) 184 `L.or#` (limb (BU.unsafeIndex bs 04) `L.shl#` 24#) 185 `L.or#` (limb (BU.unsafeIndex bs 05) `L.shl#` 16#) 186 `L.or#` (limb (BU.unsafeIndex bs 06) `L.shl#` 08#) 187 `L.or#` (limb (BU.unsafeIndex bs 07)) 188 {-# INLINABLE unsafe_word0 #-} 189 190 -- unsafely extract the second 64-bit word from a big-endian-encoded bytestring 191 unsafe_word1 :: BS.ByteString -> Limb 192 unsafe_word1 bs = 193 (limb (BU.unsafeIndex bs 08) `L.shl#` 56#) 194 `L.or#` (limb (BU.unsafeIndex bs 09) `L.shl#` 48#) 195 `L.or#` (limb (BU.unsafeIndex bs 10) `L.shl#` 40#) 196 `L.or#` (limb (BU.unsafeIndex bs 11) `L.shl#` 32#) 197 `L.or#` (limb (BU.unsafeIndex bs 12) `L.shl#` 24#) 198 `L.or#` (limb (BU.unsafeIndex bs 13) `L.shl#` 16#) 199 `L.or#` (limb (BU.unsafeIndex bs 14) `L.shl#` 08#) 200 `L.or#` (limb (BU.unsafeIndex bs 15)) 201 {-# INLINABLE unsafe_word1 #-} 202 203 -- unsafely extract the third 64-bit word from a big-endian-encoded bytestring 204 unsafe_word2 :: BS.ByteString -> Limb 205 unsafe_word2 bs = 206 (limb (BU.unsafeIndex bs 16) `L.shl#` 56#) 207 `L.or#` (limb (BU.unsafeIndex bs 17) `L.shl#` 48#) 208 `L.or#` (limb (BU.unsafeIndex bs 18) `L.shl#` 40#) 209 `L.or#` (limb (BU.unsafeIndex bs 19) `L.shl#` 32#) 210 `L.or#` (limb (BU.unsafeIndex bs 20) `L.shl#` 24#) 211 `L.or#` (limb (BU.unsafeIndex bs 21) `L.shl#` 16#) 212 `L.or#` (limb (BU.unsafeIndex bs 22) `L.shl#` 08#) 213 `L.or#` (limb (BU.unsafeIndex bs 23)) 214 {-# INLINABLE unsafe_word2 #-} 215 216 -- unsafely extract the fourth 64-bit word from a big-endian-encoded bytestring 217 unsafe_word3 :: BS.ByteString -> Limb 218 unsafe_word3 bs = 219 (limb (BU.unsafeIndex bs 24) `L.shl#` 56#) 220 `L.or#` (limb (BU.unsafeIndex bs 25) `L.shl#` 48#) 221 `L.or#` (limb (BU.unsafeIndex bs 26) `L.shl#` 40#) 222 `L.or#` (limb (BU.unsafeIndex bs 27) `L.shl#` 32#) 223 `L.or#` (limb (BU.unsafeIndex bs 28) `L.shl#` 24#) 224 `L.or#` (limb (BU.unsafeIndex bs 29) `L.shl#` 16#) 225 `L.or#` (limb (BU.unsafeIndex bs 30) `L.shl#` 08#) 226 `L.or#` (limb (BU.unsafeIndex bs 31)) 227 {-# INLINABLE unsafe_word3 #-} 228 229 -- 256-bit big-endian bytestring decoding. the input size is not checked! 230 unsafe_roll32 :: BS.ByteString -> Wider 231 unsafe_roll32 bs = 232 let !w0 = unsafe_word0 bs 233 !w1 = unsafe_word1 bs 234 !w2 = unsafe_word2 bs 235 !w3 = unsafe_word3 bs 236 in Wider (# w3, w2, w1, w0 #) 237 {-# INLINABLE unsafe_roll32 #-} 238 239 -- arbitrary-size big-endian bytestring decoding 240 roll32 :: BS.ByteString -> Maybe Wider 241 roll32 bs 242 | BS.length stripped > 32 = Nothing 243 | otherwise = Just $! BS.foldl' alg 0 stripped 244 where 245 stripped = BS.dropWhile (== 0) bs 246 alg !a (word8_to_wider -> !b) = (a `W.shl_limb` 8) `W.or` b 247 {-# INLINABLE roll32 #-} 248 249 -- 256-bit big-endian bytestring encoding 250 unroll32 :: Wider -> BS.ByteString 251 unroll32 (Wider (# w0, w1, w2, w3 #)) = 252 BI.unsafeCreate 32 $ \ptr -> do 253 -- w0 254 Storable.pokeByteOff ptr 00 (word8s w3 56#) 255 Storable.pokeByteOff ptr 01 (word8s w3 48#) 256 Storable.pokeByteOff ptr 02 (word8s w3 40#) 257 Storable.pokeByteOff ptr 03 (word8s w3 32#) 258 Storable.pokeByteOff ptr 04 (word8s w3 24#) 259 Storable.pokeByteOff ptr 05 (word8s w3 16#) 260 Storable.pokeByteOff ptr 06 (word8s w3 08#) 261 Storable.pokeByteOff ptr 07 (word8 w3) 262 -- w1 263 Storable.pokeByteOff ptr 08 (word8s w2 56#) 264 Storable.pokeByteOff ptr 09 (word8s w2 48#) 265 Storable.pokeByteOff ptr 10 (word8s w2 40#) 266 Storable.pokeByteOff ptr 11 (word8s w2 32#) 267 Storable.pokeByteOff ptr 12 (word8s w2 24#) 268 Storable.pokeByteOff ptr 13 (word8s w2 16#) 269 Storable.pokeByteOff ptr 14 (word8s w2 08#) 270 Storable.pokeByteOff ptr 15 (word8 w2) 271 -- w2 272 Storable.pokeByteOff ptr 16 (word8s w1 56#) 273 Storable.pokeByteOff ptr 17 (word8s w1 48#) 274 Storable.pokeByteOff ptr 18 (word8s w1 40#) 275 Storable.pokeByteOff ptr 19 (word8s w1 32#) 276 Storable.pokeByteOff ptr 20 (word8s w1 24#) 277 Storable.pokeByteOff ptr 21 (word8s w1 16#) 278 Storable.pokeByteOff ptr 22 (word8s w1 08#) 279 Storable.pokeByteOff ptr 23 (word8 w1) 280 -- w3 281 Storable.pokeByteOff ptr 24 (word8s w0 56#) 282 Storable.pokeByteOff ptr 25 (word8s w0 48#) 283 Storable.pokeByteOff ptr 26 (word8s w0 40#) 284 Storable.pokeByteOff ptr 27 (word8s w0 32#) 285 Storable.pokeByteOff ptr 28 (word8s w0 24#) 286 Storable.pokeByteOff ptr 29 (word8s w0 16#) 287 Storable.pokeByteOff ptr 30 (word8s w0 08#) 288 Storable.pokeByteOff ptr 31 (word8 w0) 289 {-# INLINABLE unroll32 #-} 290 291 -- modQ via conditional subtraction 292 modQ :: Wider -> Wider 293 modQ x = W.select x (x - _CURVE_Q) (CT.not (W.lt x _CURVE_Q)) 294 {-# INLINABLE modQ #-} 295 296 -- bytewise xor 297 xor :: BS.ByteString -> BS.ByteString -> BS.ByteString 298 xor = BS.packZipWith B.xor 299 {-# INLINABLE xor #-} 300 301 -- constants ------------------------------------------------------------------ 302 303 -- | secp256k1 field prime. 304 _CURVE_P :: Wider 305 _CURVE_P = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F 306 307 -- | secp256k1 group order. 308 _CURVE_Q :: Wider 309 _CURVE_Q = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 310 311 -- | half of the secp256k1 group order. 312 _CURVE_QH :: Wider 313 _CURVE_QH = 0x7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF5D576E7357A4501DDFE92F46681B20A0 314 315 -- bitlength of group order 316 -- 317 -- = smallest integer such that _CURVE_Q < 2 ^ _CURVE_Q_BITS 318 _CURVE_Q_BITS :: Int 319 _CURVE_Q_BITS = 256 320 321 -- bytelength of _CURVE_Q 322 -- 323 -- = _CURVE_Q_BITS / 8 324 _CURVE_Q_BYTES :: Int 325 _CURVE_Q_BYTES = 32 326 327 -- secp256k1 weierstrass form, /b/ coefficient 328 _CURVE_B :: Wider 329 _CURVE_B = 7 330 331 -- secp256k1 weierstrass form, /b/ coefficient, montgomery form 332 _CURVE_Bm :: C.Montgomery 333 _CURVE_Bm = 7 334 335 -- _CURVE_Bm * 3 336 _CURVE_Bm3 :: C.Montgomery 337 _CURVE_Bm3 = 21 338 339 -- Is field element? 340 fe :: Wider -> Bool 341 fe n = case W.cmp_vartime n 0 of 342 GT -> case W.cmp_vartime n _CURVE_P of 343 LT -> True 344 _ -> False 345 _ -> False 346 {-# INLINE fe #-} 347 348 -- Is group element? 349 ge :: Wider -> Bool 350 ge (Wider n) = CT.decide (ge# n) 351 {-# INLINE ge #-} 352 353 -- curve points --------------------------------------------------------------- 354 355 -- curve point, affine coordinates 356 data Affine = Affine !C.Montgomery !C.Montgomery 357 deriving stock (Show, Generic) 358 359 -- curve point, projective coordinates 360 data Projective = Projective { 361 px :: !C.Montgomery 362 , py :: !C.Montgomery 363 , pz :: !C.Montgomery 364 } 365 deriving stock (Show, Generic) 366 367 instance Eq Projective where 368 Projective ax ay az == Projective bx by bz = 369 let !x1z2 = ax * bz 370 !x2z1 = bx * az 371 !y1z2 = ay * bz 372 !y2z1 = by * az 373 in CT.decide (CT.and (C.eq x1z2 x2z1) (C.eq y1z2 y2z1)) 374 375 -- | An ECC-flavoured alias for a secp256k1 point. 376 type Pub = Projective 377 378 -- Convert to affine coordinates. 379 affine :: Projective -> Affine 380 affine (Projective x y z) = 381 let !iz = C.inv z 382 in Affine (x * iz) (y * iz) 383 {-# INLINABLE affine #-} 384 385 -- Convert to projective coordinates. 386 projective :: Affine -> Projective 387 projective (Affine x y) 388 | C.eq_vartime x 0 || C.eq_vartime y 0 = _CURVE_ZERO 389 | otherwise = Projective x y 1 390 391 -- | secp256k1 generator point. 392 _CURVE_G :: Projective 393 _CURVE_G = Projective x y z where 394 !x = C.Montgomery 395 (# Limb 15507633332195041431##, Limb 2530505477788034779## 396 , Limb 10925531211367256732##, Limb 11061375339145502536## #) 397 !y = C.Montgomery 398 (# Limb 12780836216951778274##, Limb 10231155108014310989## 399 , Limb 8121878653926228278##, Limb 14933801261141951190## #) 400 !z = C.Montgomery 401 (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) 402 403 -- | secp256k1 zero point, point at infinity, or monoidal identity. 404 _CURVE_ZERO :: Projective 405 _CURVE_ZERO = Projective 0 1 0 406 407 -- secp256k1 zero point, point at infinity, or monoidal identity 408 _ZERO :: Projective 409 _ZERO = Projective 0 1 0 410 {-# DEPRECATED _ZERO "use _CURVE_ZERO instead" #-} 411 412 -- secp256k1 in short weierstrass form (y ^ 2 = x ^ 3 + 7) 413 weierstrass :: C.Montgomery -> C.Montgomery 414 weierstrass x = C.sqr x * x + _CURVE_Bm 415 {-# INLINE weierstrass #-} 416 417 -- Point is valid 418 valid :: Projective -> Bool 419 valid (affine -> Affine x y) = C.eq_vartime (C.sqr y) (weierstrass x) 420 421 -- (bip0340) return point with x coordinate == x and with even y coordinate 422 -- 423 -- conceptually: 424 -- y ^ 2 = x ^ 3 + 7 425 -- y = "+-" sqrt (x ^ 3 + 7) 426 -- (n.b. for solution y, p - y is also a solution) 427 -- y + (p - y) = p (odd) 428 -- (n.b. sum is odd, so one of y and p - y must be odd, and the other even) 429 -- if y even, return (x, y) 430 -- else, return (x, p - y) 431 lift_vartime :: C.Montgomery -> Maybe Affine 432 lift_vartime x = do 433 let !c = weierstrass x 434 !y <- C.sqrt_vartime c 435 let !y_e | C.odd_vartime y = negate y 436 | otherwise = y 437 pure $! Affine x y_e 438 439 even_y_vartime :: Projective -> Projective 440 even_y_vartime p = case affine p of 441 Affine _ (C.retr -> y) 442 | CT.decide (W.odd y) -> neg p 443 | otherwise -> p 444 445 -- Constant-time selection of Projective points. 446 select_proj :: Projective -> Projective -> CT.Choice -> Projective 447 select_proj (Projective ax ay az) (Projective bx by bz) c = 448 Projective (C.select ax bx c) (C.select ay by c) (C.select az bz c) 449 {-# INLINE select_proj #-} 450 451 -- unboxed internals ---------------------------------------------------------- 452 453 -- algo 7, renes et al, 2015 454 add_proj# :: Proj -> Proj -> Proj 455 add_proj# (# x1, y1, z1 #) (# x2, y2, z2 #) = 456 let !(C.Montgomery b3) = _CURVE_Bm3 457 !t0a = C.mul# x1 x2 458 !t1a = C.mul# y1 y2 459 !t2a = C.mul# z1 z2 460 !t3a = C.add# x1 y1 461 !t4a = C.add# x2 y2 462 !t3b = C.mul# t3a t4a 463 !t4b = C.add# t0a t1a 464 !t3c = C.sub# t3b t4b 465 !t4c = C.add# y1 z1 466 !x3a = C.add# y2 z2 467 !t4d = C.mul# t4c x3a 468 !x3b = C.add# t1a t2a 469 !t4e = C.sub# t4d x3b 470 !x3c = C.add# x1 z1 471 !y3a = C.add# x2 z2 472 !x3d = C.mul# x3c y3a 473 !y3b = C.add# t0a t2a 474 !y3c = C.sub# x3d y3b 475 !x3e = C.add# t0a t0a 476 !t0b = C.add# x3e t0a 477 !t2b = C.mul# b3 t2a 478 !z3a = C.add# t1a t2b 479 !t1b = C.sub# t1a t2b 480 !y3d = C.mul# b3 y3c 481 !x3f = C.mul# t4e y3d 482 !t2c = C.mul# t3c t1b 483 !x3g = C.sub# t2c x3f 484 !y3e = C.mul# y3d t0b 485 !t1c = C.mul# t1b z3a 486 !y3f = C.add# t1c y3e 487 !t0c = C.mul# t0b t3c 488 !z3b = C.mul# z3a t4e 489 !z3c = C.add# z3b t0c 490 in (# x3g, y3f, z3c #) 491 {-# INLINE add_proj# #-} 492 493 -- algo 8, renes et al, 2015 494 add_mixed# :: Proj -> Proj -> Proj 495 add_mixed# (# x1, y1, z1 #) (# x2, y2, _z2 #) = 496 let !(C.Montgomery b3) = _CURVE_Bm3 497 !t0a = C.mul# x1 x2 498 !t1a = C.mul# y1 y2 499 !t3a = C.add# x2 y2 500 !t4a = C.add# x1 y1 501 !t3b = C.mul# t3a t4a 502 !t4b = C.add# t0a t1a 503 !t3c = C.sub# t3b t4b 504 !t4c = C.mul# y2 z1 505 !t4d = C.add# t4c y1 506 !y3a = C.mul# x2 z1 507 !y3b = C.add# y3a x1 508 !x3a = C.add# t0a t0a 509 !t0b = C.add# x3a t0a 510 !t2a = C.mul# b3 z1 511 !z3a = C.add# t1a t2a 512 !t1b = C.sub# t1a t2a 513 !y3c = C.mul# b3 y3b 514 !x3b = C.mul# t4d y3c 515 !t2b = C.mul# t3c t1b 516 !x3c = C.sub# t2b x3b 517 !y3d = C.mul# y3c t0b 518 !t1c = C.mul# t1b z3a 519 !y3e = C.add# t1c y3d 520 !t0c = C.mul# t0b t3c 521 !z3b = C.mul# z3a t4d 522 !z3c = C.add# z3b t0c 523 in (# x3c, y3e, z3c #) 524 {-# INLINE add_mixed# #-} 525 526 -- algo 9, renes et al, 2015 527 double# :: Proj -> Proj 528 double# (# x, y, z #) = 529 let !(C.Montgomery b3) = _CURVE_Bm3 530 !t0 = C.sqr# y 531 !z3a = C.add# t0 t0 532 !z3b = C.add# z3a z3a 533 !z3c = C.add# z3b z3b 534 !t1 = C.mul# y z 535 !t2a = C.sqr# z 536 !t2b = C.mul# b3 t2a 537 !x3a = C.mul# t2b z3c 538 !y3a = C.add# t0 t2b 539 !z3d = C.mul# t1 z3c 540 !t1b = C.add# t2b t2b 541 !t2c = C.add# t1b t2b 542 !t0b = C.sub# t0 t2c 543 !y3b = C.mul# t0b y3a 544 !y3c = C.add# x3a y3b 545 !t1c = C.mul# x y 546 !x3b = C.mul# t0b t1c 547 !x3c = C.add# x3b x3b 548 in (# x3c, y3c, z3d #) 549 {-# INLINE double# #-} 550 551 select_proj# :: Proj -> Proj -> CT.Choice -> Proj 552 select_proj# (# ax, ay, az #) (# bx, by, bz #) c = 553 (# W.select# ax bx c, W.select# ay by c, W.select# az bz c #) 554 {-# INLINE select_proj# #-} 555 556 neg# :: Proj -> Proj 557 neg# (# x, y, z #) = (# x, C.neg# y, z #) 558 {-# INLINE neg# #-} 559 560 mul# :: Proj -> Limb4 -> (# () | Proj #) 561 mul# (# px, py, pz #) s 562 | CT.decide (CT.not (ge# s)) = (# () | #) 563 | otherwise = 564 let !(P gx gy gz) = _CURVE_G 565 !(C.Montgomery o) = C.one 566 in loop (0 :: Int) (# Z, o, Z #) (# gx, gy, gz #) (# px, py, pz #) s 567 where 568 loop !j !a !f !d !_SECRET 569 | j == _CURVE_Q_BITS = (# | a #) 570 | otherwise = 571 let !nd = double# d 572 !(# nm, lsb_set #) = W.shr1_c# _SECRET 573 !nacc = select_proj# a (add_proj# a d) lsb_set 574 !nf = select_proj# (add_proj# f d) f lsb_set 575 in loop (succ j) nacc nf nd nm 576 {-# INLINE mul# #-} 577 578 ge# :: Limb4 -> CT.Choice 579 ge# n = 580 let !(Wider q) = _CURVE_Q 581 in CT.and (W.gt# n Z) (W.lt# n q) 582 {-# INLINE ge# #-} 583 584 mul_wnaf# :: ByteArray -> Int -> Limb4 -> (# () | Proj #) 585 mul_wnaf# ctxArray ctxW ls 586 | CT.decide (CT.not (ge# ls)) = (# () | #) 587 | otherwise = 588 let !(P zx zy zz) = _CURVE_ZERO 589 !(P gx gy gz) = _CURVE_G 590 in (# | loop 0 (# zx, zy, zz #) (# gx, gy, gz #) ls #) 591 where 592 !one = (# Limb 1##, Limb 0##, Limb 0##, Limb 0## #) 593 !wins = fi (256 `quot` ctxW + 1) 594 !size@(GHC.Word.W# s) = 2 ^ (ctxW - 1) 595 !(GHC.Word.W# mask) = 2 ^ ctxW - 1 596 !(GHC.Word.W# texW) = fi ctxW 597 !(GHC.Word.W# mnum) = 2 ^ ctxW 598 599 loop !j@(GHC.Word.W# w) !acc !f !n@(# Limb lo, _, _, _ #) 600 | j == wins = acc 601 | otherwise = 602 let !(GHC.Word.W# off0) = j * size 603 !b0 = Exts.and# lo mask 604 !bor = CT.from_word_gt# b0 s 605 606 !(# n0, _ #) = W.shr_limb# n (Exts.word2Int# texW) 607 !n0_plus_1 = W.add_w# n0 one 608 !n1 = W.select# n0 n0_plus_1 bor 609 610 !abs_b = CT.select_word# b0 (Exts.minusWord# mnum b0) bor 611 !is_zero = CT.from_word_eq# b0 0## 612 !c0 = CT.from_bit# (Exts.and# w 1##) 613 !off_nz = Exts.minusWord# (Exts.plusWord# off0 abs_b) 1## 614 !off = CT.select_word# off0 off_nz (CT.not is_zero) 615 616 !pr = ct_index_proj# ctxArray off0 s off 617 !neg_pr = neg# pr 618 !pt_zero = select_proj# pr neg_pr c0 619 !pt_nonzero = select_proj# pr neg_pr bor 620 621 !f_added = add_proj# f pt_zero 622 !acc_added = add_proj# acc pt_nonzero 623 !nacc = select_proj# acc_added acc is_zero 624 !nf = select_proj# f f_added is_zero 625 in loop (succ j) nacc nf n1 626 {-# INLINE mul_wnaf# #-} 627 628 -- retrieve a point (as an unboxed tuple) from a context array 629 index_proj# :: ByteArray -> Exts.Int# -> Proj 630 index_proj# (ByteArray arr#) i# = 631 let !base# = i# Exts.*# 12# 632 !x = (# Limb (Exts.indexWordArray# arr# base#) 633 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 01#)) 634 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 02#)) 635 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 03#)) #) 636 !y = (# Limb (Exts.indexWordArray# arr# (base# Exts.+# 04#)) 637 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 05#)) 638 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 06#)) 639 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 07#)) #) 640 !z = (# Limb (Exts.indexWordArray# arr# (base# Exts.+# 08#)) 641 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 09#)) 642 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 10#)) 643 , Limb (Exts.indexWordArray# arr# (base# Exts.+# 11#)) #) 644 in (# x, y, z #) 645 {-# INLINE index_proj# #-} 646 647 -- Constant-time table lookup within a window. 648 -- 649 -- Unconditionally scans all entries from 'base' to 'base + size - 1', 650 -- selecting the one where 'index' equals 'target'. 651 ct_index_proj# 652 :: ByteArray 653 -> Exts.Word# -- ^ base index 654 -> Exts.Word# -- ^ size of window 655 -> Exts.Word# -- ^ target index 656 -> Proj 657 ct_index_proj# arr base size target = loop 0## (# Z, Z, Z #) where 658 loop i acc 659 | Exts.isTrue# (i `Exts.geWord#` size) = acc 660 | otherwise = 661 let !idx = Exts.plusWord# base i 662 !pt = index_proj# arr (Exts.word2Int# idx) 663 !eq = CT.from_word_eq# idx target 664 !nacc = select_proj# acc pt eq 665 in loop (Exts.plusWord# i 1##) nacc 666 {-# INLINE ct_index_proj# #-} 667 668 -- ec arithmetic -------------------------------------------------------------- 669 670 -- Negate secp256k1 point. 671 neg :: Projective -> Projective 672 neg (P x y z) = 673 let !(# px, py, pz #) = neg# (# x, y, z #) 674 in P px py pz 675 {-# INLINABLE neg #-} 676 677 -- Elliptic curve addition on secp256k1. 678 add :: Projective -> Projective -> Projective 679 add p q = add_proj p q 680 {-# INLINABLE add #-} 681 682 -- algo 7, "complete addition formulas for prime order elliptic curves," 683 -- renes et al, 2015 684 -- 685 -- https://eprint.iacr.org/2015/1060.pdf 686 add_proj :: Projective -> Projective -> Projective 687 add_proj (P ax ay az) (P bx by bz) = 688 let !(# x, y, z #) = add_proj# (# ax, ay, az #) (# bx, by, bz #) 689 in P x y z 690 {-# INLINABLE add_proj #-} 691 692 -- algo 8, renes et al, 2015 693 add_mixed :: Projective -> Projective -> Projective 694 add_mixed (P ax ay az) (P bx by bz) = 695 let !(# x, y, z #) = add_mixed# (# ax, ay, az #) (# bx, by, bz #) 696 in P x y z 697 {-# INLINABLE add_mixed #-} 698 699 -- algo 9, renes et al, 2015 700 double :: Projective -> Projective 701 double (Projective (C.Montgomery ax) (C.Montgomery ay) (C.Montgomery az)) = 702 let !(# x, y, z #) = double# (# ax, ay, az #) 703 in P x y z 704 {-# INLINABLE double #-} 705 706 -- Timing-safe scalar multiplication of secp256k1 points. 707 mul :: Projective -> Wider -> Maybe Projective 708 mul (P x y z) (Wider s) = case mul# (# x, y, z #) s of 709 (# () | #) -> Nothing 710 (# | (# px, py, pz #) #) -> Just $! P px py pz 711 {-# INLINABLE mul #-} 712 713 -- Timing-unsafe scalar multiplication of secp256k1 points. 714 -- 715 -- Don't use this function if the scalar could potentially be a secret. 716 mul_vartime :: Projective -> Wider -> Maybe Projective 717 mul_vartime p = \case 718 Zero -> pure _CURVE_ZERO 719 n | not (ge n) -> Nothing 720 | otherwise -> pure $! loop _CURVE_ZERO p n 721 where 722 loop !r !d = \case 723 Zero -> r 724 m -> 725 let !nd = double d 726 !(# nm, lsb_set #) = W.shr1_c m 727 !nr = if CT.decide lsb_set then add r d else r 728 in loop nr nd nm 729 730 -- | Precomputed multiples of the secp256k1 base or generator point. 731 data Context = Context { 732 ctxW :: {-# UNPACK #-} !Int 733 , ctxArray :: {-# UNPACK #-} !ByteArray 734 } deriving Generic 735 736 instance Show Context where 737 show Context {} = "<secp256k1 context>" 738 739 -- | Create a secp256k1 context by precomputing multiples of the curve's 740 -- generator point. 741 -- 742 -- This should be used once to create a 'Context' to be reused 743 -- repeatedly afterwards. 744 -- 745 -- >>> let !tex = precompute 746 -- >>> sign_ecdsa' tex sec msg 747 -- >>> sign_schnorr' tex sec msg aux 748 precompute :: Context 749 precompute = _precompute 4 750 751 -- This is a highly-optimized version of a function originally 752 -- translated from noble-secp256k1's "precompute". Points are stored in 753 -- a ByteArray by arranging each limb into slices of 12 consecutive 754 -- slots (each Projective point consists of three Montgomery values, 755 -- each of which consists of four limbs, summing to twelve limbs in 756 -- total). 757 -- 758 -- Each point takes 96 bytes to store in this fashion, so the total size of 759 -- the ByteArray is (size * 96) bytes. 760 _precompute :: Int -> Context 761 _precompute ctxW = Context {..} where 762 capJ = (2 :: Int) ^ (ctxW - 1) 763 ws = 256 `quot` ctxW + 1 764 size = ws * capJ 765 766 -- construct the context array 767 ctxArray = runST $ do 768 marr <- BA.newByteArray (size * 96) 769 loop_w marr _CURVE_G 0 770 BA.unsafeFreezeByteArray marr 771 772 -- write a point into the i^th 12-slot slice in the array 773 write :: MutableByteArray s -> Int -> Projective -> ST s () 774 write marr i 775 (P (# Limb x0, Limb x1, Limb x2, Limb x3 #) 776 (# Limb y0, Limb y1, Limb y2, Limb y3 #) 777 (# Limb z0, Limb z1, Limb z2, Limb z3 #)) = do 778 let !base = i * 12 779 BA.writeByteArray marr (base + 00) (GHC.Word.W# x0) 780 BA.writeByteArray marr (base + 01) (GHC.Word.W# x1) 781 BA.writeByteArray marr (base + 02) (GHC.Word.W# x2) 782 BA.writeByteArray marr (base + 03) (GHC.Word.W# x3) 783 BA.writeByteArray marr (base + 04) (GHC.Word.W# y0) 784 BA.writeByteArray marr (base + 05) (GHC.Word.W# y1) 785 BA.writeByteArray marr (base + 06) (GHC.Word.W# y2) 786 BA.writeByteArray marr (base + 07) (GHC.Word.W# y3) 787 BA.writeByteArray marr (base + 08) (GHC.Word.W# z0) 788 BA.writeByteArray marr (base + 09) (GHC.Word.W# z1) 789 BA.writeByteArray marr (base + 10) (GHC.Word.W# z2) 790 BA.writeByteArray marr (base + 11) (GHC.Word.W# z3) 791 792 -- loop over windows 793 loop_w :: MutableByteArray s -> Projective -> Int -> ST s () 794 loop_w !marr !p !w 795 | w == ws = pure () 796 | otherwise = do 797 nb <- loop_j marr p p (w * capJ) 0 798 let np = double nb 799 loop_w marr np (succ w) 800 801 -- loop within windows 802 loop_j 803 :: MutableByteArray s 804 -> Projective 805 -> Projective 806 -> Int 807 -> Int 808 -> ST s Projective 809 loop_j !marr !p !b !idx !j = do 810 write marr idx b 811 if j == capJ - 1 812 then pure b 813 else do 814 let !nb = add b p 815 loop_j marr p nb (succ idx) (succ j) 816 817 -- Timing-safe wNAF (w-ary non-adjacent form) scalar multiplication of 818 -- secp256k1 points. 819 mul_wnaf :: Context -> Wider -> Maybe Projective 820 mul_wnaf Context {..} (Wider s) = case mul_wnaf# ctxArray ctxW s of 821 (# () | #) -> Nothing 822 (# | (# px, py, pz #) #) -> Just $! P px py pz 823 {-# INLINABLE mul_wnaf #-} 824 825 -- | Derive a public key (i.e., a secp256k1 point) from the provided 826 -- secret. 827 -- 828 -- >>> import qualified System.Entropy as E 829 -- >>> sk <- fmap parse_int256 (E.getEntropy 32) 830 -- >>> derive_pub sk 831 -- Just "<secp256k1 point>" 832 derive_pub :: Wider -> Maybe Pub 833 derive_pub = mul _CURVE_G 834 {-# NOINLINE derive_pub #-} 835 836 -- | The same as 'derive_pub', except uses a 'Context' to optimise 837 -- internal calculations. 838 -- 839 -- >>> import qualified System.Entropy as E 840 -- >>> sk <- fmap parse_int256 (E.getEntropy 32) 841 -- >>> let !tex = precompute 842 -- >>> derive_pub' tex sk 843 -- Just "<secp256k1 point>" 844 derive_pub' :: Context -> Wider -> Maybe Pub 845 derive_pub' = mul_wnaf 846 {-# NOINLINE derive_pub' #-} 847 848 -- parsing -------------------------------------------------------------------- 849 850 -- | Parse a 'Wider', /e.g./ a Schnorr or ECDSA secret key. 851 -- 852 -- >>> import qualified Data.ByteString as BS 853 -- >>> parse_int256 (BS.replicate 32 0xFF) 854 -- Just <2^256 - 1> 855 parse_int256 :: BS.ByteString -> Maybe Wider 856 parse_int256 bs = do 857 guard (BS.length bs == 32) 858 pure $! unsafe_roll32 bs 859 {-# INLINABLE parse_int256 #-} 860 861 -- | Parse compressed secp256k1 point (33 bytes), uncompressed point (65 862 -- bytes), or BIP0340-style point (32 bytes). 863 -- 864 -- >>> parse_point <33-byte compressed point> 865 -- Just <Pub> 866 -- >>> parse_point <65-byte uncompressed point> 867 -- Just <Pub> 868 -- >>> parse_point <32-byte bip0340 public key> 869 -- Just <Pub> 870 -- >>> parse_point <anything else> 871 -- Nothing 872 parse_point :: BS.ByteString -> Maybe Projective 873 parse_point bs 874 | len == 32 = _parse_bip0340 bs 875 | len == 33 = _parse_compressed h t 876 | len == 65 = _parse_uncompressed h t 877 | otherwise = Nothing 878 where 879 len = BS.length bs 880 h = BU.unsafeIndex bs 0 -- lazy 881 t = BS.drop 1 bs 882 883 -- input is guaranteed to be 32B in length 884 _parse_bip0340 :: BS.ByteString -> Maybe Projective 885 _parse_bip0340 = fmap projective . lift_vartime . C.to . unsafe_roll32 886 887 -- bytestring input is guaranteed to be 32B in length 888 _parse_compressed :: Word8 -> BS.ByteString -> Maybe Projective 889 _parse_compressed h (unsafe_roll32 -> x) 890 | h /= 0x02 && h /= 0x03 = Nothing 891 | not (fe x) = Nothing 892 | otherwise = do 893 let !mx = C.to x 894 !my <- C.sqrt_vartime (weierstrass mx) 895 let !yodd = CT.decide (W.odd (C.retr my)) 896 !hodd = B.testBit h 0 897 pure $! 898 if hodd /= yodd 899 then Projective mx (negate my) 1 900 else Projective mx my 1 901 902 -- bytestring input is guaranteed to be 64B in length 903 _parse_uncompressed :: Word8 -> BS.ByteString -> Maybe Projective 904 _parse_uncompressed h bs = do 905 let (unsafe_roll32 -> x, unsafe_roll32 -> y) = BS.splitAt _CURVE_Q_BYTES bs 906 guard (h == 0x04) 907 let !p = Projective (C.to x) (C.to y) 1 908 guard (valid p) 909 pure $! p 910 911 -- | Parse an ECDSA signature encoded in 64-byte "compact" form. 912 -- 913 -- >>> parse_sig <64-byte compact signature> 914 -- Just "<ecdsa signature>" 915 parse_sig :: BS.ByteString -> Maybe ECDSA 916 parse_sig bs = do 917 guard (BS.length bs == 64) 918 let (r0, s0) = BS.splitAt 32 bs 919 r <- roll32 r0 920 s <- roll32 s0 921 pure $! ECDSA r s 922 923 -- serializing ---------------------------------------------------------------- 924 925 -- | Serialize a secp256k1 point in 33-byte compressed form. 926 -- 927 -- >>> serialize_point pub 928 -- "<33-byte compressed point>" 929 serialize_point :: Projective -> BS.ByteString 930 serialize_point (affine -> Affine (C.from -> x) (C.from -> y)) = 931 let !(Wider (# Limb w, _, _, _ #)) = y 932 !b | B.testBit (GHC.Word.W# w) 0 = 0x03 933 | otherwise = 0x02 934 in BS.cons b (unroll32 x) 935 936 -- ecdh ----------------------------------------------------------------------- 937 938 -- SEC1-v2 3.3.1, plus SHA256 hash 939 940 -- | Compute a shared secret, given a secret key and public secp256k1 point, 941 -- via Elliptic Curve Diffie-Hellman (ECDH). 942 -- 943 -- The shared secret is the SHA256 hash of the x-coordinate of the 944 -- point obtained by scalar multiplication. 945 -- 946 -- >>> let sec_alice = 0x03 947 -- >>> let sec_bob = 2 ^ 128 - 1 948 -- >>> let Just pub_alice = derive_pub sec_alice 949 -- >>> let Just pub_bob = derive_pub sec_bob 950 -- >>> let secret_as_computed_by_alice = ecdh pub_bob sec_alice 951 -- >>> let secret_as_computed_by_bob = ecdh pub_alice sec_bob 952 -- >>> secret_as_computed_by_alice == secret_as_computed_by_bob 953 -- True 954 ecdh 955 :: Projective -- ^ public key 956 -> Wider -- ^ secret key 957 -> Maybe BS.ByteString -- ^ shared secret 958 ecdh pub _SECRET = do 959 pt@(P _ _ (C.Montgomery -> z)) <- mul pub _SECRET 960 let !(Affine (C.retr -> x) _) = affine pt 961 !result = SHA256.hash (unroll32 x) 962 if CT.decide (C.eq z 0) then Nothing else Just result 963 964 -- schnorr -------------------------------------------------------------------- 965 -- see https://github.com/bitcoin/bips/blob/master/bip-0340.mediawiki 966 967 -- | Create a 64-byte Schnorr signature for the provided message, using 968 -- the provided secret key. 969 -- 970 -- BIP0340 recommends that 32 bytes of fresh auxiliary entropy be 971 -- generated and added at signing time as additional protection 972 -- against side-channel attacks (namely, to thwart so-called "fault 973 -- injection" attacks). This entropy is /supplemental/ to security, 974 -- and the cryptographic security of the signature scheme itself does 975 -- not rely on it, so it is not strictly required; 32 zero bytes can 976 -- be used in its stead (and can be supplied via 'mempty'). 977 -- 978 -- >>> import qualified System.Entropy as E 979 -- >>> aux <- E.getEntropy 32 980 -- >>> sign_schnorr sec msg aux 981 -- Just "<64-byte schnorr signature>" 982 sign_schnorr 983 :: Wider -- ^ secret key 984 -> BS.ByteString -- ^ message 985 -> BS.ByteString -- ^ 32 bytes of auxilliary random data 986 -> Maybe BS.ByteString -- ^ 64-byte Schnorr signature 987 sign_schnorr = _sign_schnorr (mul _CURVE_G) 988 989 -- | The same as 'sign_schnorr', except uses a 'Context' to optimise 990 -- internal calculations. 991 -- 992 -- You can expect about a 2x performance increase when using this 993 -- function, compared to 'sign_schnorr'. 994 -- 995 -- >>> import qualified System.Entropy as E 996 -- >>> aux <- E.getEntropy 32 997 -- >>> let !tex = precompute 998 -- >>> sign_schnorr' tex sec msg aux 999 -- Just "<64-byte schnorr signature>" 1000 sign_schnorr' 1001 :: Context -- ^ secp256k1 context 1002 -> Wider -- ^ secret key 1003 -> BS.ByteString -- ^ message 1004 -> BS.ByteString -- ^ 32 bytes of auxilliary random data 1005 -> Maybe BS.ByteString -- ^ 64-byte Schnorr signature 1006 sign_schnorr' tex = _sign_schnorr (mul_wnaf tex) 1007 1008 _sign_schnorr 1009 :: (Wider -> Maybe Projective) -- partially-applied multiplication function 1010 -> Wider -- secret key 1011 -> BS.ByteString -- message 1012 -> BS.ByteString -- 32 bytes of auxilliary random data 1013 -> Maybe BS.ByteString 1014 _sign_schnorr _mul _SECRET m a = do 1015 p <- _mul _SECRET 1016 let Affine (C.retr -> x_p) (C.retr -> y_p) = affine p 1017 s = S.to _SECRET 1018 d = S.select s (negate s) (W.odd y_p) 1019 bytes_d = unroll32 (S.retr d) 1020 bytes_p = unroll32 x_p 1021 t = xor bytes_d (hash_aux a) 1022 rand = hash_nonce (t <> bytes_p <> m) 1023 k' = S.to (unsafe_roll32 rand) 1024 guard (not (S.eq_vartime k' 0)) -- negligible probability 1025 pt <- _mul (S.retr k') 1026 let Affine (C.retr -> x_r) (C.retr -> y_r) = affine pt 1027 k = S.select k' (negate k') (W.odd y_r) 1028 bytes_r = unroll32 x_r 1029 rand' = hash_challenge (bytes_r <> bytes_p <> m) 1030 e = S.to (unsafe_roll32 rand') 1031 bytes_ked = unroll32 (S.retr (k + e * d)) 1032 sig = bytes_r <> bytes_ked 1033 -- NB for benchmarking we morally want to remove the precautionary 1034 -- verification check here. 1035 -- 1036 -- guard (verify_schnorr m p sig) 1037 pure $! sig 1038 {-# INLINE _sign_schnorr #-} 1039 1040 -- | Verify a 64-byte Schnorr signature for the provided message with 1041 -- the supplied public key. 1042 -- 1043 -- >>> verify_schnorr msg pub <valid signature> 1044 -- True 1045 -- >>> verify_schnorr msg pub <invalid signature> 1046 -- False 1047 verify_schnorr 1048 :: BS.ByteString -- ^ message 1049 -> Pub -- ^ public key 1050 -> BS.ByteString -- ^ 64-byte Schnorr signature 1051 -> Bool 1052 verify_schnorr = _verify_schnorr (mul_vartime _CURVE_G) 1053 1054 -- | The same as 'verify_schnorr', except uses a 'Context' to optimise 1055 -- internal calculations. 1056 -- 1057 -- You can expect about a 1.5x performance increase when using this 1058 -- function, compared to 'verify_schnorr'. 1059 -- 1060 -- >>> let !tex = precompute 1061 -- >>> verify_schnorr' tex msg pub <valid signature> 1062 -- True 1063 -- >>> verify_schnorr' tex msg pub <invalid signature> 1064 -- False 1065 verify_schnorr' 1066 :: Context -- ^ secp256k1 context 1067 -> BS.ByteString -- ^ message 1068 -> Pub -- ^ public key 1069 -> BS.ByteString -- ^ 64-byte Schnorr signature 1070 -> Bool 1071 verify_schnorr' tex = _verify_schnorr (mul_wnaf tex) 1072 1073 _verify_schnorr 1074 :: (Wider -> Maybe Projective) -- partially-applied multiplication function 1075 -> BS.ByteString 1076 -> Pub 1077 -> BS.ByteString 1078 -> Bool 1079 _verify_schnorr _mul m p sig 1080 | BS.length sig /= 64 = False 1081 | otherwise = M.isJust $ do 1082 let capP = even_y_vartime p 1083 (unsafe_roll32 -> r, unsafe_roll32 -> s) = BS.splitAt 32 sig 1084 guard (fe r && ge s) 1085 let Affine (C.retr -> x_P) _ = affine capP 1086 e = modQ . unsafe_roll32 $ 1087 hash_challenge (unroll32 r <> unroll32 x_P <> m) 1088 pt0 <- _mul s 1089 pt1 <- mul_vartime capP e 1090 let dif = add pt0 (neg pt1) 1091 guard (dif /= _CURVE_ZERO) 1092 let Affine (C.from -> x_R) (C.from -> y_R) = affine dif 1093 guard $ not (CT.decide (W.odd y_R) || not (W.eq_vartime x_R r)) 1094 {-# INLINE _verify_schnorr #-} 1095 1096 -- hardcoded tag of BIP0340/aux 1097 -- 1098 -- \x -> let h = SHA256.hash "BIP0340/aux" 1099 -- in SHA256.hash (h <> h <> x) 1100 hash_aux :: BS.ByteString -> BS.ByteString 1101 hash_aux x = SHA256.hash $ 1102 "\241\239N^\192c\202\218m\148\202\250\157\152~\160i&X9\236\193\US\151-w\165.\216\193\204\144\241\239N^\192c\202\218m\148\202\250\157\152~\160i&X9\236\193\US\151-w\165.\216\193\204\144" <> x 1103 {-# INLINE hash_aux #-} 1104 1105 -- hardcoded tag of BIP0340/nonce 1106 hash_nonce :: BS.ByteString -> BS.ByteString 1107 hash_nonce x = SHA256.hash $ 1108 "\aIw4\167\155\203\&5[\155\140}\ETXO\DC2\FS\244\&4\215>\247-\218\EM\135\NULa\251R\191\235/\aIw4\167\155\203\&5[\155\140}\ETXO\DC2\FS\244\&4\215>\247-\218\EM\135\NULa\251R\191\235/" <> x 1109 {-# INLINE hash_nonce #-} 1110 1111 -- hardcoded tag of BIP0340/challenge 1112 hash_challenge :: BS.ByteString -> BS.ByteString 1113 hash_challenge x = SHA256.hash $ 1114 "{\181-z\159\239X2>\177\191z@}\179\130\210\243\242\216\ESC\177\"OI\254Q\143mH\211|{\181-z\159\239X2>\177\191z@}\179\130\210\243\242\216\ESC\177\"OI\254Q\143mH\211|" <> x 1115 {-# INLINE hash_challenge #-} 1116 1117 -- ecdsa ---------------------------------------------------------------------- 1118 -- see https://www.rfc-editor.org/rfc/rfc6979, https://secg.org/sec1-v2.pdf 1119 1120 -- RFC6979 2.3.2 1121 bits2int :: BS.ByteString -> Wider 1122 bits2int = unsafe_roll32 1123 {-# INLINABLE bits2int #-} 1124 1125 -- RFC6979 2.3.3 1126 int2octets :: Wider -> BS.ByteString 1127 int2octets = unroll32 1128 {-# INLINABLE int2octets #-} 1129 1130 -- RFC6979 2.3.4 1131 bits2octets :: BS.ByteString -> BS.ByteString 1132 bits2octets bs = 1133 let z1 = bits2int bs 1134 z2 = modQ z1 1135 in int2octets z2 1136 1137 -- | An ECDSA signature. 1138 data ECDSA = ECDSA { 1139 ecdsa_r :: !Wider 1140 , ecdsa_s :: !Wider 1141 } 1142 deriving (Generic) 1143 1144 instance Show ECDSA where 1145 show _ = "<ecdsa signature>" 1146 1147 -- ECDSA signature type. 1148 data SigType = 1149 LowS 1150 | Unrestricted 1151 deriving Show 1152 1153 -- Indicates whether to hash the message or assume it has already been 1154 -- hashed. 1155 data HashFlag = 1156 Hash 1157 | NoHash 1158 deriving Show 1159 1160 -- Convert an ECDSA signature to low-S form. 1161 low :: ECDSA -> ECDSA 1162 low (ECDSA r s) = ECDSA r (W.select s (_CURVE_Q - s) (W.gt s _CURVE_QH)) 1163 {-# INLINE low #-} 1164 1165 -- | Produce an ECDSA signature for the provided message, using the 1166 -- provided private key. 1167 -- 1168 -- 'sign_ecdsa' produces a "low-s" signature, as is commonly required 1169 -- in applications using secp256k1. If you need a generic ECDSA 1170 -- signature, use 'sign_ecdsa_unrestricted'. 1171 -- 1172 -- >>> sign_ecdsa sec msg 1173 -- Just "<ecdsa signature>" 1174 sign_ecdsa 1175 :: Wider -- ^ secret key 1176 -> BS.ByteString -- ^ message 1177 -> Maybe ECDSA 1178 sign_ecdsa = _sign_ecdsa (mul _CURVE_G) LowS Hash 1179 1180 -- | The same as 'sign_ecdsa', except uses a 'Context' to optimise internal 1181 -- calculations. 1182 -- 1183 -- You can expect about a 10x performance increase when using this 1184 -- function, compared to 'sign_ecdsa'. 1185 -- 1186 -- >>> let !tex = precompute 1187 -- >>> sign_ecdsa' tex sec msg 1188 -- Just "<ecdsa signature>" 1189 sign_ecdsa' 1190 :: Context -- ^ secp256k1 context 1191 -> Wider -- ^ secret key 1192 -> BS.ByteString -- ^ message 1193 -> Maybe ECDSA 1194 sign_ecdsa' tex = _sign_ecdsa (mul_wnaf tex) LowS Hash 1195 1196 -- | Produce an ECDSA signature for the provided message, using the 1197 -- provided private key. 1198 -- 1199 -- 'sign_ecdsa_unrestricted' produces an unrestricted ECDSA signature, 1200 -- which is less common in applications using secp256k1 due to the 1201 -- signature's inherent malleability. If you need a conventional 1202 -- "low-s" signature, use 'sign_ecdsa'. 1203 -- 1204 -- >>> sign_ecdsa_unrestricted sec msg 1205 -- Just "<ecdsa signature>" 1206 sign_ecdsa_unrestricted 1207 :: Wider -- ^ secret key 1208 -> BS.ByteString -- ^ message 1209 -> Maybe ECDSA 1210 sign_ecdsa_unrestricted = _sign_ecdsa (mul _CURVE_G) Unrestricted Hash 1211 1212 -- | The same as 'sign_ecdsa_unrestricted', except uses a 'Context' to 1213 -- optimise internal calculations. 1214 -- 1215 -- You can expect about a 10x performance increase when using this 1216 -- function, compared to 'sign_ecdsa_unrestricted'. 1217 -- 1218 -- >>> let !tex = precompute 1219 -- >>> sign_ecdsa_unrestricted' tex sec msg 1220 -- Just "<ecdsa signature>" 1221 sign_ecdsa_unrestricted' 1222 :: Context -- ^ secp256k1 context 1223 -> Wider -- ^ secret key 1224 -> BS.ByteString -- ^ message 1225 -> Maybe ECDSA 1226 sign_ecdsa_unrestricted' tex = _sign_ecdsa (mul_wnaf tex) Unrestricted Hash 1227 1228 -- Produce a "low-s" ECDSA signature for the provided message, using 1229 -- the provided private key. Assumes that the message has already been 1230 -- pre-hashed. 1231 -- 1232 -- (Useful for testing against noble-secp256k1's suite, in which messages 1233 -- in the test vectors have already been hashed.) 1234 _sign_ecdsa_no_hash 1235 :: Wider -- ^ secret key 1236 -> BS.ByteString -- ^ message digest 1237 -> Maybe ECDSA 1238 _sign_ecdsa_no_hash = _sign_ecdsa (mul _CURVE_G) LowS NoHash 1239 1240 _sign_ecdsa_no_hash' 1241 :: Context 1242 -> Wider 1243 -> BS.ByteString 1244 -> Maybe ECDSA 1245 _sign_ecdsa_no_hash' tex = _sign_ecdsa (mul_wnaf tex) LowS NoHash 1246 1247 _sign_ecdsa 1248 :: (Wider -> Maybe Projective) -- partially-applied multiplication function 1249 -> SigType 1250 -> HashFlag 1251 -> Wider 1252 -> BS.ByteString 1253 -> Maybe ECDSA 1254 _sign_ecdsa _mul ty hf _SECRET m = runST $ do 1255 -- RFC6979 sec 3.3a 1256 let entropy = int2octets _SECRET 1257 nonce = bits2octets h 1258 drbg <- DRBG.new SHA256.hmac entropy nonce mempty 1259 -- RFC6979 sec 2.4 1260 sign_loop drbg 1261 where 1262 d = S.to _SECRET 1263 hm = S.to (bits2int h) 1264 h = case hf of 1265 Hash -> SHA256.hash m 1266 NoHash -> m 1267 1268 sign_loop g = do 1269 k <- gen_k g 1270 let mpair = do 1271 kg <- _mul k 1272 let Affine (S.to . C.retr -> r) _ = affine kg 1273 ki = S.inv (S.to k) 1274 s = (hm + d * r) * ki 1275 pure $! (S.retr r, S.retr s) 1276 case mpair of 1277 Nothing -> pure Nothing 1278 Just (r, s) 1279 | W.eq_vartime r 0 -> sign_loop g -- negligible probability 1280 | otherwise -> 1281 let !sig = Just $! ECDSA r s 1282 in case ty of 1283 Unrestricted -> pure sig 1284 LowS -> pure (fmap low sig) 1285 {-# INLINE _sign_ecdsa #-} 1286 1287 -- RFC6979 sec 3.3b 1288 gen_k :: DRBG.DRBG s -> ST s Wider 1289 gen_k g = loop g where 1290 loop drbg = do 1291 bytes <- DRBG.gen mempty (fi _CURVE_Q_BYTES) drbg 1292 let can = bits2int bytes 1293 case W.cmp_vartime can _CURVE_Q of 1294 LT -> pure can 1295 _ -> loop drbg -- 2 ^ -128 probability 1296 {-# INLINE gen_k #-} 1297 1298 -- | Verify a "low-s" ECDSA signature for the provided message and 1299 -- public key, 1300 -- 1301 -- Fails to verify otherwise-valid "high-s" signatures. If you need to 1302 -- verify generic ECDSA signatures, use 'verify_ecdsa_unrestricted'. 1303 -- 1304 -- >>> verify_ecdsa msg pub valid_sig 1305 -- True 1306 -- >>> verify_ecdsa msg pub invalid_sig 1307 -- False 1308 verify_ecdsa 1309 :: BS.ByteString -- ^ message 1310 -> Pub -- ^ public key 1311 -> ECDSA -- ^ signature 1312 -> Bool 1313 verify_ecdsa m p sig@(ECDSA _ s) 1314 | CT.decide (W.gt s _CURVE_QH) = False 1315 | otherwise = verify_ecdsa_unrestricted m p sig 1316 1317 -- | The same as 'verify_ecdsa', except uses a 'Context' to optimise 1318 -- internal calculations. 1319 -- 1320 -- You can expect about a 2x performance increase when using this 1321 -- function, compared to 'verify_ecdsa'. 1322 -- 1323 -- >>> let !tex = precompute 1324 -- >>> verify_ecdsa' tex msg pub valid_sig 1325 -- True 1326 -- >>> verify_ecdsa' tex msg pub invalid_sig 1327 -- False 1328 verify_ecdsa' 1329 :: Context -- ^ secp256k1 context 1330 -> BS.ByteString -- ^ message 1331 -> Pub -- ^ public key 1332 -> ECDSA -- ^ signature 1333 -> Bool 1334 verify_ecdsa' tex m p sig@(ECDSA _ s) 1335 | CT.decide (W.gt s _CURVE_QH) = False 1336 | otherwise = verify_ecdsa_unrestricted' tex m p sig 1337 1338 -- | Verify an unrestricted ECDSA signature for the provided message and 1339 -- public key. 1340 -- 1341 -- >>> verify_ecdsa_unrestricted msg pub valid_sig 1342 -- True 1343 -- >>> verify_ecdsa_unrestricted msg pub invalid_sig 1344 -- False 1345 verify_ecdsa_unrestricted 1346 :: BS.ByteString -- ^ message 1347 -> Pub -- ^ public key 1348 -> ECDSA -- ^ signature 1349 -> Bool 1350 verify_ecdsa_unrestricted = _verify_ecdsa_unrestricted (mul_vartime _CURVE_G) 1351 1352 -- | The same as 'verify_ecdsa_unrestricted', except uses a 'Context' to 1353 -- optimise internal calculations. 1354 -- 1355 -- You can expect about a 2x performance increase when using this 1356 -- function, compared to 'verify_ecdsa_unrestricted'. 1357 -- 1358 -- >>> let !tex = precompute 1359 -- >>> verify_ecdsa_unrestricted' tex msg pub valid_sig 1360 -- True 1361 -- >>> verify_ecdsa_unrestricted' tex msg pub invalid_sig 1362 -- False 1363 verify_ecdsa_unrestricted' 1364 :: Context -- ^ secp256k1 context 1365 -> BS.ByteString -- ^ message 1366 -> Pub -- ^ public key 1367 -> ECDSA -- ^ signature 1368 -> Bool 1369 verify_ecdsa_unrestricted' tex = _verify_ecdsa_unrestricted (mul_wnaf tex) 1370 1371 _verify_ecdsa_unrestricted 1372 :: (Wider -> Maybe Projective) -- partially-applied multiplication function 1373 -> BS.ByteString 1374 -> Pub 1375 -> ECDSA 1376 -> Bool 1377 _verify_ecdsa_unrestricted _mul m p (ECDSA r0 s0) = M.isJust $ do 1378 -- SEC1-v2 4.1.4 1379 let h = SHA256.hash m 1380 guard (ge r0 && ge s0) 1381 let r = S.to r0 1382 s = S.to s0 1383 e = S.to (bits2int h) 1384 si = S.inv s 1385 u1 = S.retr (e * si) 1386 u2 = S.retr (r * si) 1387 pt0 <- _mul u1 1388 pt1 <- mul_vartime p u2 1389 let capR = add pt0 pt1 1390 guard (capR /= _CURVE_ZERO) 1391 let Affine (S.to . C.retr -> v) _ = affine capR 1392 guard (S.eq_vartime v r) 1393 {-# INLINE _verify_ecdsa_unrestricted #-} 1394