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