Added the Shallue van de Woestijne encoding for curve hashing (#1)

* Added the Shallue van de Woestijne encoding for curve hashing

* Added stack extras, comments, and hash zero bytestring

.gitignore

@@ -6,3 +6,5 @@ pairing.cabal
 *~
 *.hi
 *.o
+.ghc.environment.*
+dist*/

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"

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

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,14 +15,21 @@ module Pairing.Fq (
   fqOne,
   fqNqr,
   euclidean,
-  random
+  random,
+  Pairing.Fq.fromBytes
 ) where
 
 import Protolude
 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,35 +59,35 @@ 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
 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)
+
+

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)

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'))

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

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: {}

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
 -------------------------------------------------------------------------------