diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog + +`pasta-curves` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +## 0.0.0.0 + +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/nccgroup/pasta-curves/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022 Eric Schorn + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# pasta-curves + +[![Stack CI](https://github.com/nccgroup/pasta-curves/actions/workflows/stack.yml/badge.svg)](https://github.com/nccgroup/pasta-curves/actions/workflows/stack.yml) +[![Cabal CI](https://github.com/nccgroup/pasta-curves/actions/workflows/cabal.yml/badge.svg)](https://github.com/nccgroup/pasta-curves/actions/workflows/cabal.yml) +[![Hackage](https://img.shields.io/hackage/v/pasta-curves.svg?logo=haskell)](https://hackage.haskell.org/package/pasta-curves) +[![Stackage Lts](http://stackage.org/package/pasta-curves/badge/lts)](http://stackage.org/lts/package/pasta-curves) +[![Stackage Nightly](http://stackage.org/package/pasta-curves/badge/nightly)](http://stackage.org/nightly/package/pasta-curves) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) + + +This Haskell library provides the Pasta Curves consisting of: the `Pallas` +curve and its `Fp` field element, the `Vesta` curve and its `Fq` field +element, and a variety of supporting functionality such as point/element +arithmetic, serialization, and hash-to-curve. The algorithms are NOT constant +time. + +Pallas is y2 = x3 + 5 over Fp(0x40000000000000000000000000000000224698fc094cf91b992d30ed00000001). +The order of the Pallas curve is 0x40000000000000000000000000000000224698fc0994a8dd8c46eb2100000001. + + +Vesta is y2 = x3 + 5 over Fq(0x40000000000000000000000000000000224698fc0994a8dd8c46eb2100000001). +The order of the Vesta curve is 0x40000000000000000000000000000000224698fc094cf91b992d30ed00000001. + +The curves are designed such that the order of one matches the field +characteristic of the other. For a brief introduction, see the Zcash blog +titled ["The Pasta Curves for Halo 2 and Beyond"](https://electriccoin.co/blog/the-pasta-curves-for-halo-2-and-beyond/). +The reference Rust implementation (which inspired this implementation) +can be found at: . + +Example usage of this library implementation: + +~~~ +$ cabal repl + +ghci> a = 9 :: Fp + +ghci> a*a +0x0000000000000000000000000000000000000000000000000000000000000051 + +ghci> pointMul a base :: Vesta +Projective {_px = 0x3CDC6A090F2BB3B52714C083929B620FE24ADBCBBD420752108CD7C29E543E5E, + _py = 0x08795CD330B3CE5AA63BD2B18DE155AE3C96E8AF9DA2CC742C6BA1464E490161, + _pz = 0x1FA26F58F3A641ADFE81775D3D53378D6178B6CCBF14F9BD4AB5F10DEE28D878} +~~~ + +--- + +Copyright 2022 Eric Schorn; Licensed under the MIT License. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,31 @@ +{-| +Module : app.Main (internal) +Description : Trivial target for application executable build. +Copyright : (c) Eric Schorn, 2022 +Maintainer : eric.schorn@nccgroup.com +Stability : experimental +Portability : GHC +SPDX-License-Identifier: MIT + +This module provides a trivial Main target for application executable builds. +-} + +{-# LANGUAGE NoImplicitPrelude, Safe #-} + +module Main (main) where + +import Prelude +import PastaCurves + +main :: IO () +main = do + print "Sample executable for pasta-curves" + print $ pointMul (2 ^ (200::Integer) - 1 :: Fq) (base :: Pallas) + -- print exampleFp + -- print exampleFq + -- print examplePallasPt + -- print exampleVestaPt + +{- For profiling + cabal v2-run --enable-profiling exes -- +RTS -p +-} diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,80 @@ +{-| +Module : benchmark.Main (internal) +Description : Target for benchmarking build. +Copyright : (c) Eric Schorn, 2022 +Maintainer : eric.schorn@nccgroup.com +Stability : experimental +Portability : GHC +SPDX-License-Identifier: MIT + +This module provides a basic Main target for benchmarking builds. The suite of +benchmarks will be expanded over time. +-} + +{-# LANGUAGE NoImplicitPrelude, Safe #-} + +module Main (main) where + +import Prelude +import Data.ByteString.UTF8 (fromString) +import Criterion.Main +import PastaCurves +import Criterion.Types (timeLimit, resamples) + + +benchConfig = defaultConfig { + timeLimit = 60, + resamples = 20 + } + +-- Benchmarks will be further developed in future versions... +main :: IO () +main = defaultMainWith benchConfig [ + bgroup "Group 1" [ + bench "Hello Pallas 1" $ whnf hashToPallas (fromString "Hello Pallas 1"), + bench "Hello Pallas 2" $ whnf hashToPallas (fromString "Hello Pallas 2"), + bench "Hello Vesta 1" $ whnf hashToVesta (fromString "Hello Vesta 1"), + bench "Hello Vesta 2" $ whnf hashToVesta (fromString "Hello Vesta 2"), + bench "Pasta base * -1" $ whnf (pointMul (-1 :: Fq)) (base :: Pallas), + bench "Pasta base * 2^200 - 1" $ whnf (pointMul (2 ^ (200::Integer) - 1 :: Fq)) (base :: Pallas), + bench "Pasta base * 2^100 - 1" $ whnf (pointMul (2 ^ (100::Integer) - 1 :: Fq)) (base :: Pallas), + bench "Vesta base * -1" $ whnf (pointMul (-1 :: Fp)) (base :: Vesta) + ] + ] + +-- Note: Initial field multiply performance is in line with expected Rust BigInt described at +-- https://research.nccgroup.com/2021/09/10/optimizing-pairing-based-cryptography-montgomery-multiplication-in-assembly/ + +{- Potential performance improvements to investigate/implement +0. Inline (<- almost zero) and other compiler directives (-O2 <- almost zero) +1. Remove field add/sub MOD by compare then subtract (<- almost zero) +2. Remove field mul MOD by Barrett reduction / Montgomery multiplication +3. Implement explicit pointDouble routine +4. Separate out statics (e.g. in sqrt routines) + +Base Case +========= +benchmarking Group 1/Hello Pallas 1 +time 2.213 ms (2.190 ms .. 2.257 ms) + +benchmarking Group 1/Hello Pallas 2 +time 2.437 ms (2.428 ms .. 2.441 ms) + +benchmarking Group 1/Hello Vesta 1 +time 2.458 ms (2.454 ms .. 2.464 ms) + +benchmarking Group 1/Hello Vesta 2 +time 2.378 ms (2.371 ms .. 2.398 ms) + +benchmarking Group 1/Pasta base * -1 +time 92.48 μs (92.35 μs .. 92.73 μs) + +benchmarking Group 1/Pasta base * 2^200 - 1 +time 106.4 μs (104.4 μs .. 109.1 μs) + +benchmarking Group 1/Pasta base * 2^100 - 1 +time 31.51 μs (31.45 μs .. 31.58 μs) + +benchmarking Group 1/Vesta base * -1 +time 92.43 μs (91.97 μs .. 92.79 μs) +-} diff --git a/pasta-curves.cabal b/pasta-curves.cabal new file mode 100644 --- /dev/null +++ b/pasta-curves.cabal @@ -0,0 +1,77 @@ +cabal-version: 3.0 +name: pasta-curves +version: 0.0.0.0 +synopsis: Provides the Pasta curves: Pallas, Vesta and their field elements Fp and Fq. +description: Provides the Pasta curves: Pallas, Vesta and their field elements Fp and Fq. + See the PastaCurves module below and/or the GitHub repository README.md for more details. +homepage: https://github.com/nccgroup/pasta-curves +bug-reports: https://github.com/nccgroup/pasta-curves/issues +license: MIT +license-file: LICENSE +author: Eric Schorn +maintainer: Eric Schorn +copyright: 2022 Eric Schorn +category: Cryptography, Elliptic Curves +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC == 8.6.5 + || == 8.8.4 + || == 8.10.7 + || == 9.0.2 + || == 9.2.2 + +source-repository head + type: git + location: https://github.com/nccgroup/pasta-curves.git + +common common-options + build-depends: base >= 4.12 && < 4.17, + utf8-string >= 1 && < 1.0.3, + cryptonite >= 0.29 && < 0.31, + memory >= 0.16 && < 0.18, + bytestring >= 0.10 && < 0.11.4 + other-modules: Curves, Fields, Pasta + ghc-options: -Weverything + -Wno-missing-import-lists + -Wno-unsafe + -Wno-all-missed-specialisations + default-language: Haskell2010 + +library + import: common-options + hs-source-dirs: src/Crypto/ECC + exposed-modules: PastaCurves + +executable pasta-curves + import: common-options + hs-source-dirs: app, src/Crypto/ECC + main-is: Main.hs + other-modules: PastaCurves + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + +test-suite pasta-curves-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test, src/Crypto/ECC + main-is: Spec.hs + other-modules: PastaCurves, TestFields, TestCurves + build-depends: tasty >= 1.4 && < 1.5, + tasty-hunit >= 0.10 && < 0.11, + tasty-quickcheck >= 0.10 && < 0.11 + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + +benchmark pasta-curves-benchmark + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark, src/Crypto/ECC + main-is: Main.hs + other-modules: PastaCurves + build-depends: criterion >= 1.5 && < 1.6 + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/Crypto/ECC/Curves.hs b/src/Crypto/ECC/Curves.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/ECC/Curves.hs @@ -0,0 +1,223 @@ +{-| +Module : Crypto.PastaCurves.Curves (internal) +Description : Supports the instantiation of parameterized prime-order elliptic curves. +Copyright : (c) Eric Schorn, 2022 +Maintainer : eric.schorn@nccgroup.com +Stability : experimental +Portability : GHC +SPDX-License-Identifier: MIT + +This internal module provides an elliptic curve (multi-use) template from arbitrary +parameters for a curve of odd order, along with a variety of supporting functionality +such as point addition, multiplication, negation, equality, serialization and +deserialization. The algorithms are NOT constant time. Safety and simplicity are the +top priorities; the curve order must be prime (and so affine curve point y-cord != 0). +-} + +{-# LANGUAGE CPP, DataKinds, DerivingStrategies, FlexibleInstances, PolyKinds #-} +{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude, Safe, ScopedTypeVariables #-} + +module Curves (Curve(..), CurvePt(..), Point(..)) where + +import Prelude hiding (drop, length, sqrt) +import Control.Monad (mfilter) +import Data.ByteString (ByteString, cons, drop, index, length, pack) +import Data.Maybe (fromJust) +import Data.Typeable (Proxy (Proxy)) +import GHC.TypeLits (Nat, KnownNat, natVal) +import Fields (Field (..)) + + +-- | The `Point` type incorporates type literals @a@ and @b@ of an elliptic curve in the +-- short Weierstrass normal form. It also incorporates @baseX@ and @baseY@ coordinates +-- for the base type. A point with different literals is considered a different type, so +-- cannot be inadvertently mixed. *The curve order must be prime, and `_y` cannot be zero*. +data Point (a :: Nat) (b :: Nat) (baseX :: Nat) (baseY :: Nat) f = + Projective {_x :: f, _y :: f, _z :: f} deriving stock (Show) -- (x * inv0 z, y * inv0 z) + + +-- CPP macro 'helpers' to extract the curve parameters from `Point a b baseX baseY f` +#define A natVal (Proxy :: Proxy a) +#define B natVal (Proxy :: Proxy b) +#define BASE_X natVal (Proxy :: Proxy baseX) +#define BASE_Y natVal (Proxy :: Proxy baseY) + + +-- Calculate equality for projective points +instance (Field f, KnownNat a, KnownNat b, KnownNat baseX, KnownNat baseY) => + Eq (Point a b baseX baseY f) where + + -- x1/z1 == x2/z2 -> x1*z2/(x2*z1) == 1 -> same for y -> x1*z2/(x2*z1) == y1*z2/(y2*z1) + -- All (neutral) points at infinity are equal. + (==) (Projective x1 y1 z1) (Projective x2 y2 z2) = + (x1 * z2 == x2 * z1) && (y1 * z2 == y2 * z1) + + +-- | The `CurvePt` class provides the bulk of the functionality related to operations +-- involving points on the elliptic curve. It supports both the Pallas and Vesta curve +-- point types, as well as any other curves (using the arbitrary curve parameters). The +-- curve order must be prime. +class CurvePt a where + + -- | Returns the (constant) base point. + base :: a + + -- | The `fromBytesC` function deserializes a compressed point from a ByteString. An + -- invalid ByteString will return @Nothing@. + fromBytesC :: ByteString -> Maybe a + + -- | The `isOnCurve` function validates whether the point is on the curve. It is + -- already utilized within `fromBytesC` deserialization, within hash-to-curve (for + -- redundant safety) and within `toBytesC` serialization. + isOnCurve :: a -> Bool + + -- | The `negatePt` function negates a point. + negatePt :: a -> a + + -- | Returns the (constant) neutral point. + neutral :: a + + -- | The `pointAdd` function adds two curve points on the same elliptic curve. + pointAdd :: a -> a -> a + + -- | The `toBytesC` function serializes a point to a (compressed) @ByteStream@. + toBytesC :: a -> ByteString + + +instance (Field f, KnownNat a, KnownNat b, KnownNat baseX, KnownNat baseY) => + CurvePt (Point a b baseX baseY f) where + + -- Construct the base point directly from the type literals. + base = Projective (fromInteger $ BASE_X) (fromInteger $ BASE_Y) 1 + + + -- Deserialize a ByteString into a point on the elliptic curve based on section 2.3.4 + -- of https://www.secg.org/sec1-v2.pdf. Only compressed points are supported. + fromBytesC bytes + -- If the ByteString is a single zero byte, the Just neutral point is returned + | length bytes == 1 && index bytes 0 == 0 = Just neutral + -- If the ByteString is correct length with an acceptable leading byte, attempt decode + | length bytes == corLen && (index bytes 0 == 0x2 || index bytes 0 == 0x03) = result + where + -- correct length is the correct length of the field element plus 1 + corLen = 1 + length (toBytesF (fromInteger (A) :: f)) + -- drop the leading byte then deserialize the x-coordinate + x = fromBytesF (drop 1 bytes) :: Maybe f + -- see what sgn0 we are expecting for the final y-coordinate + sgn0y = if index bytes 0 == 0x02 then 0 else 1 :: Integer + -- calculate y squared from deserialized x-coordinate and curve constants + alpha = (\t -> t ^ (3 :: Integer) + ((fromInteger $ A) :: f) * t + ((fromInteger $ B) :: f)) <$> x + -- get square root (thus a proposed y-coordinate; note y cannot be zero) + beta = alpha >>= sqrt + -- adjust which root is selected for y-coordinate + y = (\t -> if sgn0 t == sgn0y then t else negate t) <$> beta + -- propose a deserialized point (which is on the curve by construction) + proposed = (Projective <$> x <*> y <*> Just 1) :: Maybe (Point a b baseX baseY f) + -- re-validate it is on the curve and return; a sqrt fail propagates through Maybes + result = mfilter isOnCurve proposed + -- Otherwise we fail (bad length, bad prefix etc) and return Nothing + fromBytesC _ = Nothing + + + -- Validate via projective form of Weierstrass equation. + isOnCurve (Projective x y z) = z * y ^ (2 :: Integer) == x ^ (3 :: Integer) + + fromInteger (A) * x * z ^ (2 :: Integer) + fromInteger (B) * z ^ (3 :: Integer) + + + -- Point negation is flipping y-coordinate. + negatePt (Projective x y z) = Projective x (- y) z + + + -- Anything with z=0 is neutral (y cannot be 0) + neutral = Projective 0 1 0 + + + -- See https://eprint.iacr.org/2015/1060.pdf page 8; Algorithm 1: Complete, projective + -- point addition for arbitrary (odd) prime order short Weierstrass curves + -- E/Fq : y^2 = x^3 + ax + b. The code has the intermediate additions 'squashed out' + pointAdd (Projective x1 y1 z1) (Projective x2 y2 z2) = result + where + m0 = x1 * x2 + m1 = y1 * y2 + m2 = z1 * z2 + m3 = (x1 + y1) * (x2 + y2) + m4 = (x1 + z1) * (x2 + z2) + m5 = (y1 + z1) * (y2 + z2) + m6 = ((fromInteger $ A) :: f) * (- m0 - m2 + m4) + m7 = ((fromInteger $ 3 * B) :: f) * m2 + m8 = (m1 - m6 - m7) * (m1 + m6 + m7) + m9 = ((fromInteger $ A) :: f) * m2 + m10 = ((fromInteger $ 3 * B) :: f) * (- m0 - m2 + m4) + m11 = ((fromInteger $ A) :: f) * (m0 - m9) + m12 = (m0 * 3 + m9) * (m10 + m11) + m13 = (- m1 - m2 + m5) * (m10 + m11) + m14 = (- m0 - m1 + m3) * (m1 - m6 - m7) + m15 = (- m0 - m1 + m3) * (m0 * 3 + m9) + m16 = (- m1 - m2 + m5) * (m1 + m6 + m7) + result = Projective (-m13 + m14) (m8 + m12) (m15 + m16) :: Point a b baseX baseY f + + + -- Serialize a point on the elliptic curve into a ByteString based on section 2.3.3 + -- of https://www.secg.org/sec1-v2.pdf. Only compressed points are supported. + --toBytesC (Projective xp yp zp) + toBytesC pt + | not $ isOnCurve pt = error "trying to serialize point not on curve" + | _z pt == 0 = pack [0] + | sgn0 y == 0 = cons 0x02 (toBytesF x) + | otherwise = cons 0x03 (toBytesF x) + where -- recover affine coordinates from original projective coordinates + x = _x pt * inv0 (_z pt) + y = _y pt * inv0 (_z pt) + + +-- | The `Curve` class provides the elliptic point multiplication operation involving +-- one `CurvePt` point on an elliptic curve and another `Field` field element as the +-- scalar operand. It also provides the `mapToCurveSimpleSwu` which is used in the later +-- stages of hashing-to-curve. It supports both the Pallas and Vesta curve point type. +class (CurvePt a, Field b) => Curve a b where + + -- | The `pointMul` function multiplies a field element by a prime-order curve point. + -- This, for example, could be a `PastaCurves.Fq` field element scalar with a + -- `PastaCurves.Pallas` elliptic curve point (which happens to use `PastaCurves.Fp` + -- co-ordinates). + pointMul :: b -> a -> a + + -- The `mapToCurveSimpleSwu` is a simplistic implementation of the Simplified + -- Shallue-van de Woestijne-Ulas method maps a field element to a curve point. + -- See https://www.ietf.org/archive/id/draft-irtf-cfrg-hash-to-curve-14.html#name-simplified-shallue-van-de-w + -- It requires A*B != 0 and a special constant Z (see link). + mapToCurveSimpleSwu :: b -> b -> a + + +instance (Field f1, Field f2, KnownNat a, KnownNat b, KnownNat baseX, KnownNat baseY) => + Curve (Point a b baseX baseY f1) f2 where + + + -- Classic double and add algorithm; will add a dedicated point double routine in the future + pointMul s pt = pointMul' s pt neutral + where + pointMul' :: f2 -> Point a b baseX baseY f1 -> Point a b baseX baseY f1 -> Point a b baseX baseY f1 + pointMul' scalar p1 accum + | scalar == 0 = accum -- scalar is a field element so cannot go 'below zero' + | sgn0 scalar /= 0 = pointMul' (shiftR1 scalar) doublePt (pointAdd accum p1) + | sgn0 scalar == 0 = pointMul' (shiftR1 scalar) doublePt accum + | otherwise = error "pointMul' pattern match fail (should never happen)" + where + doublePt = pointAdd p1 p1 + + + -- Z is Pasta-specific (constant is calculated elsewhere) + mapToCurveSimpleSwu fu fz = if A * B /= 0 then result else error "Curve params A*B must not be zero" + where + u = (fromInteger $ toI fu) :: f1 -- pesky type conversion + z = (fromInteger $ toI fz) :: f1 + -- See https://www.ietf.org/archive/id/draft-irtf-cfrg-hash-to-curve-14.html#section-6.6.2-7 + tv1 = inv0 (z ^ (2 :: Integer) * u ^ (4 :: Integer) + z * u ^ (2 :: Integer)) + x1a = (fromInteger ((-1) * B) * inv0 (fromInteger (A))) * (1 + tv1) + x1 = if toI tv1 == 0 then fromInteger (B) * inv0 (z * fromInteger (A)) else x1a + gx1 = x1 ^ (3 :: Integer) + fromInteger (A) * x1 + fromInteger (B) + x2 = z * u ^ (2 :: Integer) * x1 + gx2 = x2 ^ (3 :: Integer) + fromInteger (A) * x2 + fromInteger (B) + (x, ya) = if isSqr gx1 then (x1, fromJust $ sqrt gx1) else (x2, fromJust $ sqrt gx2) + y = if sgn0 u /= sgn0 ya then -ya else ya + result = Projective x y 1 :: Point a b baseX baseY f1 diff --git a/src/Crypto/ECC/Fields.hs b/src/Crypto/ECC/Fields.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/ECC/Fields.hs @@ -0,0 +1,251 @@ +{-| +Module : Crypto.PastaCurves.Fields (internal) +Description : Supports the instantiation of parameterized prime-modulus fields. +Copyright : (c) Eric Schorn, 2022 +Maintainer : eric.schorn@nccgroup.com +Stability : experimental +Portability : GHC +SPDX-License-Identifier: MIT + +This internal module provides a (multi-use) field element template with an arbitrary +prime modulus along with a variety of supporting functionality such as basic arithmetic, +multiplicative inverse, square testing, square root, serialization and deserialization, +and hash2Field. The algorithms are NOT constant time; Safety and simplicity are the top +priorities. +-} + +{-# LANGUAGE CPP, DataKinds, DerivingStrategies, KindSignatures, NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables, Trustworthy #-} + +module Fields (Field(..), Fz(..), Num(..)) where + +import Prelude hiding (concat, replicate) +import Crypto.Hash (Blake2b_512 (Blake2b_512), hashWith) +import Data.Bifunctor (bimap) +import Data.Bits ((.|.), shiftL, shiftR) +import Data.ByteArray (convert, length, xor) +import Data.ByteString (concat, foldl', pack, replicate) +import Data.ByteString.UTF8 (ByteString, fromString) +import Data.Char (chr) +import Data.Typeable (Proxy (Proxy)) +import GHC.Word (Word8) +import GHC.TypeLits (KnownNat, Nat, natVal) + + +-- | The `Fz (z :: Nat)` field element (template) type includes a parameterized modulus +-- of @z@. +newtype Fz (z :: Nat) = Fz Integer deriving stock (Eq) + + +-- A CPP macro 'helper' to extract the modulus from (Fz z). +#define MOD natVal (Proxy :: Proxy z) + + +-- | The `Fz` type is an instance of the `Num` class. +instance KnownNat z => Num (Fz z) where + + fromInteger a = Fz $ a `mod` MOD + + (+) (Fz a) (Fz b) = fromInteger (a + b) + + (-) (Fz a) (Fz b) = fromInteger (a - b) + + (*) (Fz a) (Fz b) = fromInteger (a * b) + + abs = error "abs: not implemented/needed" + + signum = error "signum: not implemented/needed" + + +-- | The `Fz` type is an instance of the `Show` class with output in hexadecimal. +instance KnownNat z => Show (Fz z) where + + show (Fz a) = "0x" ++ ["0123456789ABCDEF" !! nibble n | n <- [e, e-1..0]] + where + nibble :: Int -> Int + nibble n = fromInteger $ shiftR a (n*4) `mod` 16 + e = ((3 + until ((MOD <) . (2 ^)) (+ 1) 0) `div` 4) - 1 :: Int + + +-- | The `Field` class provides useful support functionality for field elements. +class (Num a, Eq a) => Field a where + + -- | The `fromBytesF` function is the primary deserialization constructor which + -- consumes a big-endian `ByteString` sized to minimally contain the modulus + -- and returns a field element. The deserialized integer must already be properly + -- reduced to reside within [0..modulus), otherwise Nothing is returned. + fromBytesF :: ByteString -> Maybe a + + -- | The `_fromBytesF` function is the secondary deserialization constructor which + -- consumes an unconstrained big-endian `ByteString` and returns a internally + -- reduced field element. This function is useful for random testing and + -- hash2Field-style functions. + _fromBytesF :: ByteString -> a + + -- | The `hash2Field` function provides intermediate functionality that is suitable + -- for ultimately supporting the `Curves.hash2Curve` function. This function returns + -- a 2-tuple of field elements. + hash2Field :: ByteString -> String -> String -> (a, a) + + -- | The `inv0` function returns the multiplicative inverse as calculated by Fermat's + -- Little Theorem (mapping 0 to 0). + inv0 :: a -> a + + -- | The `isSqr` function indicates whether the operand has a square root. + isSqr :: a -> Bool + + -- | The `sgn0` function returns the least significant bit of the field element as an + -- Integer. + sgn0 :: a -> Integer + + -- | The `shiftR1` function shifts the field element one bit to the right, effectively + -- dividing it by two (and discarding the remainder). + shiftR1 :: a -> a + + -- | The `Fields.sqrt` function implements the variable-time Tonelli-Shanks + -- algorithm to calculate the operand's square root. The function returns `Nothing` + -- in the event of a problem (such as the operand not being a square, the modulus + -- is not prime, etc). + sqrt :: a -> Maybe a + + -- | The `toBytesF` function serializes an element into a big-endian `ByteString` + -- sized to minimally contain the modulus. + toBytesF :: a -> ByteString + + -- | The `toI` function returns the field element as a properly reduced Integer. + toI :: a -> Integer + + +-- | The `Fz z` type is an instance of the `Field` class. Several functions are largely +-- simple adapters to the more generic internal functions implemented further below. +instance KnownNat z => Field (Fz z) where + + -- Validated deserialization, returns a Maybe field element. Follows section 2.3.6 + -- of https://www.secg.org/sec1-v2.pdf + -- If ByteString is not the correct length or integer >= modulus, return Nothing. + -- fromBytesF :: ByteString -> Maybe a + fromBytesF bytes | Data.ByteArray.length bytes /= corLen || integer >= MOD = Nothing + | otherwise = Just $ fromInteger integer + where + corLen = (7 + until ((MOD <) . (2 ^)) (+ 1) 0) `div` 8 :: Int -- correct length + integer = foldl' (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 bytes :: Integer + + + -- Unvalidated deserialization (no limits wrt modulus), returns reduced field element. + -- _fromBytesF :: ByteString -> a + _fromBytesF bytes = fromInteger $ foldl' (\a b -> shiftL a 8 .|. fromIntegral b) 0 bytes + + + -- Field-level support for the hash2Curve function, returns a pair of field elements. + -- The hash2field construction is per Zcash Pasta Curve (which is very similar but not + -- identical to the CFRG hash-to-curve specification). Fortuitously, cryptonite sets + -- the hash personalization to all zeros, see https://github.com/haskell-crypto/cryptonite/issues/333 + -- Zcash/Pasta code https://github.com/zcash/pasta_curves/blob/main/src/hashtocurve.rs#L10 + -- CFRG scheme (for ref) https://www.ietf.org/archive/id/draft-irtf-cfrg-hash-to-curve-14.html#name-hash_to_field-implementatio + -- Length of domain prefix and curve ID need to be less than 256 - 22 + -- hash2Field :: ByteString -> String -> String -> (a, a) + hash2Field msg domPref curveId + | 22 + Prelude.length curveId + Prelude.length domPref > 255 = error "strings too long" + | otherwise = bimap _fromBytesF _fromBytesF (digest1, digest2) + where + -- Calculate reusable prefix and suffix + prefix = replicate 128 0 + suffix = fromString (domPref ++ "-" ++ curveId ++ "_XMD:BLAKE2b_SSWU_RO_" ++ + [chr (22 + Prelude.length curveId + Prelude.length domPref)]) + -- A little helper function to hash ByteStrings + mkDigest :: ByteString -> ByteString + mkDigest x = convert $ hashWith Blake2b_512 x + -- Hash the message along with prefix, suffix, etc + digest0 = mkDigest $ concat [prefix, msg, pack [0,0x80,0], suffix] + -- Hash the hash again + digest1 = mkDigest $ concat [digest0, pack [0x01], suffix] + -- Mix the two above hashes together via bytewise XOR, then hash that too + mix = xor digest0 digest1 :: ByteString + digest2 = mkDigest $ concat [mix, pack [0x02], suffix] + + + -- Multiplicative inverse, with 0 mapped to 0, via Fermat's Little Theorem + -- inv0 :: a -> a + inv0 (Fz a) = Fz $ _powMod a (MOD - 2) (MOD) + + + -- Determines if the operand has a square root. Uses helper functions with Integers + -- isSqr :: a -> Bool + isSqr (Fz a) = _isSqr a (MOD) + + + -- Returns the least significant bit of the field element as an Integer + -- sgn0 :: a -> Integer + sgn0 (Fz a) = a `mod` 2 + + + -- Shift right by 1 (divides the element by 2, discarding the remainder) + -- shiftR1 :: a -> a + shiftR1 (Fz a) = Fz $ a `div` 2 + + + -- Returns square root as Maybe field element. If any problems, returns Nothing. + -- sqrt :: a -> Maybe a + sqrt (Fz a) = fromInteger <$> _sqrtVt a (MOD) s p c -- Use helper function + where + -- rewrite (modulus - 1) as p * 2**s + s = until ((/= 0) . ((MOD -1) `rem`) . (2 ^)) (+ 1) 0 - 1 :: Integer + p = (MOD - 1) `div` (2 ^ s) + -- Find first non-square and use that to prepare \'fountain of fixes\' + z = head ([x | x <- [1..], not (_isSqr x (MOD))] ++ [0]) + c = _powMod z p (MOD) + + + -- Deserialization. Follows section 2.3.7 of https://www.secg.org/sec1-v2.pdf + -- toBytesF :: a -> ByteString + toBytesF (Fz a) = pack $ reverse res + where + corLen = fromInteger $ (7 + until ((MOD <) . (2 ^)) (+ 1) 0) `div` 8 :: Int + res = [fromIntegral (shiftR a (8*b)) | b <- [0..(corLen - 1)]] :: [Word8] + + + -- Returns the element as an Integer + -- toI :: a -> Integer + toI (Fz a) = a + + +-- Complex/common support functions operating on integers rather than field elements + +-- | Modular exponentiation. +-- _powMod :: operand -> exponent -> modulus +_powMod :: Integer -> Integer -> Integer -> Integer +_powMod _ e q | e < 0 || q < 2 = error "Invalid exponent/modulus" +_powMod _ 0 _ = 1 +_powMod a 1 _ = a +_powMod a e q | even e = _powMod (a * a `mod` q) (shiftR e 1) q + | otherwise = a * _powMod a (e - 1) q `mod` q + + +-- | Is operand a square via Legendre symbol. +-- isSqr :: operand -> modulus +_isSqr :: Integer -> Integer -> Bool +_isSqr a q = (legendreSymbol == 0) || (legendreSymbol == 1) + where legendreSymbol = _powMod a ((q - 1) `div` 2) q + + +-- | Variable-time Tonelli-Shanks algorithm. Works with any prime modulus. +-- _sqrtVt :: operand -> modulus -> \'s\' -> \'p\' -> nonSquare +_sqrtVt :: Integer -> Integer -> Integer -> Integer -> Integer -> Maybe Integer +_sqrtVt 0 _ _ _ _ = Just 0 +_sqrtVt a q _ _ _ | not (_isSqr a q) = Nothing -- Not truly necessary +_sqrtVt _ _ _ _ 0 = Nothing -- covers the bases +_sqrtVt a q s p c = Just result + where + t = _powMod a p q + r = _powMod a ((p + 1) `div` 2) q + result = loopy t r c s -- recursively iterate the function below + loopy :: Integer -> Integer -> Integer -> Integer -> Integer + loopy tt _ _ ss | tt == 0 || ss == 0 = 0 + loopy 1 rr _ _ = rr + loopy tt rr cc ss = loopy t_n r_n c_n s_n -- read _n as _next + where + s_n = head ([i | i <- [1..(ss - 1)], _powMod tt (2 ^ i) q == 1] ++ [0]) -- ++0 avoids empty + ff = _powMod cc (2 ^ (ss - s_n - 1)) q + r_n = rr * ff `mod` q + t_n = (tt * _powMod ff 2 q) `mod` q + c_n = _powMod cc (2 ^ (ss - s_n)) q diff --git a/src/Crypto/ECC/Pasta.hs b/src/Crypto/ECC/Pasta.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/ECC/Pasta.hs @@ -0,0 +1,147 @@ +{-| +Module : Crypto.PastaCurves.Pasta (internal) +Description : Pasta-specific instantiation of parameterized curves and fields. +Copyright : (c) Eric Schorn, 2022 +Maintainer : eric.schorn@nccgroup.com +Stability : experimental +Portability : GHC +SPDX-License-Identifier: MIT + +This internal module instantiates the specific curves and fields specific to Pasta. It +also includes `hashToPallas` and `hashToVesta` functionality (which in turn includes +two isogenous curves, mapping functionality, and coefficient vectors). The algorithms +are NOT constant time; Safety and simplicity are the top priorities. +-} + +{-# LANGUAGE DataKinds, NoImplicitPrelude, Safe #-} + +module Pasta (Fp, Fq, Num(..), Pallas, Vesta, Curve(..), CurvePt(..), Field(..), + hashToPallas, hashToVesta, pallasPrime, vestaPrime) where + +import Prelude +import Curves (Curve(..), CurvePt(..), Point(..)) +import Fields (Fz, Field(..)) +import Data.ByteString.UTF8 (ByteString) + + +-- | `Fp` is the field element used as a coordinate in the Pallas elliptic curve. +-- It is a type synonym for the internal `Fields.Fz` type, parameterized with the +-- correct modulus. It is also typically used as a scalar to multiply a Vesta elliptic +-- curve point. Note that pointMul does not enforce specific scalar/point combinations. +type Fp = Fz 0x40000000000000000000000000000000224698fc094cf91b992d30ed00000001 + + +-- | `Pallas` represents a point on the Pallas elliptic curve using `Fp` coordinates. +-- The curve was designed to have the some order as the `Fq` element\'s modulus. It is +-- a type synonym for the internal `Curves.Point` type, parameterized with the curve\s +-- @a@ and @b@ values and the affine base point as @base_x@ and @base_y@. The underlying +-- point is of type @Point a b base_x base_y field@. +type Pallas = (Point 0 5 1 0x248b4a5cf5ed6c83ac20560f9c8711ab92e13d27d60fb1aa7f5db6c93512d546 Fp) + + +-- | `Fq` is the field element used as a coordinate in the Vesta elliptic curve. +-- It is a type synonym for the internal `Fields.Fz` type, parameterized with the +-- correct modulus. It is also typically used as a scalar to multiply a Pallas elliptic +-- curve point. Note that pointMul does not enforce specific scalar/point combinations. +type Fq = Fz 0x40000000000000000000000000000000224698fc0994a8dd8c46eb2100000001 + + +-- | `Vesta` represents a point on the Vesta elliptic curve using `Fq` coordinates. +-- The curve was designed to have the some order as the `Fp` element\'s modulus. It is +-- a type synonym for the internal `Curves.Point` type, parameterized with the curve\s +-- @a@ and @b@ values and the affine base point as @base_x@ and @base_y@. The underlying +-- point is of type @Point a b base_x base_y field@. +type Vesta = (Point 0 5 1 0x26bc999156dd5194ec49b1c551768ab375785e7ce00906d13e0361674fd8959f Fq) + + +-- This is a curve that is isogenous to Pallas, but with a*b != 0; base point params are unused +type IsoPallas = (Point 0x18354a2eb0ea8c9c49be2d7258370742b74134581a27a59f92bb4b0b657a014b 1265 0 0 Fp) + + +-- This is a curve that is isogenous to Vesta, but with a*b != 0; base point params are unused +type IsoVesta = (Point 0x267f9b2ee592271a81639c4d96f787739673928c7d01b212c515ad7242eaa6b1 1265 0 0 Fq) + + +-- | The `hashToPallas` function takes an arbitrary `ByteString` and maps it to a valid +-- point on the Pallas elliptic curve (of unknown relation to the base point). +hashToPallas :: ByteString -> Pallas +hashToPallas msg = result + where + (fe0, fe1) = hash2Field msg "z.cash:test" "pallas" :: (Fp, Fp) + q0 = mapToCurveSimpleSwu fe0 (fromInteger (-13)) :: IsoPallas -- -13 is Pasta specific magic constant + q1 = mapToCurveSimpleSwu fe1 (fromInteger (-13)) :: IsoPallas + (Projective xp yp zp) = pointAdd q0 q1 :: IsoPallas + x = xp * inv0 zp ; y = yp * inv0 zp + xTop = head isoPallasVecs * x ^ (3::Integer) + isoPallasVecs !! 1 * x ^ (2::Integer) + isoPallasVecs !! 2 * x + isoPallasVecs !! 3 + xBot = x ^ (2::Integer) + isoPallasVecs !! 4 * x + isoPallasVecs !! 5 + yTop = isoPallasVecs !! 6 * x ^ (3::Integer) + isoPallasVecs !! 7 * x ^ (2::Integer) + isoPallasVecs !! 8 * x + isoPallasVecs !! 9 + yBot = x ^ (3::Integer) + isoPallasVecs !! 10 * x ^ (2::Integer) + isoPallasVecs !! 11 * x + isoPallasVecs !! 12 + proposed = Projective (xTop * inv0 xBot) (y * yTop * inv0 yBot) 1 :: Pallas + result = if isOnCurve proposed then proposed else error "hashed to Pallas non-point" + + +-- | The `hashToVesta` function takes an arbitrary `ByteString` and maps it to a valid +-- point on the Vesta elliptic curve (of unknown relation to the base point). +hashToVesta :: ByteString -> Vesta +hashToVesta msg = result + where + (fe0, fe1) = hash2Field msg "z.cash:test" "vesta" :: (Fq, Fq) + q0 = mapToCurveSimpleSwu fe0 (fromInteger (-13)) :: IsoVesta + q1 = mapToCurveSimpleSwu fe1 (fromInteger (-13)) :: IsoVesta + (Projective xp yp zp) = pointAdd q0 q1 :: IsoVesta + x = xp * inv0 zp ; y = yp * inv0 zp + xTop = head isoVestaVecs * x ^ (3::Integer) + isoVestaVecs !! 1 * x ^ (2::Integer) + isoVestaVecs !! 2 * x + isoVestaVecs !! 3 + xBot = x ^ (2::Integer) + isoVestaVecs !! 4 * x + isoVestaVecs !! 5 + yTop = isoVestaVecs !! 6 * x ^ (3::Integer) + isoVestaVecs !! 7 * x ^ (2::Integer) + isoVestaVecs !! 8 * x + isoVestaVecs !! 9 + yBot = x ^ (3::Integer) + isoVestaVecs !! 10 * x ^ (2::Integer) + isoVestaVecs !! 11 * x + isoVestaVecs !! 12 + proposed = Projective (xTop * inv0 xBot) (y * yTop * inv0 yBot) 1 :: Vesta + result = if isOnCurve proposed then proposed else error "hashed to Vesta non-point" + + +-- | The Pallas field modulus https://neuromancer.sk/std/other/Pallas +pallasPrime :: Integer +pallasPrime = 0x40000000000000000000000000000000224698fc094cf91b992d30ed00000001 + + +-- | The Vesta field modulus https://neuromancer.sk/std/other/Vesta +vestaPrime :: Integer +vestaPrime = 0x40000000000000000000000000000000224698fc0994a8dd8c46eb2100000001 + + +-- Vectors to map isogenous curve (with a*b != 0) point to Pallas +-- See https://github.com/zcash/pasta_curves/blob/21fd9e2c1bbd2d049bfe95588d77cb884e9f93ab/src/curves.rs#L1017-L1096 +isoPallasVecs :: [Fp] +isoPallasVecs = [ + 0x0e38e38e38e38e38e38e38e38e38e38e4081775473d8375b775f6034aaaaaaab, + 0x3509afd51872d88e267c7ffa51cf412a0f93b82ee4b994958cf863b02814fb76, + 0x17329b9ec525375398c7d7ac3d98fd13380af066cfeb6d690eb64faef37ea4f7, + 0x1c71c71c71c71c71c71c71c71c71c71c8102eea8e7b06eb6eebec06955555580, + 0x1d572e7ddc099cff5a607fcce0494a799c434ac1c96b6980c47f2ab668bcd71f, + 0x325669becaecd5d11d13bf2a7f22b105b4abf9fb9a1fc81c2aa3af1eae5b6604, + 0x1a12f684bda12f684bda12f684bda12f7642b01ad461bad25ad985b5e38e38e4, + 0x1a84d7ea8c396c47133e3ffd28e7a09507c9dc17725cca4ac67c31d8140a7dbb, + 0x3fb98ff0d2ddcadd303216cce1db9ff11765e924f745937802e2be87d225b234, + 0x025ed097b425ed097b425ed097b425ed0ac03e8e134eb3e493e53ab371c71c4f, + 0x0c02c5bcca0e6b7f0790bfb3506defb65941a3a4a97aa1b35a28279b1d1b42ae, + 0x17033d3c60c68173573b3d7f7d681310d976bbfabbc5661d4d90ab820b12320a, + 0x40000000000000000000000000000000224698fc094cf91b992d30ecfffffde5] + + +-- Vectors to map isogenous curve (with a*b != 0) point to Vesta +-- Curve isogenous to Vesta, with a*b != 0 +-- See https://github.com/zcash/pasta_curves/blob/21fd9e2c1bbd2d049bfe95588d77cb884e9f93ab/src/curves.rs#L1117-L1196 +isoVestaVecs :: [Fq] +isoVestaVecs = [ + 0x38e38e38e38e38e38e38e38e38e38e390205dd51cfa0961a43cd42c800000001, + 0x1d935247b4473d17acecf10f5f7c09a2216b8861ec72bd5d8b95c6aaf703bcc5, + 0x18760c7f7a9ad20ded7ee4a9cdf78f8fd59d03d23b39cb11aeac67bbeb586a3d, + 0x31c71c71c71c71c71c71c71c71c71c71e1c521a795ac8356fb539a6f0000002b, + 0x0a2de485568125d51454798a5b5c56b2a3ad678129b604d3b7284f7eaf21a2e9, + 0x14735171ee5427780c621de8b91c242a30cd6d53df49d235f169c187d2533465, + 0x12f684bda12f684bda12f684bda12f685601f4709a8adcb36bef1642aaaaaaab, + 0x2ec9a923da239e8bd6767887afbe04d121d910aefb03b31d8bee58e5fb81de63, + 0x19b0d87e16e2578866d1466e9de10e6497a3ca5c24e9ea634986913ab4443034, + 0x1ed097b425ed097b425ed097b425ed098bc32d36fb21a6a38f64842c55555533, + 0x2f44d6c801c1b8bf9e7eb64f890a820c06a767bfc35b5bac58dfecce86b2745e, + 0x3d59f455cafc7668252659ba2b546c7e926847fb9ddd76a1d43d449776f99d2f, + 0x40000000000000000000000000000000224698fc0994a8dd8c46eb20fffffde5] diff --git a/src/Crypto/ECC/PastaCurves.hs b/src/Crypto/ECC/PastaCurves.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/ECC/PastaCurves.hs @@ -0,0 +1,80 @@ +{-| +Module : Crypto.PastaCurves.PastaCurves +Description : Provides the overall Pasta curve and field functionality. +Copyright : (c) Eric Schorn, 2022 +Maintainer : eric.schorn@nccgroup.com +Stability : experimental +Portability : GHC +SPDX-License-Identifier: MIT + +This module provides the Pasta Curves consisting of: the `Pallas` curve and its `Fp` +field element, the `Vesta` curve and its `Fq` field element, and a variety of +supporting functionality such as point/element arithmetic, serialization, and +hash-to-curve. The algorithms are NOT constant time; Safety and simplicity are the top +priorities. + +\[ +\text{Pallas: } y^2 = x^3 + 5 \text{ over } F_p(0x40000000000000000000000000000000224698fc094cf91b992d30ed00000001) +\] + +\[ +\text{Vesta: } y^2 = x^3 + 5 \text{ over } F_q(0x40000000000000000000000000000000224698fc0994a8dd8c46eb2100000001) +\] + +The order of the Pallas curve is 0x40000000000000000000000000000000224698fc0994a8dd8c46eb2100000001. + +The order of the Vesta curve is 0x40000000000000000000000000000000224698fc094cf91b992d30ed00000001. + +The curves are designed such that the order of one matches the field characteristic of +the other. For a brief introduction, see the Zcash blog titled "The Pasta Curves for Halo +2 and Beyond" at . +The reference Rust implementation (which inspired this implementation) can be found at: +. + +Example usage of this library implementation: + +@ +$ cabal repl + +ghci> a = 9 :: Fp + +ghci> a*a +0x0000000000000000000000000000000000000000000000000000000000000051 + +ghci> pointMul a base :: Vesta +Projective {_px = 0x3CDC6A090F2BB3B52714C083929B620FE24ADBCBBD420752108CD7C29E543E5E, + _py = 0x08795CD330B3CE5AA63BD2B18DE155AE3C96E8AF9DA2CC742C6BA1464E490161, + _pz = 0x1FA26F58F3A641ADFE81775D3D53378D6178B6CCBF14F9BD4AB5F10DEE28D878} +@ + +-} + +{-# LANGUAGE DataKinds, NoImplicitPrelude, Safe #-} + +module PastaCurves (Fp, Fq, Pallas, Vesta, CurvePt(..), Curve(..), hashToPallas, + hashToVesta, Field(..), pallasPrime, vestaPrime, exampleFp, exampleFq, examplePallasPt, + exampleVestaPt, Num(..)) where + +import Pasta (Fp, Fq, Num(..), Pallas, Vesta, CurvePt(..), Curve(..), Field(..), + hashToPallas, hashToVesta, pallasPrime, vestaPrime) +import Data.ByteString.UTF8 (fromString) + + +-- | An example `Fp` element (8). +exampleFp :: Fp +exampleFp = 8 + + +-- | An example `Fq` element (999). +exampleFq :: Fq +exampleFq = 999 + + +-- | An example `Pallas` point generated by hashing a message. +examplePallasPt :: Pallas +examplePallasPt = hashToPallas (fromString "A message to hash") + + +-- | An example `Vesta` point (base * 8). +exampleVestaPt :: Vesta +exampleVestaPt = pointMul exampleFp base diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude, Trustworthy #-} + +module Main (main) where + +import Prelude +import System.Environment (setEnv) +import Test.Tasty (defaultMain, testGroup) +import TestFields (fieldProps, testBadF, testGoodF) +import TestCurves (curveProps, testHashToPallas, testHashToVesta, testPOI, testBadC, testPallasEq) + + +main :: IO () +main = do + setEnv "TASTY_QUICKCHECK_TESTS" "1_000" + defaultMain $ testGroup "\nRunning Tests" [fieldProps, testBadF, testGoodF, + testHashToPallas, testHashToVesta, curveProps, testPOI, testBadC, testPallasEq] + print "Finished!" diff --git a/test/TestCurves.hs b/test/TestCurves.hs new file mode 100644 --- /dev/null +++ b/test/TestCurves.hs @@ -0,0 +1,122 @@ +-- Test curves... + +{-# LANGUAGE FlexibleInstances, NoImplicitPrelude, Trustworthy #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module TestCurves (curveProps, testPOI, testHashToPallas, testHashToVesta, testBadC, testPallasEq) where + +import Prelude hiding (exp) +import Data.ByteString (pack) +import Data.ByteString.UTF8 (fromString) +import Data.Maybe (fromJust, isNothing) +import Data.Word (Word8) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase) +import Test.Tasty.QuickCheck (Arbitrary(..), testProperty) +import TestFields () +import PastaCurves +import Curves (Point(Projective)) + + +instance Arbitrary Pallas where + arbitrary = do + scalar <- arbitrary + return $ pointMul (scalar :: Fq) (base :: Pallas) + + +instance Arbitrary Vesta where + arbitrary = do + scalar <- arbitrary + return $ pointMul (scalar :: Fp) (base :: Vesta) + + +curveProps :: TestTree +curveProps = testGroup "Testing Curve properties via QuickCheck" [ + + testProperty "Pallas point add/mul" $ + \x y -> pointAdd (pointMul (x :: Fq) base) (pointMul y base) == pointMul (x+y) (base::Pallas), + testProperty "Pallas point add symm" $ + \x y -> pointAdd x y == pointAdd y (x :: Pallas), + testProperty "Pallas ser->deser" $ + \x -> fromJust (fromBytesC (toBytesC x)) == (x :: Pallas), + + testProperty "Vesta point add/mul" $ + \x y -> pointAdd (pointMul (x :: Fp) base) (pointMul y base) == pointMul (x+y) (base :: Vesta), + testProperty "Vesta point add symm" $ + \x y -> pointAdd x y == pointAdd y (x :: Vesta), + testProperty "Vesta ser->deser" $ + \x -> fromJust (fromBytesC (toBytesC x)) == (x :: Vesta) + ] + + +testPOI :: TestTree +testPOI = testCase "poi decode" $ + do + let poiBytes = pack [0] + let orderLessOne = (0::Fq) - 1 + let act = pointAdd (pointMul orderLessOne base) base :: Pallas + let actBytes = toBytesC act + assertBool "bad pairing mul" (poiBytes == actBytes) + assertBool "point point eq" (act == (neutral :: Pallas)) + + +testBadC :: TestTree +testBadC = testCase "bad decode" $ do + let tooFewBytes = pack [0, 0] + let act1 = fromBytesC tooFewBytes :: Maybe Pallas + assertBool "bad too short bytes" (isNothing act1) + let tooManyBytes = pack $ replicate 34 0 + let act2 = fromBytesC tooManyBytes :: Maybe Pallas + assertBool "bad too many bytes" (isNothing act2) + let tooLargeValue = pack $ (0x02 :: Word8) : (0x41 :: Word8) : replicate 31 0 + let act3 = fromBytesC tooLargeValue :: Maybe Pallas + assertBool "bad too large value" (isNothing act3) + let notOnCurve = pack $ (0x02 :: Word8) : replicate 32 0 + let act4 = fromBytesC notOnCurve :: Maybe Pallas + assertBool "bad not on curve" (isNothing act4) + let baseBytes = pack $ ((0x02 :: Word8) : replicate 31 0) ++ [0x01 :: Word8] + let act5 = fromBytesC baseBytes :: Maybe Pallas + assertBool "bad is base" $ fromJust act5 == (base :: Pallas) + let notBaseBytes = pack $ ((0x03 :: Word8) : replicate 31 0) ++ [0x01 :: Word8] + let act6 = fromBytesC notBaseBytes :: Maybe Pallas + assertBool "bad not base" $ fromJust act6 /= (base :: Pallas) + + +testPallasEq :: TestTree +testPallasEq = testCase "bad Eq" $ do + let x1 = 0x2e341f9b583ed433336de60408dc32487b37d8076f09ed1cd25e4f406c46f0bc :: Fp + let y1 = 0x285a83a7d3a0d903aa1bb19eb6894d7dca04b13687abf05423ce54362de3d5de :: Fp + let z1 = 1 :: Fp + let x2 = 0x24024b8e1f42b83c83c211405147f74209b30aca025efc773734e7163798eb77 :: Fp + let y2 = 0x27db4a65be914fba5eac9c613554e58b4469b8eb344e937511f48b1780d9ab70 :: Fp + let z2 = 1 :: Fp + let x3 = 0x1dc72099914e05a28ce349b110c6f52291eb1cec24643bbed1fb489f7cb41f47 :: Fp + let y3 = 0x01b1f3ee3ec752c0a9022c1c2e178d00c10aa97417236f91a49ab232ec347c4f :: Fp + let z3 = 1 :: Fp + assertBool "Bad Eq1" $ ((Projective x1 y1 z1) :: Pallas) /= (Projective x2 y2 z2) + assertBool "Bad Eq2" $ ((Projective x2 y2 z2) :: Pallas) /= (Projective x3 y3 z3) + assertBool "Bad Eq3" $ ((Projective x3 y3 z3) :: Pallas) /= (Projective x1 y1 z1) + + +testHashToPallas :: TestTree +testHashToPallas = testCase "testHashToPallas" $ assertBool "Failed testHashToPallas" helper + where + actual = hashToPallas (fromString "Trans rights now!") -- String from zcash test vector line 147 (link below) + -- See https://github.com/zcash/pasta_curves/blob/21fd9e2c1bbd2d049bfe95588d77cb884e9f93ab/src/pallas.rs#L150-L158 + z = 0x1d48103df8fcbb70d1809c1806c95651dd884a559fec0549658537ce9d94bed9 :: Fp + x = 0x36a6e3a9c50b7b6540cb002c977c82f37f8a875fb51eb35327ee1452e6ce7947 * inv0 (z ^ (2::Integer)) + y = 0x01da3b4403d73252f2d7e9c19bc23dc6a080f2d02f8262fca4f7e3d756ac6a7c * inv0 (z ^ (3::Integer)) + expected = Projective x y 1 :: Pallas + helper = actual == expected + + +testHashToVesta :: TestTree +testHashToVesta = testCase "testHashToVesta" $ assertBool "Failed testHashToVesta" helper + where + actual = hashToVesta (fromString "hello") -- String from zcash test vector line 147 (link below) + -- See https://github.com/zcash/pasta_curves/blob/21fd9e2c1bbd2d049bfe95588d77cb884e9f93ab/src/vesta.rs#L63-L71 + z = 0x1b58d4aa4d68c3f4d9916b77c79ff9911597a27f2ee46244e98eb9615172d2ad :: Fq + x = 0x12763505036e0e1a6684b7a7d8d5afb7378cc2b191a95e34f44824a06fcbd08e * inv0 (z ^ (2::Integer)) + y = 0x0256eafc0188b79bfa7c4b2b393893ddc298e90da500fa4a9aee17c2ea4240e6 * inv0 (z ^ (3::Integer)) + expected = Projective x y 1 :: Vesta + helper = actual == expected diff --git a/test/TestFields.hs b/test/TestFields.hs new file mode 100644 --- /dev/null +++ b/test/TestFields.hs @@ -0,0 +1,63 @@ +-- Test fields... + +{-# LANGUAGE DataKinds, FlexibleInstances, NoImplicitPrelude, OverloadedStrings, Trustworthy #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant bracket" #-} + +module TestFields (fieldProps, testBadF, testGoodF) where + +import Prelude hiding (sqrt) +import Data.ByteString (pack) +import Data.Maybe (fromJust, isNothing) +import Data.Word (Word8) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, assertBool) +import Test.Tasty.QuickCheck (Arbitrary(..), choose, testProperty) +import PastaCurves + + +instance Arbitrary Fp where + arbitrary = fromInteger <$> choose (0, 2 ^ (512::Integer)) + +instance Arbitrary Fq where + arbitrary = fromInteger <$> choose (0, 2 ^ (512::Integer)) + + +fieldProps :: TestTree +fieldProps = testGroup "Testing Field properties via QuickCheck" [ + testProperty "Fp arith" $ \a b c -> a*(b-c) - a*b + a*c == (0 :: Fp), + testProperty "Fp inv0" $ \a -> a * inv0 a == (1 :: Fp), + testProperty "Fp sqrt" $ \a -> fromJust (sqrt (a*a)) ^ (2 :: Integer) == (a ^ (2 :: Integer) :: Fp), + testProperty "Fp isSqr" $ \a -> isSqr (a*a :: Fp), + testProperty "Fp serdes" $ \a -> fromBytesF (toBytesF a) == Just (a :: Fp), + testProperty "Fp shiftR1" $ \a -> shiftR1 a == fromInteger (toI (a :: Fp) `div` 2), + + testProperty "Fq arith" $ \a b c -> a*(b-c) - a*b + a*c == (0 :: Fq), + testProperty "Fq inv0" $ \a -> a * inv0 a == (1 :: Fq), + testProperty "Fq sqrt" $ \a -> fromJust (sqrt (a*a)) ^ (2 :: Integer) == (a ^ (2 :: Integer) :: Fq), + testProperty "Fq isSqr" $ \a -> isSqr (a*a :: Fq), + testProperty "Fq serdes" $ \a -> fromBytesF (toBytesF a) == Just (a :: Fq), + testProperty "Fq shiftR1" $ \a -> shiftR1 a == fromInteger (toI (a :: Fq) `div` 2) + ] + + +testBadF :: TestTree +testBadF = testCase "testBadF" $ + do + let tooFewBytes = pack [0] + let act1 = fromBytesF tooFewBytes :: Maybe Fq + assertBool "bad too short bytes" (isNothing act1) + let tooManyBytes = pack $ replicate 33 0 + let act2 = fromBytesF tooManyBytes :: Maybe Fq + assertBool "bad too many bytes" (isNothing act2) + let tooLargeValue = pack $ (0x41 :: Word8) : replicate 31 0 + let act3 = fromBytesF tooLargeValue :: Maybe Fq + assertBool "bad too large value" (isNothing act3) + +testGoodF :: TestTree +testGoodF = testCase "testGoodF" $ + do + assertBool "sgn0 -1" (sgn0 (negate (1 :: Fq)) == 0) + assertBool "sgn0 1" (sgn0 (1 :: Fq) == 1) + -- hash2Field tested as part of hash2Curve +