Secp256k1.hs (14329B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE DeriveGeneric #-} 3 {-# LANGUAGE DerivingStrategies #-} 4 {-# LANGUAGE MagicHash #-} 5 {-# LANGUAGE OverloadedStrings #-} 6 {-# LANGUAGE UnboxedSums #-} 7 {-# LANGUAGE ViewPatterns #-} 8 9 module Crypto.Secp256k1 where 10 11 import Control.Monad (when) 12 import Control.Monad.ST 13 import qualified Data.ByteString as BS 14 import qualified Data.ByteString.Base16 as B16 15 import Data.STRef 16 import GHC.Generics 17 import GHC.Natural 18 import qualified GHC.Num.Integer as I 19 import Prelude hiding (mod) 20 21 -- see https://www.secg.org/sec2-v2.pdf for parameter specs 22 23 -- secp256k1 field prime 24 -- 25 -- ~ 2^256 - 2^32 - 2^9 - 2^8 - 2^7 - 2^6 - 2^4 - 1 26 _CURVE_P :: Integer 27 _CURVE_P = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F 28 29 -- | Division modulo secp256k1 field prime. 30 modP :: Integer -> Integer 31 modP a = I.integerMod a _CURVE_P 32 33 -- secp256k1 group order 34 _CURVE_N :: Integer 35 _CURVE_N = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 36 37 -- smallest integer such that _CURVE_N < 2 ^ _CURVE_N_LEN 38 _CURVE_N_LEN :: Integer 39 _CURVE_N_LEN = 256 40 41 -- bytelength of _CURVE_N 42 _CURVE_N_BYTES :: Int 43 _CURVE_N_BYTES = 32 44 45 -- secp256k1 short weierstrass form, /a/ coefficient 46 _CURVE_A :: Integer 47 _CURVE_A = 0 48 49 -- secp256k1 weierstrass form, /b/ coefficient 50 _CURVE_B :: Integer 51 _CURVE_B = 7 52 53 -- point in affine coordinates 54 data Affine = Affine !Integer !Integer 55 deriving stock (Show, Generic) 56 57 instance Eq Affine where 58 Affine x1 y1 == Affine x2 y2 = 59 modP x1 == modP x2 && modP y1 == modP y2 60 61 -- point in projective coordinates 62 data Projective = Projective { 63 px :: !Integer 64 , py :: !Integer 65 , pz :: !Integer 66 } 67 deriving stock (Show, Generic) 68 69 instance Eq Projective where 70 Projective ax ay az == Projective bx by bz = 71 let x1z2 = modP (ax * bz) 72 x2z1 = modP (bx * az) 73 y1z2 = modP (ay * bz) 74 y2z1 = modP (by * az) 75 in x1z2 == x2z1 && y1z2 == y2z1 76 77 -- secp256k1 generator 78 -- 79 -- ~ parse "0279BE667EF9DCBBAC55A06295CE870B07029BFCDB2DCE28D959F2815B16F81798" 80 _CURVE_G :: Projective 81 _CURVE_G = Projective x y 1 where 82 x = 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 83 y = 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8 84 85 -- secp256k1 zero point 86 _ZERO :: Projective 87 _ZERO = Projective 0 1 0 88 89 -- | Division modulo secp256k1 group order. 90 modN :: Integer -> Integer 91 modN a = I.integerMod a _CURVE_N 92 93 -- | Is field element. 94 fe :: Integer -> Bool 95 fe n = 0 < n && n < _CURVE_P 96 97 -- | Is group element. 98 ge :: Integer -> Bool 99 ge n = 0 < n && n < _CURVE_N 100 101 -- modular inverse 102 -- for a, m return x such that ax = 1 mod m 103 modinv :: Integer -> Natural -> Maybe Integer 104 modinv a m = case I.integerRecipMod# a m of 105 (# fromIntegral -> n | #) -> Just n 106 (# | _ #) -> Nothing 107 108 -- modular square root (shanks-tonelli) 109 -- for a, m return x such that a = xx mod m 110 modsqrt :: Integer -> Maybe Integer 111 modsqrt n = runST $ do 112 r <- newSTRef 1 113 num <- newSTRef n 114 e <- newSTRef ((_CURVE_P + 1) `div` 4) 115 loop r num e 116 rr <- readSTRef r 117 pure $ 118 if modP (rr * rr) == n 119 then Just rr 120 else Nothing 121 where 122 loop sr snum se = do 123 e <- readSTRef se 124 when (e > 0) $ do 125 when (I.integerTestBit e 0) $ do 126 num <- readSTRef snum 127 modifySTRef' sr (\lr -> (lr * num) `rem` _CURVE_P) 128 modifySTRef' snum (\ln -> (ln * ln) `rem` _CURVE_P) 129 modifySTRef' se (`I.integerShiftR` 1) 130 loop sr snum se 131 132 -- prime order j-invariant 0 (i.e. a == 0) 133 weierstrass :: Integer -> Integer 134 weierstrass x = modP (modP (x * x) * x + _CURVE_B) 135 136 -- negate point 137 neg :: Projective -> Projective 138 neg (Projective x y z) = Projective x (modP (negate y)) z 139 140 -- general ec addition 141 add :: Projective -> Projective -> Projective 142 add p q@(Projective _ _ z) 143 | p == q = double p -- algo 9 144 | z == 1 = add_mixed p q -- algo 8 145 | otherwise = add_proj p q -- algo 7 146 147 -- algo 7, "complete addition formulas for prime order elliptic curves," 148 -- renes et al, 2015 149 add_proj :: Projective -> Projective -> Projective 150 add_proj (Projective x1 y1 z1) (Projective x2 y2 z2) = runST $ do 151 x3 <- newSTRef 0 152 y3 <- newSTRef 0 153 z3 <- newSTRef 0 154 let b3 = modP (_CURVE_B * 3) 155 t0 <- newSTRef (modP (x1 * x2)) -- 1 156 t1 <- newSTRef (modP (y1 * y2)) 157 t2 <- newSTRef (modP (z1 * z2)) 158 t3 <- newSTRef (modP (x1 + y1)) -- 4 159 t4 <- newSTRef (modP (x2 + y2)) 160 readSTRef t4 >>= \r4 -> 161 modifySTRef' t3 (\r3 -> modP (r3 * r4)) 162 readSTRef t0 >>= \r0 -> 163 readSTRef t1 >>= \r1 -> 164 writeSTRef t4 (modP (r0 + r1)) 165 readSTRef t4 >>= \r4 -> 166 modifySTRef' t3 (\r3 -> modP (r3 - r4)) -- 8 167 writeSTRef t4 (modP (y1 + z1)) 168 writeSTRef x3 (modP (y2 + z2)) 169 readSTRef x3 >>= \rx3 -> 170 modifySTRef' t4 (\r4 -> modP (r4 * rx3)) 171 readSTRef t1 >>= \r1 -> 172 readSTRef t2 >>= \r2 -> 173 writeSTRef x3 (modP (r1 + r2)) -- 12 174 readSTRef x3 >>= \rx3 -> 175 modifySTRef' t4 (\r4 -> modP (r4 - rx3)) 176 writeSTRef x3 (modP (x1 + z1)) 177 writeSTRef y3 (modP (x2 + z2)) 178 readSTRef y3 >>= \ry3 -> 179 modifySTRef' x3 (\rx3 -> modP (rx3 * ry3)) -- 16 180 readSTRef t0 >>= \r0 -> 181 readSTRef t2 >>= \r2 -> 182 writeSTRef y3 (modP (r0 + r2)) 183 readSTRef x3 >>= \rx3 -> 184 modifySTRef' y3 (\ry3 -> modP (rx3 - ry3)) 185 readSTRef t0 >>= \r0 -> 186 writeSTRef x3 (modP (r0 + r0)) 187 readSTRef x3 >>= \rx3 -> 188 modifySTRef t0 (\r0 -> modP (rx3 + r0)) -- 20 189 modifySTRef' t2 (\r2 -> modP (b3 * r2)) 190 readSTRef t1 >>= \r1 -> 191 readSTRef t2 >>= \r2 -> 192 writeSTRef z3 (modP (r1 + r2)) 193 readSTRef t2 >>= \r2 -> 194 modifySTRef' t1 (\r1 -> modP (r1 - r2)) 195 modifySTRef' y3 (\ry3 -> modP (b3 * ry3)) -- 24 196 readSTRef t4 >>= \r4 -> 197 readSTRef y3 >>= \ry3 -> 198 writeSTRef x3 (modP (r4 * ry3)) 199 readSTRef t3 >>= \r3 -> 200 readSTRef t1 >>= \r1 -> 201 writeSTRef t2 (modP (r3 * r1)) 202 readSTRef t2 >>= \r2 -> 203 modifySTRef' x3 (\rx3 -> modP (r2 - rx3)) 204 readSTRef t0 >>= \r0 -> 205 modifySTRef' y3 (\ry3 -> modP (ry3 * r0)) -- 28 206 readSTRef z3 >>= \rz3 -> 207 modifySTRef' t1 (\r1 -> modP (r1 * rz3)) 208 readSTRef t1 >>= \r1 -> 209 modifySTRef' y3 (\ry3 -> modP (r1 + ry3)) 210 readSTRef t3 >>= \r3 -> 211 modifySTRef' t0 (\r0 -> modP (r0 * r3)) 212 readSTRef t4 >>= \r4 -> 213 modifySTRef' z3 (\rz3 -> modP (rz3 * r4)) -- 32 214 readSTRef t0 >>= \r0 -> 215 modifySTRef' z3 (\rz3 -> modP (rz3 + r0)) 216 Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3 217 218 -- algo 8, renes et al, 2015 219 add_mixed :: Projective -> Projective -> Projective 220 add_mixed (Projective x1 y1 z1) (Projective x2 y2 z2) 221 | z2 /= 1 = error "ppad-secp256k1: internal error" 222 | otherwise = runST $ do 223 x3 <- newSTRef 0 224 y3 <- newSTRef 0 225 z3 <- newSTRef 0 226 let b3 = modP (_CURVE_B * 3) 227 t0 <- newSTRef (modP (x1 * x2)) -- 1 228 t1 <- newSTRef (modP (y1 * y2)) 229 t3 <- newSTRef (modP (x2 + y2)) 230 t4 <- newSTRef (modP (x1 + y1)) -- 4 231 readSTRef t4 >>= \r4 -> 232 modifySTRef' t3 (\r3 -> modP (r3 * r4)) 233 readSTRef t0 >>= \r0 -> 234 readSTRef t1 >>= \r1 -> 235 writeSTRef t4 (modP (r0 + r1)) 236 readSTRef t4 >>= \r4 -> 237 modifySTRef' t3 (\r3 -> modP (r3 - r4)) -- 7 238 writeSTRef t4 (modP (y2 * z1)) 239 modifySTRef' t4 (\r4 -> modP (r4 + y1)) 240 writeSTRef y3 (modP (x2 * z1)) -- 10 241 modifySTRef' y3 (\ry3 -> modP (ry3 + x1)) 242 readSTRef t0 >>= \r0 -> 243 writeSTRef x3 (modP (r0 + r0)) 244 readSTRef x3 >>= \rx3 -> 245 modifySTRef' t0 (\r0 -> modP (rx3 + r0)) -- 13 246 t2 <- newSTRef (modP (b3 * z1)) 247 readSTRef t1 >>= \r1 -> 248 readSTRef t2 >>= \r2 -> 249 writeSTRef z3 (modP (r1 + r2)) 250 readSTRef t2 >>= \r2 -> 251 modifySTRef' t1 (\r1 -> modP (r1 - r2)) -- 16 252 modifySTRef' y3 (\ry3 -> modP (b3 * ry3)) 253 readSTRef t4 >>= \r4 -> 254 readSTRef y3 >>= \ry3 -> 255 writeSTRef x3 (modP (r4 * ry3)) 256 readSTRef t3 >>= \r3 -> 257 readSTRef t1 >>= \r1 -> 258 writeSTRef t2 (modP (r3 * r1)) -- 19 259 readSTRef t2 >>= \r2 -> 260 modifySTRef' x3 (\rx3 -> modP (r2 - rx3)) 261 readSTRef t0 >>= \r0 -> 262 modifySTRef' y3 (\ry3 -> modP (ry3 * r0)) 263 readSTRef z3 >>= \rz3 -> 264 modifySTRef' t1 (\r1 -> modP (r1 * rz3)) -- 22 265 readSTRef t1 >>= \r1 -> 266 modifySTRef' y3 (\ry3 -> modP (r1 + ry3)) 267 readSTRef t3 >>= \r3 -> 268 modifySTRef' t0 (\r0 -> modP (r0 * r3)) 269 readSTRef t4 >>= \r4 -> 270 modifySTRef' z3 (\rz3 -> modP (rz3 * r4)) -- 25 271 readSTRef t0 >>= \r0 -> 272 modifySTRef' z3 (\rz3 -> modP (rz3 + r0)) 273 Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3 274 275 -- algo 9, renes et al, 2015 276 double :: Projective -> Projective 277 double (Projective x y z) = runST $ do 278 x3 <- newSTRef 0 279 y3 <- newSTRef 0 280 z3 <- newSTRef 0 281 let b3 = modP (_CURVE_B * 3) 282 t0 <- newSTRef (modP (y * y)) -- 1 283 readSTRef t0 >>= \r0 -> 284 writeSTRef z3 (modP (r0 + r0)) 285 modifySTRef' z3 (\rz3 -> modP (rz3 + rz3)) 286 modifySTRef' z3 (\rz3 -> modP (rz3 + rz3)) -- 4 287 t1 <- newSTRef (modP (y * z)) 288 t2 <- newSTRef (modP (z * z)) 289 modifySTRef t2 (\r2 -> modP (b3 * r2)) -- 7 290 readSTRef z3 >>= \rz3 -> 291 readSTRef t2 >>= \r2 -> 292 writeSTRef x3 (modP (r2 * rz3)) 293 readSTRef t0 >>= \r0 -> 294 readSTRef t2 >>= \r2 -> 295 writeSTRef y3 (modP (r0 + r2)) 296 readSTRef t1 >>= \r1 -> 297 modifySTRef' z3 (\rz3 -> modP (r1 * rz3)) -- 10 298 readSTRef t2 >>= \r2 -> 299 writeSTRef t1 (modP (r2 + r2)) 300 readSTRef t1 >>= \r1 -> 301 modifySTRef' t2 (\r2 -> modP (r1 + r2)) 302 readSTRef t2 >>= \r2 -> 303 modifySTRef' t0 (\r0 -> modP (r0 - r2)) -- 13 304 readSTRef t0 >>= \r0 -> 305 modifySTRef' y3 (\ry3 -> modP (r0 * ry3)) 306 readSTRef x3 >>= \rx3 -> 307 modifySTRef' y3 (\ry3 -> modP (rx3 + ry3)) 308 writeSTRef t1 (modP (x * y)) -- 16 309 readSTRef t0 >>= \r0 -> 310 readSTRef t1 >>= \r1 -> 311 writeSTRef x3 (modP (r0 * r1)) 312 modifySTRef' x3 (\rx3 -> modP (rx3 + rx3)) 313 Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3 314 315 -- ec scalar multiplication 316 mul :: Projective -> Integer -> Projective 317 mul p n 318 | n == 0 = _ZERO 319 | not (ge n) = error "ppad-secp256k1 (mul): scalar not in group" 320 | otherwise = loop _ZERO p n 321 where 322 loop !r !d m 323 | m <= 0 = r 324 | otherwise = 325 let nd = double d 326 nm = I.integerShiftR m 1 327 nr = if I.integerTestBit m 0 then add r d else r 328 in loop nr nd nm 329 330 -- XX confirm timing safety 331 mul_safe :: Projective -> Integer -> Projective 332 mul_safe p n 333 | not (ge n) = error "ppad-secp256k1 (mul_safe): scalar not in group" 334 | otherwise = loop _ZERO _CURVE_G p n 335 where 336 loop !r !f !d m 337 | m <= 0 = r 338 | otherwise = 339 let nd = double d 340 nm = I.integerShiftR m 1 341 in if I.integerTestBit m 0 342 then loop (add r d) f nd nm 343 else loop r (add f d) nd nm 344 345 -- | Convert to affine coordinates. 346 affine :: Projective -> Affine 347 affine p@(Projective x y z) 348 | p == _ZERO = Affine 0 0 349 | z == 1 = Affine x y 350 | otherwise = case modinv z (fromIntegral _CURVE_P) of 351 Nothing -> error "ppad-secp256k1 (affine): impossible point" 352 Just iz -> Affine (modP (x * iz)) (modP (y * iz)) 353 354 -- | Convert to projective coordinates. 355 projective :: Affine -> Projective 356 projective (Affine x y) 357 | x == 0 && y == 0 = _ZERO 358 | otherwise = Projective x y 1 359 360 -- | Point is valid 361 valid :: Projective -> Bool 362 valid p = case affine p of 363 Affine x y 364 | not (fe x) || not (fe y) -> False 365 | modP (y * y) /= weierstrass x -> False 366 | otherwise -> True 367 368 -- | Parse hex-encoded compressed or uncompressed point. 369 parse :: BS.ByteString -> Maybe Projective 370 parse (B16.decode -> ebs) = case ebs of 371 Left _ -> Nothing 372 Right bs -> case BS.uncons bs of 373 Nothing -> Nothing 374 Just (fromIntegral -> h, t) -> 375 let (roll -> x, etc) = BS.splitAt _CURVE_N_BYTES t 376 len = BS.length bs 377 in -- compressed 378 if len == 33 && (h == 0x02 || h == 0x03) 379 then if not (fe x) 380 then Nothing 381 else do 382 y <- modsqrt (weierstrass x) 383 let yodd = I.integerTestBit y 0 384 hodd = I.integerTestBit h 0 385 pure $ 386 if hodd /= yodd 387 then Projective x (modP (negate y)) 1 388 else Projective x y 1 389 else -- uncompressed 390 if len == 65 && h == 0x04 391 then let (roll -> y, _) = BS.splitAt _CURVE_N_BYTES etc 392 p = Projective x y 1 393 in if valid p 394 then Just p 395 else Nothing 396 else Nothing 397 398 -- big-endian bytestring decoding 399 roll :: BS.ByteString -> Integer 400 roll = BS.foldl' unstep 0 where 401 unstep a (fromIntegral -> b) = (a `I.integerShiftL` 8) `I.integerOr` b 402 403 -- big-endian bytestring encoding 404 unroll :: Integer -> BS.ByteString 405 unroll i = case i of 406 0 -> BS.singleton 0 407 _ -> BS.reverse $ BS.unfoldr step i 408 where 409 step 0 = Nothing 410 step m = Just (fromIntegral m, m `I.integerShiftR` 8) 411 412 -- RFC6979 413 bits2int :: BS.ByteString -> Integer 414 bits2int bs = 415 let (fromIntegral -> blen) = BS.length bs * 8 416 (fromIntegral -> qlen) = _CURVE_N_LEN -- RFC6979 notation 417 del = blen - qlen 418 in if del > 0 419 then roll bs `I.integerShiftR` del 420 else roll bs 421 422 -- RFC6979 423 int2octets :: Integer -> BS.ByteString 424 int2octets i = pad (unroll i) where 425 pad !bs 426 | BS.length bs < _CURVE_N_BYTES = pad (BS.cons 0 bs) 427 | otherwise = bs 428 429 -- RFC6979 430 bits2octets :: BS.ByteString -> BS.ByteString 431 bits2octets bs = 432 let z1 = bits2int bs 433 z2 = modN z1 434 in int2octets z2 435 436 -- XX handle low-s 437 sign :: BS.ByteString -> Integer -> Integer -> (Integer, Integer) 438 sign (modN . bits2int -> h) k x = 439 let kg = mul _CURVE_G k 440 Affine (modN -> r) _ = affine kg 441 s = case modinv k (fromIntegral _CURVE_N) of 442 Nothing -> error "ppad-secp256k1 (sign): bad k value" 443 Just kinv -> modN (modN (h + modN (x * r)) * kinv) 444 in if r == 0 445 then error "ppad-secp256k1 (sign): <negligible probability outcome>" 446 else (r, s) 447 448 -- XX test 449 450 test_h1 :: BS.ByteString 451 test_h1 = B16.decodeLenient 452 "AF2BDBE1AA9B6EC1E2ADE1D694F41FC71A831D0268E9891562113D8A62ADD1BF" 453 454 test_x :: Integer 455 test_x = 0x09A4D6792295A7F730FC3F2B49CBC0F62E862272F 456