diff --git a/.gitignore b/.gitignore index ac6c2b6..a95437b 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,5 @@ pairing.cabal *~ *.hi *.o +.ghc.environment.* +dist*/ \ No newline at end of file diff --git a/bench/BenchPairing.hs b/bench/BenchPairing.hs index 954f240..0a1a131 100644 --- a/bench/BenchPairing.hs +++ b/bench/BenchPairing.hs @@ -126,6 +126,9 @@ test_g2_2 = Point.Point 7590136428571280465598215063146990078553196689176860926896020586846726844869 8036135660414384292776446470327730948618639044617118659780848199544099832559) +test_hash :: ByteString +test_hash = toS "TyqIPUBYojDVOnDPacfMGrGOzpaQDWD3KZCpqzLhpE4A3kRUCQFUx040Ok139J8WDVV2C99Sfge3G20Q8MEgu23giWmqRxqOc8pH" + benchmarks :: [Benchmark] benchmarks = [ bgroup "Frobenius in Fq12" @@ -225,6 +228,8 @@ benchmarks $ whnf (uncurry Point.gAdd) (test_g1_1, test_g1_2) , bench "multiply" $ whnf (uncurry Point.gMul) (test_g1_1, 42) + , bench "hashToG1" + $ whnfIO (Group.hashToG1 test_hash) ] , bgroup "G2" diff --git a/package.yaml b/package.yaml index 51c6978..3d65f8f 100644 --- a/package.yaml +++ b/package.yaml @@ -32,6 +32,7 @@ dependencies: - memory - wl-pprint-text - QuickCheck + - arithmoi library: source-dirs: src @@ -68,6 +69,15 @@ library: - OverloadedStrings - NoImplicitPrelude - FlexibleInstances + - ExplicitForAll + - RankNTypes + - DataKinds + - KindSignatures + - GeneralizedNewtypeDeriving + - TypeApplications + - ExistentialQuantification + - ScopedTypeVariables + - DeriveGeneric exposed-modules: - Pairing.Params @@ -81,6 +91,10 @@ library: - Pairing.Pairing - Pairing.Jacobian - Pairing.CyclicGroup + - Pairing.Hash + + other-modules: + - Pairing.Modular tests: test-circuit-compiler: @@ -93,6 +107,7 @@ tests: - tasty-discover - tasty-hunit - tasty-quickcheck + - quickcheck-instances - QuickCheck benchmarks: @@ -108,3 +123,4 @@ benchmarks: - tasty - tasty-quickcheck - tasty-hunit + - quickcheck-instances diff --git a/src/Pairing/Fq.hs b/src/Pairing/Fq.hs index 825a4fe..f00ead9 100644 --- a/src/Pairing/Fq.hs +++ b/src/Pairing/Fq.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE Strict #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} - -- | Prime field with characteristic _q, over which the elliptic curve -- is defined and the other finite field extensions. First field in -- the tower: @@ -19,7 +15,8 @@ module Pairing.Fq ( fqOne, fqNqr, euclidean, - random + random, + Pairing.Fq.fromBytes ) where import Protolude @@ -27,6 +24,12 @@ import Crypto.Random (MonadRandom) import Crypto.Number.Generate (generateMax) import Pairing.Params as Params import Pairing.CyclicGroup +import Pairing.Modular as M +import Data.Bits +import qualified Data.ByteString as BS +import Data.Bits +import Math.NumberTheory.Moduli.Class +import Math.NumberTheory.Moduli.Sqrt ------------------------------------------------------------------------------- -- Types @@ -56,15 +59,15 @@ instance Fractional Fq where -- | Turn an integer into an @Fq@ number, should be used instead of -- the @Fq@ constructor. new :: Integer -> Fq -new a = Fq (a `mod` _q) +new a = Fq $ withQ $ (getVal . newMod a) {-# INLINE norm #-} norm :: Fq -> Fq -norm (Fq a) = Fq (a `mod` _q) +norm (Fq a) = new a {-# INLINE fqAdd #-} fqAdd :: Fq -> Fq -> Fq -fqAdd (Fq a) (Fq b) = norm (Fq (a+b)) +fqAdd (Fq a) (Fq b) = Fq $ withQ (modBinOp a b (+)) {-# INLINE fqAbs #-} fqAbs :: Fq -> Fq @@ -72,19 +75,19 @@ fqAbs (Fq a) = Fq a {-# INLINE fqSig #-} fqSig :: Fq -> Fq -fqSig (Fq a) = Fq (signum a `mod` _q) +fqSig (Fq a) = Fq $ withQ (modUnOp a signum) {-# INLINE fqMul #-} fqMul :: Fq -> Fq -> Fq -fqMul (Fq a) (Fq b) = norm (Fq (a*b)) +fqMul (Fq a) (Fq b) = Fq $ withQ (modBinOp a b (*)) {-# INLINE fqNeg #-} fqNeg :: Fq -> Fq -fqNeg (Fq a) = Fq ((-a) `mod` _q) +fqNeg (Fq a) = Fq $ withQ (modUnOp a negate) {-# INLINE fqDiv #-} fqDiv :: Fq -> Fq -> Fq -fqDiv a b = fqMul a (inv b) +fqDiv (Fq a) (Fq b) = Fq $ withQ (modBinOp a b (/)) {-# INLINE fqNqr #-} -- | Quadratic non-residue @@ -128,3 +131,8 @@ random :: MonadRandom m => m Fq random = do seed <- generateMax _q pure (Fq seed) + +fromBytes :: ByteString -> Fq +fromBytes bs = Fq $ withQ (M.toInteger . M.fromBytes bs) + + diff --git a/src/Pairing/Group.hs b/src/Pairing/Group.hs index c84f9e2..053c247 100644 --- a/src/Pairing/Group.hs +++ b/src/Pairing/Group.hs @@ -14,6 +14,9 @@ module Pairing.Group ( g2, b1, b2, + hashToG1, + randomG1, + randomG2 ) where import Protolude @@ -26,6 +29,8 @@ import Pairing.Point import Pairing.Params import Pairing.CyclicGroup import Test.QuickCheck +import Pairing.Hash +import Crypto.Random (MonadRandom) -- | G1 is E(Fq) defined by y^2 = x^3 + b type G1 = Point Fq @@ -132,3 +137,16 @@ instance Arbitrary (Point Fq) where -- G1 instance Arbitrary (Point Fq2) where -- G2 arbitrary = gMul g2 . abs <$> (arbitrary :: Gen Integer) + +hashToG1 :: (MonadIO m, MonadRandom m) => ByteString -> m G1 +hashToG1 = swEncBN + +randomG1 :: (MonadIO m, MonadRandom m) => m G1 +randomG1 = do + Fq r <- Fq.random + pure (gMul g1 r) + +randomG2 :: (MonadIO m, MonadRandom m) => m G2 +randomG2 = do + Fq r <- Fq.random + pure (gMul g2 r) diff --git a/src/Pairing/Hash.hs b/src/Pairing/Hash.hs new file mode 100644 index 0000000..67dd746 --- /dev/null +++ b/src/Pairing/Hash.hs @@ -0,0 +1,86 @@ +module Pairing.Hash ( + swEncBN + ) where + +import Protolude +import Pairing.Params +import Pairing.Point +import Pairing.Modular as M +import Pairing.Fq as Fq +import Math.NumberTheory.Moduli.Class +import Math.NumberTheory.Moduli.Sqrt +import Crypto.Random (MonadRandom) +import Data.List + +sqrtOfMinusThree :: forall m . KnownNat m => Proxy m -> Mod m +sqrtOfMinusThree mName = sqrtOf mName (-3) + +-- | +-- Picks the postive square root only +-- | + +sqrtOf :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m +sqrtOf mName i = case sqrtsMod i of + [] -> panic ("Could not calculate sqrt " <> show i) + (x:_) -> x + +w :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m -> Mod m +w mname sq3 t = (sq3 * t) / (1 + (b mname) + (t `powMod` 2)) + +b :: forall m . KnownNat m => Proxy m -> Mod m +b mName = fromInteger @(Mod m) _b + +x1 :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m -> Mod m +x1 mName t w = ((sqrtOfMinusThree mName) - 1) / 2 - (t * w) + +x2 :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m +x2 mName x1' = (-1) - x1' + +x3 :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m +x3 mName w = 1 + (1 / (w `powMod` 2)) + +chi :: forall m . KnownNat m => Proxy m -> Mod m -> Integer +chi mName a + | a == 0 = 0 + | isSquare mName a = 1 + | otherwise = -1 + +alphaBeta :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m -> Integer +alphaBeta mName pr px = chi mName ((pr * pr) * ((px `powMod` 3) + (b mName))) + +i :: Integer -> Integer -> Integer +i pa pb = (((pa - 1) * pb) `mod` 3) + 1 + +swy :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m -> Mod m -> Mod m -> Integer +swy mn pr3 pt pxi pb = ch * y + where + ch = chi mn ((pr3 `powMod` 2) * pt) + y = getVal $ sqrtOf mn ((pxi `powMod` 3) + pb) + +-- | Encodes a given byte string to a point on the BN curve. +-- The implemenation uses the Shallue van de Woestijne encoding to BN curves as specifed +-- in Section 6 of Indifferentiable Hashing to Barreto Naehrig Curves +-- by Pierre-Alain Fouque and Mehdi Tibouchi. +-- This function evaluates an empty bytestring or one that contains \NUL to zero +-- which according to Definiton 2 of the paper is sent to an arbitrary point on the curve +-- +swEncBN :: (MonadIO m, MonadRandom m) => ByteString -> m (Point Fq) +swEncBN bs = withQM $ \mn -> do + let t = M.fromBytes bs mn + let sq3 = sqrtOfMinusThree mn + let w' = w mn sq3 t + let x1' = x1 mn t w' + if (t == 0) then + pure $ (Point (Fq.new (getVal x1')) (Fq.new (getVal $ sqrtOf mn (1 + (b mn))))) + else do + let x2' = x2 mn x1' + let x3' = x3 mn w' + let lst = [x1', x2', x3'] + r1 <- randomMod mn + r2 <- randomMod mn + r3 <- randomMod mn + let al = alphaBeta mn r1 x1' + let bet = alphaBeta mn r2 x2' + let i' = i al bet + let swy' = swy mn r3 t (genericIndex lst (i' - 1)) (b mn) + pure (Point (Fq.new (getVal $ genericIndex lst (i' - 1))) (Fq.new swy')) diff --git a/src/Pairing/Modular.hs b/src/Pairing/Modular.hs new file mode 100644 index 0000000..83eff7a --- /dev/null +++ b/src/Pairing/Modular.hs @@ -0,0 +1,85 @@ +module Pairing.Modular where + +import Protolude +import Math.NumberTheory.Moduli.Class +import Math.NumberTheory.Moduli.Sqrt +import Math.NumberTheory.UniqueFactorisation +import Pairing.Params +import Crypto.Random (MonadRandom) +import Crypto.Number.Generate (generateMax) +import qualified Data.ByteString as BS + +-- Mod conversion and management +withQ :: (forall m . KnownNat m => Proxy m -> r) -> r +withQ cont = case someNatVal _q of + Nothing -> panic ("Somehow " <> show _q <> " was not a Nat") + Just (SomeNat mName) -> cont mName + +-- Mod conversion and management +withQM :: (forall n. KnownNat n => Proxy n -> m r) -> m r +withQM cont = case someNatVal _q of + Nothing -> panic ("Somehow " <> show _q <> " was not a Nat") + Just (SomeNat mName) -> cont mName + +newMod :: forall m . KnownNat m => Integer -> Proxy m -> Mod m +newMod n mName = fromInteger @(Mod m) n + +toInteger :: Mod m -> Integer +toInteger = getVal + +modUnOp :: forall m . KnownNat m => Integer -> (Mod m -> Mod m) -> Proxy m -> Integer +modUnOp n f mName = getVal $ f (fromInteger @(Mod m) n) + +modBinOp :: forall m . KnownNat m => Integer -> Integer -> (Mod m -> Mod m -> Mod m) -> Proxy m -> Integer +modBinOp r s f mName = getVal $ f (fromInteger @(Mod m) r) (fromInteger @(Mod m) s) + +multInverse :: KnownNat m => Mod m -> Maybe (Mod m) +multInverse n = do + m <- isMultElement n + let mm = invertGroup m + pure (multElement mm) + +modUnOpM :: forall m a . (KnownNat m, Monad a) => Integer -> (Mod m -> a (Mod m)) -> Proxy m -> a Integer +modUnOpM n f mName = do + a <- f (fromInteger @(Mod m) n) + pure (getVal a) + +modPow :: Integral p => Integer -> p -> Integer +modPow a b = withQ (modUnOp a (flip powMod b)) + +modSqrt :: Integer -> [Integer] +modSqrt a = withQ (modUnOpM a sqrtsMod) + +threeModFourCongruence :: Integer -> Bool +threeModFourCongruence q = q `mod` 4 == 3 `mod` 4 + +isSquare :: forall m . KnownNat m => Proxy m -> Mod m -> Bool +isSquare _ a = if (threeModFourCongruence _q) then (length kp > 0) else False + where + kp = sqrtsMod a + +isSquareIn3Mod4 :: Integer -> Integer +isSquareIn3Mod4 a = if (threeModFourCongruence _q) then sq else 0 + where + sq = withQ (modUnOp a f) + f m = m `powMod` p2 + p2 = (_q + 1) `quot` 4 + +legendre :: Integer -> Integer +legendre a = if conv > 1 then (-1) else conv + where + conv = withQ (modUnOp a f) + f m = m `powMod` p2 + p2 = (_q - 1) `quot` 2 + +randomMod :: forall n m. (MonadRandom m, KnownNat n) => Proxy n -> m (Mod n) +randomMod mName = do + seed <- generateMax _q + pure (fromInteger @(Mod n) seed) + +fromBytes :: forall n. (KnownNat n) => ByteString -> Proxy n -> Mod n +fromBytes bs mn = newMod (fromBytes' bs) mn + where + fromBytes' :: ByteString -> Integer + fromBytes' = BS.foldl' f 0 + f a b = a `shiftL` 8 .|. fromIntegral b \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index a5f2bd8..ac8c0dc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,7 +38,8 @@ packages: # Dependency packages to be pulled from upstream that are not in the resolver # using the same syntax as the packages field. # (e.g., acme-missiles-0.3) -# extra-deps: [] +extra-deps: + - arithmoi-0.8.0.0 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/tests/TestGroups.hs b/tests/TestGroups.hs index ad52a95..213916f 100644 --- a/tests/TestGroups.hs +++ b/tests/TestGroups.hs @@ -13,7 +13,9 @@ import Pairing.Params import Test.Tasty import Test.Tasty.QuickCheck import Test.Tasty.HUnit - +import qualified Test.QuickCheck.Monadic as TQM (monadicIO, assert) +import Test.QuickCheck.Instances () +import Data.ByteString as BS (null, dropWhile) import TestCommon ------------------------------------------------------------------------------- @@ -59,6 +61,11 @@ unit_order_g1_valid :: Assertion unit_order_g1_valid = gMul g1 _r @=? Infinity +prop_hashToG1 :: ByteString -> Property +prop_hashToG1 bs = TQM.monadicIO $ do + toCurve <- liftIO (hashToG1 bs) + TQM.assert (isOnCurveG1 toCurve) + ------------------------------------------------------------------------------- -- G2 -------------------------------------------------------------------------------