diff --git a/bench-secp256k1/Main.hs b/bench-secp256k1/Main.hs new file mode 100644 index 0000000..fb8412b --- /dev/null +++ b/bench-secp256k1/Main.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module: Main +-- Copyright: Copyright © 2023 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- TODO +-- +module Main +( main +) where + +import Control.DeepSeq + +import Criterion +import Criterion.Main + +-- internal modules + +import Crypto.Secp256k1.Internal + +-- -------------------------------------------------------------------------- -- +-- Orphans + +instance NFData Point where + rnf (Point x y) = x `seq` y `seq` () + rnf O = () + +-- -------------------------------------------------------------------------- -- +-- Main + +-- randomZm :: IO M n +-- randomZm = bytesToZm <$> getEntropy 32 + +fn1, fn2 :: Fn +fn1 = fn 0xa1cc7887c498a8d4e948be34e9645b2db144dbc4dedb9aedda98c999d97a29ff +fn2 = fn 0x287ab1a7e15775383bf4ac0df141a72d457b39bb2bf9bbe394fd62da26e633cf + +fp1 :: Fp +fp1 = fp 0x62995dd98b44b6524410c296ede3dbd80660d0fc9a8750bfd183ca815420e962 +-- fp2 :: Fp +-- fp2 = fp 0xc46d0f0d64e22dfb204db3af660ed82c108eec13392dcce8aac41315454317a3 + +p1 :: Point +p1 = getPublicKey fn1 + +main :: IO () +main = defaultMain + [ bgroup "sqrtFp" + [ bench "sqrtFp1" $ whnf sqrtFp1 fp1 + , bench "sqrtFp2" $ whnf sqrtFp2 fp1 + , bench "sqrtFp3" $ whnf sqrtFp3 fp1 + ] + , env (return p1) $ \ ~p -> + bgroup "multP" + [ bench "montgomeryMult" $ whnf (montgomeryMult fn2) p + , bench "doubleAndAdd" $ whnf (doubleAndAdd (nat fn2)) p + ] + ] diff --git a/ethereum.cabal b/ethereum.cabal index 8c7da3c..4754b55 100644 --- a/ethereum.cabal +++ b/ethereum.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: ethereum version: 0.1.0.1 synopsis: Ethereum related Datatypes and Algorithms @@ -8,15 +8,16 @@ license: BSD-3-Clause license-file: LICENSE author: Lars Kuhtz maintainer: lakuhtz@gmail.com -copyright: Copyright (c) 2020-2022 Kadena LLC. +copyright: Copyright (c) 2020-2023 Kadena LLC. category: Data tested-with: - GHC==9.2.4 - GHC==9.0.2 - GHC==8.10.7 + , GHC==9.4.2 + , GHC==9.2.4 + , GHC==9.0.2 + , GHC==8.10.7 extra-source-files: - README.md - CHANGELOG.md + , README.md + , CHANGELOG.md source-repository head type: git @@ -29,12 +30,73 @@ flag openssl-use-pkg-config common openssl-common c-sources: - cbits/prime.c + , cbits/prime.c if flag(openssl-use-pkg-config) pkgconfig-depends: libcrypto else extra-Libraries: crypto +-- -------------------------------------------------------------------------- -- +-- Internal Library secp256k1 + +library secp256k1 + hs-source-dirs: src-secp256k1 + default-language: Haskell2010 + ghc-options: + -Wall + exposed-modules: + , Crypto.Secp256k1 + , Crypto.Secp256k1.Internal + build-depends: + , base >=4.11 && <5 + , bytestring >=0.11.3 + , exceptions >=0.10 + , text >=1.2 + if impl(ghc < 9.0.0) + build-depends: + , integer-gmp >=1.0.3 + +test-suite secp256k1-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test-secp256k1 + other-modules: + , Test.Crypto.Secp256k1.Internal + ghc-options: + -Wall + -threaded + -with-rtsopts=-N + main-is: Main.hs + build-depends: + , secp256k1 + + , QuickCheck >=2.14 + , base >=4.11 && <5 + , bytestring >=0.11.3 + , entropy >=0.4 + , hashes >=0.2.3 + , quickcheck-instances >=0.3 + , tasty >=1.3 + , tasty-quickcheck >=0.10 + +benchmark secp256k1-benchmarks + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench-secp256k1 + ghc-options: + -Wall + -threaded + -with-rtsopts=-N + main-is: Main.hs + build-depends: + , secp256k1 + , base >=4.11 && <5 + , criterion >=1.6 + , deepseq >=1.4 + +-- -------------------------------------------------------------------------- -- +-- Library + library import: openssl-common hs-source-dirs: src @@ -42,22 +104,22 @@ library ghc-options: -Wall exposed-modules: - Ethereum.Block - Ethereum.Ethhash - Ethereum.Ethhash.CacheSizes - Ethereum.Ethhash.DataSizes - Ethereum.HP - Ethereum.HP.Internal - Ethereum.Header - Ethereum.Misc - Ethereum.RLP - Ethereum.Receipt - Ethereum.Receipt.ReceiptProof - Ethereum.Transaction - Ethereum.Trie - Ethereum.Utils + , Ethereum.Block + , Ethereum.Ethhash + , Ethereum.Ethhash.CacheSizes + , Ethereum.Ethhash.DataSizes + , Ethereum.HP + , Ethereum.HP.Internal + , Ethereum.Header + , Ethereum.Misc + , Ethereum.RLP + , Ethereum.Receipt + , Ethereum.Receipt.ReceiptProof + , Ethereum.Transaction + , Ethereum.Trie + , Ethereum.Utils - Numeric.Checked + , Numeric.Checked build-depends: , base >=4.11 && <5 , aeson >=1.4.5 @@ -79,15 +141,15 @@ test-suite ethereum-tests default-language: Haskell2010 hs-source-dirs: test other-modules: - Test.Ethereum.Block - Test.Ethereum.Ethhash - Test.Ethereum.HP - -- Test.Ethereum.Header - Test.Ethereum.RLP - Test.Ethereum.Receipt - Test.Ethereum.Trie - Test.Orphans - Test.Utils + , Test.Ethereum.Block + , Test.Ethereum.Ethhash + , Test.Ethereum.HP + -- , Test.Ethereum.Header + , Test.Ethereum.RLP + , Test.Ethereum.Receipt + , Test.Ethereum.Trie + , Test.Orphans + , Test.Utils ghc-options: -Wall -threaded diff --git a/src-secp256k1/Crypto/Secp256k1.hs b/src-secp256k1/Crypto/Secp256k1.hs new file mode 100644 index 0000000..a7678d9 --- /dev/null +++ b/src-secp256k1/Crypto/Secp256k1.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module: Crypto.Secp256k1 +-- Copyright: Copyright © 2023 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Crypto.Secp256k1 +( EcdsaPublicKey +, ecdsaPublicKey +, ecdsaPublicKeyBytes +, EcdsaMessageDigest +, ecdsaMessageDigest +, EcdsaR +, ecdsaR +, EcdsaS +, ecdsaS +, ecdsaVerify +, ecdsaRecoverPublicKey +) where + +import Control.Monad +import Control.Monad.Catch + +import qualified Data.ByteString.Short as BS +import qualified Data.Text as T + +import Numeric.Natural + +-- internal modules + +import Crypto.Secp256k1.Internal + +-- -------------------------------------------------------------------------- -- +-- Exceptions + +newtype EcdsaException = EcdsaException T.Text + deriving (Show, Eq, Ord) + +instance Exception EcdsaException + +-- -------------------------------------------------------------------------- -- +-- Utils + +checkLength :: MonadThrow m => T.Text -> Natural -> BS.ShortByteString -> m BS.ShortByteString +checkLength label n bs + | l > n = throwM $ EcdsaException $ + label <> ".checkLength: input too long. Expected " <> sshow n <> " but got " <> sshow l <> " bytes." + | l < n = throwM $ EcdsaException $ + label <> ".checkLength: input too short. Expected " <> sshow n <> " but got " <> sshow l <> " bytes." + | otherwise = return bs + where + l = int $ BS.length bs + +pointToBytes :: Point -> BS.ShortByteString +pointToBytes (Point x y) = BS.cons 0x04 (fpToShortBytes x <> fpToShortBytes y) +pointToBytes O = BS.pack [0x00] + +publicKeyPointFromBytes :: MonadThrow m => BS.ShortByteString -> m Point +publicKeyPointFromBytes (BS.unpack -> [0x00]) = throwM $ EcdsaException + "pointFromBytes: point of infinity can't be used as public key" +publicKeyPointFromBytes bs = do + void $ checkLength "pointFrombBytes" 65 bs + (x, y) <- case BS.uncons bs of + Just (0x04, r) -> return $ BS.splitAt 32 r + Just (x, _) -> throwM $ EcdsaException $ + "pointFromBytes: unsupported encoding. Expected 0x04 (uncomporessed point), but got " <> sshow x + Nothing -> error "pointFromBytes: missing first byte of input" + -- can't happend because we check that input is of length 65 + + case maybePublicKey (shortBytesToFp x) (shortBytesToFp y) of + Nothing -> throwM $ EcdsaException + "pointFromBytes: invalid public key. Coordinates are not a point on the curve" + Just p -> return p + +-- -------------------------------------------------------------------------- -- +-- Public API + +newtype EcdsaPublicKey = EcdsaPublicKey Point +newtype EcdsaMessageDigest = EcdsaMessageDigest Fn +newtype EcdsaR = EcdsaR Fn +newtype EcdsaS = EcdsaS Fn + +-- | Input: 65 bytes that represent an uncompressed (prefix 0x04) secp256k1 +-- curve point. +-- +ecdsaPublicKey :: MonadThrow m => BS.ShortByteString -> m EcdsaPublicKey +ecdsaPublicKey = fmap EcdsaPublicKey . publicKeyPointFromBytes + +-- | Returns 65 bytes that represent a public key encoded as uncompressed +-- secp256k1 curve point. +-- +ecdsaPublicKeyBytes :: EcdsaPublicKey -> BS.ShortByteString +ecdsaPublicKeyBytes (EcdsaPublicKey p) = pointToBytes p + +-- | Input: 32 bytes that represent a message digest. +-- +-- It is expected that the digest is produced by a cryptographic hash functions +-- that produceds digests of at least 32 bytes. If the original digest has more +-- than 32 bytes the input should contain only the leftmost 32 bytes (assuming +-- that security of the hash is distributed uniformily accross all bits of the +-- original digest). +-- +ecdsaMessageDigest :: MonadThrow m => BS.ShortByteString -> m EcdsaMessageDigest +ecdsaMessageDigest = fmap (EcdsaMessageDigest . shortBytesToFn) + . checkLength "EcdsaMessageDigest" 32 + +-- | Input: 32 byte long R value of the secp256k1 ECDSA signature +-- +ecdsaR :: MonadThrow m => BS.ShortByteString -> m EcdsaR +ecdsaR = fmap (EcdsaR . shortBytesToFn) . checkLength "ecdsaR" 32 + +-- | Input: 32 byte long S value of the secp256k1 ECDSA signature +-- +ecdsaS :: MonadThrow m => BS.ShortByteString -> m EcdsaS +ecdsaS = fmap (EcdsaS . shortBytesToFn) . checkLength "ecdsaS" 32 + +ecdsaVerify + :: MonadThrow m + => EcdsaMessageDigest + -- ^ A 32 bytes long message digest that was compute with the same hash + -- function that was used for producing the signature. + -> EcdsaPublicKey + -- ^ The public key of the signer encoded as 65 byte long uncompressed + -- curve point. + -> EcdsaR + -- ^ The R value of the input signature + -> EcdsaS + -- ^ The S value of the input singature + -> m Bool +ecdsaVerify (EcdsaMessageDigest d) (EcdsaPublicKey p) (EcdsaR r) (EcdsaS s) = + case verify d r s p of + Left t -> throwM $ EcdsaException t + Right b -> return b + +ecdsaRecoverPublicKey + :: EcdsaMessageDigest + -- ^ A 32 bytes long message digest that was compute with the same hash + -- function that was used for producing the signature. + -> EcdsaR + -- ^ The R value of the input signature + -> EcdsaS + -- ^ The S value of the input singature + -> Bool + -- ^ whether parity of the public recovered public key is odd. + -- + -- If you don't know this parameter it is safe to try both options, at + -- the cost of taking on average 1.5 times more computation time to + -- compute the result. + -> Bool + -- ^ whether the second solution for the public key is returned. This + -- parameter is almost surely always @False@. + -- + -- If you don't know this value it is safe to assume that it is @False@. + -- + -> Maybe EcdsaPublicKey +ecdsaRecoverPublicKey (EcdsaMessageDigest d) (EcdsaR r) (EcdsaS s) oddY secondKey = + EcdsaPublicKey <$> recoverPublicKey d r s oddY secondKey + diff --git a/src-secp256k1/Crypto/Secp256k1/Internal.hs b/src-secp256k1/Crypto/Secp256k1/Internal.hs new file mode 100644 index 0000000..547c7b8 --- /dev/null +++ b/src-secp256k1/Crypto/Secp256k1/Internal.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | +-- Module: Crypto.Secp256k1.Internal +-- Copyright: Copyright © 2023 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Low-Level implementation of Secp256k1 ECDSA signature verification with +-- public key recovery. +-- +-- Implementation is based on http://www.secg.org/sec1-v2.pdf +-- +-- Only operations that do not involve private key material are implemented. +-- +module Crypto.Secp256k1.Internal +( +-- * Modulo Arithmethic + Zm +, pattern Zm +, zm +, nat +, byteLength +, bitLength +, (.+) +, (.-) +, (.*) +, (./) +, (.^) +, minusM +, invM +, isOddM +, zConv +, bytesToZm +, shortBytesToZm +, zmToBytes +, zmToShortBytes + +-- * Prime Field for curve Secp256k1 + +, type PC +, Fp +, pattern Fp +, fp +, bytesToFp +, shortBytesToFp +, fpToBytes +, fpToShortBytes +, sqrtFp +, sqrtFp1 +, sqrtFp2 +, sqrtFp3 + +-- * Order of curve Secp256k1 + +, type NC +, Fn +, pattern Fn +, fn +, bytesToFn +, shortBytesToFn +, fnToBytes +, fnToShortBytes + +-- * Elliptic curve points for Secp256k1 + +, Point(O) +, pattern Point + +-- ** Curve Secp256k1 +, pC +, nC +, gC +, hC +, aC +, bC + +-- * Arithmetic for Weierstrass curves +, (.+.) +, (.-.) +, (.*.) +, (*.) +, minusP +, montgomeryMult +, doubleAndAdd +, pointFromX +, isOnCurve +, maybePoint +, point + +-- * ECDSA for Secp256k1 +, verify +, recoverPublicKey +, validatePublicKey +, validateSecretKey +, getPublicKey +, maybePublicKey + +-- ** Printing +, zm2hex +, zm2hex_ +, hex2zm +, hex2zm_ +, p2hex + +-- ** Miscelaneous +, int +, natVal_ +, intVal_ +, sshow +, bytesToNat +, natToBytes +, shortBytesToNat +) where + +import Control.Monad + +import Data.Bits (Bits, shiftL, testBit) +import qualified Data.ByteString as B +import qualified Data.ByteString.Short as BS +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Read as T +import Data.Word + +import GHC.Natural (powModNatural, Natural) +import GHC.Stack +import qualified GHC.TypeLits as I (KnownNat, natVal') +import GHC.TypeNats (KnownNat, natVal') +#if ! MIN_VERSION_base(4,16,0) +import GHC.TypeNats (Nat) +#endif + +import Text.Printf + +#if MIN_VERSION_base(4,15,0) +import GHC.Num (integerRecipMod#, integerLog2) +#else +import GHC.Exts (Int(..)) +import GHC.Integer.GMP.Internals (recipModInteger) +import GHC.Integer.Logarithms (integerLog2#) +#endif + +import GHC.Exts (Proxy#, proxy#) + +-- -------------------------------------------------------------------------- -- +-- Operators + +infixl 6 .+, .-, .+., .-. +infixl 7 .*, ./, .*., *. +infixr 8 .^ + +-- -------------------------------------------------------------------------- -- +-- Utils + +#if MIN_VERSION_base(4,16,0) +type Nat = Natural +#endif + +#if ! MIN_VERSION_base(4,15,0) +integerLog2 :: Integer -> Int +integerLog2 x = case integerLog2# x of a -> I# a +#endif + +int :: Integral a => Num b => a -> b +int = fromIntegral +{-# INLINE int #-} + +natVal_ :: forall n . KnownNat n => Natural +natVal_ = natVal' (proxy# :: Proxy# n) +{-# INLINE natVal_ #-} + +intVal_ :: forall n . I.KnownNat n => Integer +intVal_ = I.natVal' (proxy# :: Proxy# n) +{-# INLINE intVal_ #-} + +bitLength_ :: Natural -> Int +bitLength_ 0 = 0 +bitLength_ n = int $ integerLog2 (int $ n - 1) + 1 + +bitLength :: forall n . KnownNat n => Int +bitLength = bitLength_ (natVal_ @n) + +byteLength_ :: Natural -> Int +byteLength_ n = (bitLength_ n - 1) `div` 8 + 1 + +byteLength :: forall n . KnownNat n => Int +byteLength = byteLength_ (natVal_ @n) + +sshow :: Show a => IsString b => a -> b +sshow = fromString . show +{-# INLINE sshow #-} + +-- Big Endian Encodings: +-- +-- The implementation is not optimized + +shortBytesToNat :: BS.ShortByteString -> Natural +shortBytesToNat = BS.foldl' (\a b -> shiftL a 8 + int b) 0 + +bytesToNat :: B.ByteString -> Natural +bytesToNat = B.foldl' (\a b -> shiftL a 8 + int b) 0 + +-- | The first parameter determines the length in bytes of the result +-- The result is either padded with zero bytes or truncated. +-- +natToShortBytes + :: Int + -> Natural + -> BS.ShortByteString +natToShortBytes l = BS.pack . natToBytesInternal l + + +-- | The first parameter determines the length in bytes of the result +-- The result is either padded with zero bytes or truncated. +-- +natToBytes + :: Int + -> Natural + -> B.ByteString +natToBytes l = B.pack . natToBytesInternal l + +natToBytesInternal + :: Int + -> Natural + -> [Word8] +natToBytesInternal l n = go l n [] + where + go 0 _ = id + go !i m = let (a, b) = quotRem m 256 in go (i - 1) a . (int b :) + +-- -------------------------------------------------------------------------- -- +-- Arithmetic modulo n + +-- | Modulo Rings +-- +-- The constructor should not be used directly. +-- +-- For constructing values use one of the provided smart constructors. For +-- pattern use one of the provided pattern synonyms or the @nat@ function. +-- +-- +newtype M (n :: Nat) = M Natural + deriving (Eq, Ord) + deriving newtype (Bits) + +instance KnownNat n => Show (M n) where + show = zm2hex + +type Zm = M +pattern Zm :: Natural -> M n +pattern Zm n <- M n +{-# COMPLETE Zm #-} + +zm :: forall n . KnownNat n => Natural -> M n +zm a = M $! a `rem` (natVal_ @n) + +-- | Convert an element of a modulo ring to a natural number +-- +nat :: M n -> Natural +nat (M a) = a + +bytesToZm :: forall n . KnownNat n => B.ByteString -> Zm n +bytesToZm = zm . bytesToNat . B.take (byteLength @n) + +shortBytesToZm :: forall n . KnownNat n => BS.ShortByteString -> Zm n +shortBytesToZm = zm . shortBytesToNat . BS.take (byteLength @n) + +zmToBytes :: forall n . KnownNat n => Zm n -> B.ByteString +zmToBytes = natToBytes (byteLength @n) . nat + +zmToShortBytes :: forall n . KnownNat n => Zm n -> BS.ShortByteString +zmToShortBytes = natToShortBytes (byteLength @n) . nat + +(.+) :: KnownNat n => M n -> M n -> M n +(M a) .+ (M b) = zm (a + b) + +minusM :: forall n . KnownNat n => M n -> M n +minusM (M 0) = M 0 +minusM (M a) = M (natVal_ @n - a) + +(.-) :: KnownNat n => M n -> M n -> M n +a .- b = a .+ minusM b + +(.*) :: KnownNat n => M n -> M n -> M n +(M a) .* (M b) = zm (a * b) + +invM :: forall n . HasCallStack => KnownNat n => M n -> M n +invM (M 0) = M $! div 0 0 +#if MIN_VERSION_base(4,15,0) +invM (M a) = M $! case integerRecipMod# (int a) (natVal_ @n) of + (# n | #)-> n + (# | () #) -> error "integerRecipMod#: no result" +#else +invM (M a) = M $! int (recipModInteger (int a) (intVal_ @n)) +#endif + +(./) :: HasCallStack => KnownNat n => M n -> M n -> M n +_ ./ (M 0) = M $! div 0 0 +a ./ b = a .* invM b + +(.^) :: forall n . KnownNat n => M n -> Natural -> M n +(.^) (M a) n = M $! powModNatural a n (natVal_ @n) + +zConv :: KnownNat m => Zm n -> Zm m +zConv (M n) = zm n + +isOddM :: M n -> Bool +isOddM (M a) = a `rem` 2 == 1 + +-- -------------------------------------------------------------------------- -- +-- | Prime of curve Secp256k1 +-- +type PC :: Nat +type PC = 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f + +-- | Prime Field for Curve Secp256k1 +-- +type Fp = M PC + +pattern Fp :: Natural -> Fp +pattern Fp n <- M n +{-# COMPLETE Fp #-} + +fp :: Natural -> Fp +fp = zm + +bytesToFp :: B.ByteString -> Fp +bytesToFp = bytesToZm + +shortBytesToFp :: BS.ShortByteString -> Fp +shortBytesToFp = fp . shortBytesToNat . BS.take 32 + +fpToBytes :: Fp -> B.ByteString +fpToBytes = zmToBytes + +fpToShortBytes :: Fp -> BS.ShortByteString +fpToShortBytes = zmToShortBytes + +-- -------------------------------------------------------------------------- -- +-- | Order of curve Secp256k1 +-- +type NC :: Nat +type NC = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 + +-- | Modulo arithmetic over the order of curve Secp256k1 +-- +type Fn = M NC + +pattern Fn :: Natural -> Fn +pattern Fn n <- M n +{-# COMPLETE Fn #-} + +fn :: Natural -> Fn +fn = zm + +bytesToFn :: B.ByteString -> Fn +bytesToFn = bytesToZm + +shortBytesToFn :: BS.ShortByteString -> Fn +shortBytesToFn = fn . shortBytesToNat . BS.take 32 + +fnToBytes :: Fn -> B.ByteString +fnToBytes = zmToBytes + +fnToShortBytes :: Fn -> BS.ShortByteString +fnToShortBytes = zmToShortBytes + +-- -------------------------------------------------------------------------- -- +-- Solving Quadratic Resdiue in in F_p + +-- Benchmarks indicate that sqrt1 and sqrt2 perform similar. Sqrt3 is slightly +-- slower. + +-- | Quadratic residue +-- +sqrtFp :: Fp -> (Bool, Fp) +sqrtFp = sqrtFp1 + +sqrtFp1 :: Fp -> (Bool, Fp) +sqrtFp1 a = (r .^ 2 == a, r) + where + r = a .^ ((pC + 1) `quot` 4) + +-- +sqrtFp2 :: Fp -> (Bool, Fp) +sqrtFp2 a = (r .^ 2 == a, r) + where + r = (a .^ ((pC + 1) `quot` 8)) .^ 2 + +-- | Source of the follwoing algorith is th scp256k1 C library. +-- +sqrtFp3 :: Fp -> (Bool, Fp) +sqrtFp3 a = (r .^ 2 == a, r) + where + x2 = a .^ p2 1 .* a + x3 = x2 .^ p2 1 .* a + x6 = x3 .^ p2 3 .* x3 + x9 = x6 .^ p2 3 .* x3 + x11 = x9 .^ p2 2 .* x2 + x22 = x11 .^ p2 11 .* x11 + x44 = x22 .^ p2 22 .* x22 + x88 = x44 .^ p2 44 .* x44 + x176 = x88 .^ p2 88 .* x88 + x220 = x176 .^ p2 44 .* x44 + x223 = x220 .^ p2 3 .* x3 + t1 = ((x223 .^ p2 23 .* x22) .^ p2 6 .* x2) .^ 2 + r = t1 .^ 2 + + p2 :: Int -> Natural + p2 = (2 ^) + +-- -------------------------------------------------------------------------- -- +-- Points on the Curve Secp256k1 + +-- | Eliptic Curve Points +-- +data Point = O | P !Fp !Fp + deriving (Show, Eq, Ord) + +-- | Accessor for the coordicates of a Point +-- +-- @O@ is exported as constructor +-- +pattern Point :: Fp -> Fp -> Point +pattern Point x y <- P x y +{-# COMPLETE O, Point #-} + +-- -------------------------------------------------------------------------- -- +-- Secp256k1 Curve Parameters +-- +-- \(y^2 = x^3 + aC * x + bC \) over the finite prime Field \(F_{pC}\) +-- +-- with parameters \( (pC,aC,bC,GC,nC,hC) \) defined as follows. +-- +-- Note that \(a\) is zero. +-- +-- cf. https://www.secg.org/sec2-v2.pdf, 2.4.1 +-- + +-- | Characteristic @p@ +-- +-- \( 2^{256} - 2^{32} - 2^9 - 2^8 - 2^7 - 2^6 - 2^4 - 1 \) +-- +pC :: Natural +pC = 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f + +-- | Coefficient @a@ +-- +aC :: Fp +aC = fp 0x0 + +-- | Coefficient @b@ +-- +bC :: Fp +bC = fp 0x7 + +-- | x coordinate @G_x@ of base point @G@ +-- +gCx :: Fp +gCx = fp 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 + +-- | y coordinate @G_y@ of base pont @G@ +-- +gCy :: Fp +gCy = fp 0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8 + +-- | Base point @G@ +-- +gC :: Point +gC = P gCx gCy + +-- | Order @n@. +-- +-- Because @h = order(Curve)/order(G) = 1@ it is both the order of the curve and +-- of the base point @G@. +-- +nC :: Natural +nC = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 + +-- | Cofactor @h@. Because this is 1, the order of the curve and the base point +-- are the same. I.e. @aG@, for @a=0,1,...@ covers all points on the curve. +-- +hC :: Natural +hC = 0x1 + +-- -------------------------------------------------------------------------- -- +-- Arithmetic on Weirstrass Curves + +-- | Point Addition +-- +(.+.) :: Point -> Point -> Point +(.+.) a O = a +(.+.) O a = a + +-- distinct points (which are not additive inverse of each other) +-- +(.+.) (P x1 y1) (P x2 y2) | x1 /= x2 = P x3 y3 + where + l = (y2 .- y1) ./ (x2 .- x1) + x3 = ((l .^ 2) .- x1) .- x2 + y3 = (l .* (x1 .- x3)) .- y1 + +-- doubling +-- +(.+.) (P x1 y1) (P _x2 y2) | y1 == y2 && y1 /= M 0 = P x3 y3 + where + l = ((M 3 .* (x1 .^ 2)) .+ aC) ./ (M 2 .* y1) + x3 = (l .^ 2) .- (M 2 .* x1) + y3 = (l .* (x1 .- x3)) .- y1 + +-- inverse points (y1 == -y2) +-- +(.+.) _ _ = O + +minusP :: Point -> Point +minusP O = O +minusP (P ax ay) = P ax (minusM ay) + +(.-.) :: Point -> Point -> Point +a .-. b = a .+. minusP b + +-- | Point multiplication by field element. +-- +(.*.) :: Fn -> Point -> Point +(.*.) = montgomeryMult + +-- montgomeryMult is only slightly slower than doubleAndAdd. + +-- | Point multiplication by integral element. +-- +(*.) :: Natural -> Point -> Point +(*.) = doubleAndAdd + +-- | Compute curve point from a scalar by multiplying with the generator. +-- This covers the whole curve for curves with cofactor of 1. +-- +point :: Fn -> Point +point x = x .*. gC + +maybePoint :: Fp -> Fp -> Maybe Point +maybePoint x y = if isOnCurve p then Just p else Nothing + where + p = P x y + +isOnCurve :: Point -> Bool +isOnCurve O = True +isOnCurve (P x y) = x .^ 3 .+ x .* aC .+ bC == y .^ 2 + +doubleAndAdd :: Natural -> Point -> Point +doubleAndAdd n p + | n < 0 = minusP $ (-n) *. p + | n == 0 = O + | n == 1 = p + | even n = p' + | otherwise = p .+. p' + where + p' = doubleAndAdd (div n 2) (p .+. p) + +-- | Montomery Ladder for scalar multiplication of curve points +-- +-- Less vulnerable against timing attacks +-- +montgomeryMult :: forall n . KnownNat n => Zm n -> Point -> Point +montgomeryMult n = go (bitLength @n - 1) O + where + go (-1) r0 _ = r0 + go m r0 r1 + | testBit n m = go (m - 1) (r0 .+. r1) (r1 .+. r1) + | otherwise = go (m - 1) (r0 .+. r0) (r0 .+. r1) + +-- -------------------------------------------------------------------------- -- +-- Public Keys for Secp256k1 + +-- | It is assumed that the caller guarantees that x and y are elements of F. +-- +validatePublicKey :: Point -> Bool +validatePublicKey O = False +validatePublicKey pk = checkOrder && isOnCurve pk + where + checkOrder = nC *. pk == O -- Is this needed for secp256k1? + +validateSecretKey :: Fn -> Bool +validateSecretKey (Fn a) = 0 < a && a < nC + +getPublicKey :: Fn -> Point +getPublicKey sk = sk .*. gC + +maybePublicKey :: Fp -> Fp -> Maybe Point +maybePublicKey x y = if validatePublicKey p then Just p else Nothing + where + p = P x y + +-- | Point decompression for curve Secp256k1 +-- +pointFromX :: Fp -> Bool -> Maybe Point +pointFromX x oddY = P x <$> case sqrtFp ys of + (True, y) -> Just $ if oddY == isOddM y then y else minusM y + (False, _) -> Nothing -- invalid point + where + ys = x .^ 3 .+ aC .* x .+ bC + -- equivalent: ys = x .^ 3 .+ bC for secp256k1 + +-- -------------------------------------------------------------------------- -- +-- Secp256k1 ECDSA Signatur verification + +-- | Lowlevel ECDSA signature validatio for curve Secp256k1. +-- +verify + :: Fn + -- ^ Message Digest + -> Fn + -- ^ r + -> Fn + -- ^ s + -> Point + -- ^ public key + -> Either T.Text Bool +verify e r s pk + | not (validatePublicKey pk) = Left "invalid public key" + | otherwise = case rP of + -- O -> Right False + O -> Left "got point at infinity during signature verification" + P (Zm xr) _ -> Right $ zm xr == r + where + u1 = e .* is + u2 = r .* is + rP = u1 .*. gC .+. u2 .*. pk -- TODO use Shamir's algorithm to make this more efficient + is = invM s + +-- | Recover public key for curve Secp256k1. +-- +-- The chance that `secondKey` is needed (i.e. there are two solution for the x +-- coordinate) is one in \(2^{128}\). Do we need to cover that case or can we just +-- ignore it? Could ignoring it lead to attacks on the chain? We don't know how +-- to test that case. +-- +-- The arithmethic in this function can be optimized. For instance cf. +-- https://github.com/indutny/elliptic/blob/43ac7f230069bd1575e1e4a58394a512303ba803/lib/elliptic/ec/index.js#L196 +-- +recoverPublicKey + :: Fn + -- ^ Message Digest + -> Fn + -- ^ r + -> Fn + -- ^ s + -> Bool + -- ^ odd Y + -> Bool + -- ^ is second key + -> Maybe Point +recoverPublicKey e r s oddY secondKey = case nC *. rP of + O -> if validatePublicKey pk then Just pk else Nothing + _ -> error "something went wrong (probably the value for second key is incorrect)" + where + x = if secondKey then zConv r .+ fp nC else zConv r + Just rP = pointFromX x oddY -- FIXME this fails for an invalid @secondKey@ value + pk = invM r .*. (s .*. rP .-. e .*. gC) + +-- -------------------------------------------------------------------------- -- +-- Hexdecimal Representation + +-- | In the contex of Ethereum points are always stored uncompressed, which +-- is indicated by prefixing them with 0x4. +-- +-- uncrompressedPointPrefix :: Word8 +-- uncrompressedPointPrefix = 0x4 + +zm2hex_ :: forall n s . KnownNat n => IsString s => Zm n -> s +zm2hex_ (Zm n) = fromString $ printf @(Natural -> String) format n + where + format = "%0" <> show (byteLength @n * 2) <> "x" + +zm2hex :: forall n s . KnownNat n => IsString s => Zm n -> s +zm2hex (Zm n) = fromString $ printf @(Natural -> String) format n + where + format = "0x%0" <> show (byteLength @n * 2) <> "x" + +hex2zm_ :: forall n . KnownNat n => T.Text -> Either T.Text (Zm n) +hex2zm_ t + | T.length t == byteLength @n * 2 = case T.hexadecimal t of + Right (x, "") -> Right $ zm x + Right (x, _) -> Left $ "pending characters after parsing " <> sshow x + Left e -> Left (T.pack e) + | otherwise = Left $ "Wrong input length: expected " <> sshow (byteLength @n * 2) <> ", got " <> sshow (T.length t) + +hex2zm :: forall n . KnownNat n => T.Text -> Either T.Text (Zm n) +hex2zm = strip0x >=> hex2zm_ + +strip0x :: T.Text -> Either T.Text T.Text +strip0x t = case T.stripPrefix "0x" t of + Just x -> Right x + Nothing -> Left $ "Missing hex prefix 0x in " <> t +{-# INLINE strip0x #-} + +p2hex :: IsString s => Point -> s +p2hex O = "0x00" +p2hex (P x y) = fromString $ "0x4" <> zm2hex_ x <> zm2hex_ y + diff --git a/src/Ethereum/Transaction.hs b/src/Ethereum/Transaction.hs index 211d081..6a8b1b5 100644 --- a/src/Ethereum/Transaction.hs +++ b/src/Ethereum/Transaction.hs @@ -18,7 +18,6 @@ module Ethereum.Transaction ( -- * ECDSA EcdsaSignature(..) -, secp256k1n -- * Misc , TransactionData(..) @@ -58,14 +57,11 @@ data EcdsaSignature = EcdsaSignature { _sigV :: !Word8 -- ^ \(v ∈ {27, 28}\) , _sigR :: !(BytesN 32) - -- ^ \(0 < r < secp256k1n\) + -- ^ \(0 < r < secp256k1 n\) , _sigS :: !(BytesN 32) - -- ^ \(0 < s < secp256k1n÷2+1\) + -- ^ \(0 < s < secp256k1 n÷2+1\) } -secp256k1n :: Natural -secp256k1n = 115792089237316195423570985008687907852837564279074904382605163141518161494337 - -- -------------------------------------------------------------------------- -- -- diff --git a/test-secp256k1/Main.hs b/test-secp256k1/Main.hs new file mode 100644 index 0000000..d551397 --- /dev/null +++ b/test-secp256k1/Main.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: Main +-- Copyright: Copyright © 2023 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- TODO +-- +module Main +( main +) where + +import Test.Tasty + +-- internal modules + +import qualified Test.Crypto.Secp256k1.Internal + +-- -------------------------------------------------------------------------- -- +-- Main + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Crypto.Secp256k1" + [ Test.Crypto.Secp256k1.Internal.tests + ] diff --git a/test-secp256k1/Test/Crypto/Secp256k1/Internal.hs b/test-secp256k1/Test/Crypto/Secp256k1/Internal.hs new file mode 100644 index 0000000..6162971 --- /dev/null +++ b/test-secp256k1/Test/Crypto/Secp256k1/Internal.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module: Test.Crypto.Secp256k1.Internal +-- Copyright: Copyright © 2023 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Test.Crypto.Secp256k1.Internal +( tests +) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Short as BS +import Data.Coerce +import Data.Hash.SHA3 + +import GHC.TypeNats + +import System.Entropy + +import Test.QuickCheck hiding (Fn) +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.QuickCheck + +-- internal modules + +import Crypto.Secp256k1.Internal + +-- -------------------------------------------------------------------------- -- +-- Examples +-- -------------------------------------------------------------------------- -- + +sk1, h1, r1, s1 :: Fn +sk1 = fn 0xebb2c082fd7727890a28ac82f6bdf97bad8de9f5d7c9028692de1a255cad3e0f +h1 = fn 0x4b688df40bcedbe641ddb16ff0a1842d9c67ea1c3bf63f3e0471baa664531d1a +r1 = fn 0x241097efbf8b63bf145c8961dbdf10c310efbb3b2676bbc0f8b08505c9e2f795 +s1 = fn 0x021006b7838609339e8b415a7f9acb1b661828131aef1ecbc7955dfb01f3ca0e +pkx1, pky1 :: Fp +pkx1 = fp 0x779dd197a5df977ed2cf6cb31d82d43328b790dc6b3b7d4437a427bd5847dfcd +pky1 = fp 0xe94b724a555b6d017bb7607c3e3281daf5b1699d6ef4124975c9237b917d426f +pk1 :: Point +pk1 = case maybePublicKey pkx1 pky1 of + Just p -> p + Nothing -> error "invalid key" + +test_1_verify :: Property +test_1_verify = verify h1 r1 s1 pk1 === Right True + +test_1_recover :: Property +test_1_recover = recoverPublicKey h1 r1 s1 False False === Just pk1 + +properties_example1 :: TestTree +properties_example1 = testGroup "example1" + [ testProperty "test_1_verify" test_1_verify + , testProperty "test_1_recover" test_1_recover + ] + +sk2, k2, h2, r2, s2 :: Fn +sk2 = fn 0xebb2c082fd7727890a28ac82f6bdf97bad8de9f5d7c9028692de1a255cad3e0f +k2 = fn 0x49a0d7b786ec9cde0d0721d72804befd06571c974b191efb42ecf322ba9ddd9a +h2 = fn 0x4b688df40bcedbe641ddb16ff0a1842d9c67ea1c3bf63f3e0471baa664531d1a +r2 = fn 0x241097efbf8b63bf145c8961dbdf10c310efbb3b2676bbc0f8b08505c9e2f795 +s2 = fn 0x021006b7838609339e8b415a7f9acb1b661828131aef1ecbc7955dfb01f3ca0e + +-- -------------------------------------------------------------------------- -- +-- Tests Tools +-- -------------------------------------------------------------------------- -- +-- +-- DO NOT use any of the following code in production. + +genSecretKey :: IO Fn +genSecretKey = bytesToFn <$> getEntropy 32 + +genKey :: IO (Fn, Point) +genKey = do + sk <- genSecretKey + return (sk, sk .*. gC) + +-- | +-- +-- https://www.secg.org/sec1-v2.pdf, 4.1.3: +-- +-- The publicly verifiable criteria that r may be conditioned to satisfy may +-- include that xR is uniquely recoverable from r in that only one of the +-- integers \(xR = r + jn\) for \(j ∈ {0, 1, 2, ..., h}\) represents a valid +-- x-coordinate of a multiple of G. For the recommended curves [SEC 2] with h = +-- 1 and h = 2, the number of valid candidate x-coordinates is usually one, so +-- this is a vacuous check. +-- +-- "Usually" here means something like always except for one out of \(2^{128}\). +-- However, in the context of a public blockchain, an attack may be able to +-- fabricate a respective signature and cause diverging behavior between +-- validating nodes with different implementations for handling this corner +-- case. Although, creating such an attack may be infeasible. +-- +-- For the meaning of the y-parity bit see: +-- +-- https://eips.ethereum.org/EIPS/eip-2098 +-- +-- For testing purposes it would be useful to implement (pure) deterministic +-- signing (https://www.rfc-editor.org/rfc/rfc6979#section-3) +-- +sign + :: Fn + -- ^ secret key + -> Fn + -- ^ message digest + -> IO (Fn, Fn, Bool, Bool) + -- ^ (r, s, isOddY, isSecondKey) +sign sk e = do + k <- genSecretKey + let (Point xr yr) = getPublicKey k + r = zConv xr + if r == fn 0 + then sign sk e -- start over + else do + let s_ = invM k .* (e .+ r .* sk) + s = if s_ > halfN then minusM s_ else s_ + if s == fn 0 + then sign sk e -- start over + else do + let isSecondKey = nat xr < (pC - nC) + isOddY = isOddM yr == (s_ == s) + return (r, s, isOddY, isSecondKey) + where + halfN = fn $ nC `quot` 2 + +hashMsg :: forall h . Hash h => Coercible h BS.ShortByteString => B.ByteString -> Fn +hashMsg msg + | BS.length h < 32 = error "digest of hash function is too short" + | otherwise = shortBytesToFn (BS.take 32 h) + where + h = coerce (hashByteString @h msg) + +-- -------------------------------------------------------------------------- -- +-- ECDSA Properties + +prop_ecdsa_verify :: Int -> Property +prop_ecdsa_verify msg = ioProperty $ do + (sk, pk) <- genKey + (r, s, isOddY, isSecondKey) <- sign sk msgDigest + return + $ classify isOddY "isOddY" + $ classify isSecondKey "isSecondKey" + $ verify msgDigest r s pk === Right True + where + msgDigest = hashMsg @Sha3_256 $ B8.pack $ show msg + +prop_ecdsa_recover :: Int -> Property +prop_ecdsa_recover msg = ioProperty $ do + (sk, pk) <- genKey + (r, s, isOddY, isSecondKey) <- sign sk msgDigest + return + $ classify isOddY "isOddY" + $ classify isSecondKey "isSecondKey" + $ counterexample ("sk: " <> show sk) + $ counterexample ("msgDigest: " <> show msgDigest) + $ counterexample ("isOddY: " <> show isOddY) + $ counterexample ("isSecondKey: " <> show isSecondKey) + $ counterexample ("r: " <> show r) + $ counterexample ("s: " <> show s) + $ recoverPublicKey msgDigest r s isOddY isSecondKey === Just pk + where + msgDigest = hashMsg @Sha3_256 $ B8.pack $ show msg + +properties_ecdsa :: TestTree +properties_ecdsa = testGroup "ECDSA" + [ testProperty "prop_ecdsa_verify" prop_ecdsa_verify + , testProperty "prop_ecdsa_recover" prop_ecdsa_recover + ] + +-- -------------------------------------------------------------------------- -- +-- Prime Field + +instance KnownNat n => Arbitrary (Zm n) where + arbitrary = zm <$> arbitrary + +-- Properties of Addition + +prop_Zm_add_assoc :: forall n . KnownNat n => Zm n -> Zm n -> Zm n -> Property +prop_Zm_add_assoc a b c = (a .+ b) .+ c === a .+ (b .+ c) + +prop_Zm_add_comm :: forall n . KnownNat n => Zm n -> Zm n -> Property +prop_Zm_add_comm a b = (a .+ b) === (b .+ a) + +prop_Zm_add_neutral_r :: forall n . KnownNat n => Zm n -> Property +prop_Zm_add_neutral_r a = a .+ zm 0 === a + +prop_Zm_add_neutral_l :: forall n . KnownNat n => Zm n -> Property +prop_Zm_add_neutral_l a = zm 0 .+ a === a + +prop_Zm_add_inverse_r :: forall n . KnownNat n => Zm n -> Property +prop_Zm_add_inverse_r a = a .+ minusM a === zm 0 + +prop_Zm_add_inverse_l :: forall n . KnownNat n => Zm n -> Property +prop_Zm_add_inverse_l a = minusM a .+ a === zm 0 + +prop_Zm_add_dual_r :: forall n . KnownNat n => Zm n -> Zm n -> Property +prop_Zm_add_dual_r a b = (a .- b) .+ b === a + +prop_Zm_add_dual_l :: forall n . KnownNat n => Zm n -> Zm n -> Property +prop_Zm_add_dual_l a b = b .+ (a .- b) === a + +-- Properties of Multiplication + +prop_Zm_mul_assoc :: forall n . KnownNat n => Zm n -> Zm n -> Zm n -> Property +prop_Zm_mul_assoc a b c = (a .* b) .* c === a .* (b .* c) + +prop_Zm_mul_comm :: forall n . KnownNat n => Zm n -> Zm n -> Property +prop_Zm_mul_comm a b = (a .* b) === b .* a + +prop_Zm_mul_neutral_r :: forall n . KnownNat n => Zm n -> Property +prop_Zm_mul_neutral_r a = a .* zm 1 === a + +prop_Zm_mul_neutral_l :: forall n . KnownNat n => Zm n -> Property +prop_Zm_mul_neutral_l a = zm 1 .* a === a + +-- This is a bit tricky because @f 0 ./ f 0 === f 0@ due to short cut semantics +-- in the definition of multiplication. We may want to change that. +-- +prop_Zm_mul_inverse_r :: forall n . KnownNat n => Zm n -> Property +prop_Zm_mul_inverse_r a = a /= zm 0 ==> a .* invM a === zm 1 + +prop_Zm_mul_inverse_l :: forall n . KnownNat n => Zm n -> Property +prop_Zm_mul_inverse_l a = a /= zm 0 ==> invM a .* a === zm 1 + +prop_Zm_mul_dual_r :: forall n . KnownNat n => Zm n -> Zm n -> Property +prop_Zm_mul_dual_r a b = b > zm 0 ==> (a ./ b) .* b === a + +prop_Zm_mul_dual_l :: forall n . KnownNat n => Zm n -> Zm n -> Property +prop_Zm_mul_dual_l a b = b > zm 0 ==> b .* (a ./ b) === a + +properties_Zm :: forall n . KnownNat n => String -> TestTree +properties_Zm l = testGroup ("Zm " <> l <> " (" <> show (natVal_ @n) <> ")") + -- additive properties + [ testProperty "prop_Zm_add_assoc" (prop_Zm_add_assoc @n) + , testProperty "prop_Zm_add_comm" (prop_Zm_add_comm @n) + , testProperty "prop_Zm_add_neutral_r" (prop_Zm_add_neutral_r @n) + , testProperty "prop_Zm_add_neutral_l" (prop_Zm_add_neutral_l @n) + , testProperty "prop_Zm_add_inverse_r" (prop_Zm_add_inverse_r @n) + , testProperty "prop_Zm_add_inverse_l" (prop_Zm_add_inverse_l @n) + , testProperty "prop_Zm_add_dual_r" (prop_Zm_add_dual_r @n) + , testProperty "prop_Zm_add_dual_l" (prop_Zm_add_dual_l @n) + + -- multiplicative properties + , testProperty "prop_Zm_mul_assoc" (prop_Zm_mul_assoc @n) + , testProperty "prop_Zm_mul_comm" (prop_Zm_mul_comm @n) + , testProperty "prop_Zm_mul_neutral_r" (prop_Zm_mul_neutral_r @n) + , testProperty "prop_Zm_mul_neutral_l" (prop_Zm_mul_neutral_l @n) + , testProperty "prop_Zm_mul_inverse_r" (prop_Zm_mul_inverse_r @n) + , testProperty "prop_Zm_mul_inverse_l" (prop_Zm_mul_inverse_l @n) + , testProperty "prop_Zm_mul_dual_r" (prop_Zm_mul_dual_r @n) + , testProperty "prop_Zm_mul_dual_l" (prop_Zm_mul_dual_l @n) + ] + +properties_Fp :: TestTree +properties_Fp = properties_Zm @PC "p" + +properties_Fn :: TestTree +properties_Fn = properties_Zm @NC "n" + +-- -------------------------------------------------------------------------- -- +-- Prime field + +-- Square and Square Root + +prop_F_sqr :: Fp -> Property +prop_F_sqr a = a .^ 2 === minusM a .^ 2 + +prop_F_sqrt0 :: Fp -> Property +prop_F_sqrt0 a = sqrtFp a === sqrtFp2 a .&&. sqrtFp a === sqrtFp3 a + +prop_F_sqrt1 :: Fp -> Property +prop_F_sqrt1 a = case sqrtFp a of + (True, b) -> b .^ 2 === a + (False, b) -> b .^ 2 === minusM a + +properties_Fp_sqrt :: TestTree +properties_Fp_sqrt = testGroup "Fp sqrt" + [ testProperty "prop_F_sqr" prop_F_sqr + , testProperty "prop_F_sqrt0" prop_F_sqrt0 + , testProperty "prop_F_sqrt1" prop_F_sqrt1 + ] + +-- -------------------------------------------------------------------------- -- +-- Curve Points + +instance Arbitrary Point where + arbitrary = frequency + [ (1, pure O) + , (9, point <$> arbitrary) + ] + -- TODO use a generator that uses pointFromX? + +prop_P_add_assoc :: Point -> Point -> Point -> Property +prop_P_add_assoc a b c = (a .+. b) .+. c === a .+. (b .+. c) + +prop_P_add_comm :: Point -> Point -> Property +prop_P_add_comm a b = a .+. b === b .+. a + +prop_P_add_neutral_r :: Point -> Property +prop_P_add_neutral_r a = a .+. O === a + +prop_P_add_neutral_l :: Point -> Property +prop_P_add_neutral_l a = O .+. a === a + +prop_P_add_inverse_r :: Point -> Property +prop_P_add_inverse_r a = a .+. minusP a === O + +prop_P_add_inverse_l :: Point -> Property +prop_P_add_inverse_l a = minusP a .+. a === O + +prop_P_add_inverse_2 :: Point -> Point -> Property +prop_P_add_inverse_2 a b = a .-. b === minusP (b .-. a) + +prop_P_mul :: Fp -> Point -> Property +prop_P_mul n p = montgomeryMult n p === doubleAndAdd (nat n) p + +prop_key_compression :: Fn -> Property +prop_key_compression sk = validatePublicKey pk ==> + (Just pk === pointFromX pkx True .||. Just pk === pointFromX pkx False) + where + pk = sk .*. gC + pkx = case pk of + (Point x _) -> x + O -> error "invalid public key, point at infinity" + +properties_P :: TestTree +properties_P = testGroup "Point" + [ testProperty "prop_P_add_assoc" prop_P_add_assoc + , testProperty "prop_P_add_comm" prop_P_add_comm + , testProperty "prop_P_add_neutral_l" prop_P_add_neutral_l + , testProperty "prop_P_add_neutral_r" prop_P_add_neutral_r + , testProperty "prop_P_add_inverse_r" prop_P_add_inverse_r + , testProperty "prop_P_add_inverse_l" prop_P_add_inverse_l + , testProperty "prop_P_add_inverse_2" prop_P_add_inverse_2 + , testProperty "prop_P_mul" prop_P_mul + , testProperty "prop_key_compression" prop_key_compression + ] + +-- -------------------------------------------------------------------------- -- +-- All Properties + +tests :: TestTree +tests = testGroup "Crypto.Secp256k1" + [ properties_Fp + , properties_Fn + , properties_Fp_sqrt + , properties_P + , properties_ecdsa + , properties_example1 + ]