Skip to content

Commit

Permalink
Added the Shallue van de Woestijne encoding for curve hashing (#1)
Browse files Browse the repository at this point in the history
* Added the Shallue van de Woestijne encoding for curve hashing

* Added stack extras, comments, and hash zero bytestring
  • Loading branch information
sumo authored and sdiehl committed Mar 4, 2019
1 parent f1cb570 commit f91e493
Show file tree
Hide file tree
Showing 9 changed files with 242 additions and 14 deletions.
2 changes: 2 additions & 0 deletions .gitignore
Original file line number Diff line number Diff line change
Expand Up @@ -6,3 +6,5 @@ pairing.cabal
*~
*.hi
*.o
.ghc.environment.*
dist*/
5 changes: 5 additions & 0 deletions bench/BenchPairing.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down Expand Up @@ -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"
Expand Down
16 changes: 16 additions & 0 deletions package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,7 @@ dependencies:
- memory
- wl-pprint-text
- QuickCheck
- arithmoi

library:
source-dirs: src
Expand Down Expand Up @@ -68,6 +69,15 @@ library:
- OverloadedStrings
- NoImplicitPrelude
- FlexibleInstances
- ExplicitForAll
- RankNTypes
- DataKinds
- KindSignatures
- GeneralizedNewtypeDeriving
- TypeApplications
- ExistentialQuantification
- ScopedTypeVariables
- DeriveGeneric

exposed-modules:
- Pairing.Params
Expand All @@ -81,6 +91,10 @@ library:
- Pairing.Pairing
- Pairing.Jacobian
- Pairing.CyclicGroup
- Pairing.Hash

other-modules:
- Pairing.Modular

tests:
test-circuit-compiler:
Expand All @@ -93,6 +107,7 @@ tests:
- tasty-discover
- tasty-hunit
- tasty-quickcheck
- quickcheck-instances
- QuickCheck

benchmarks:
Expand All @@ -108,3 +123,4 @@ benchmarks:
- tasty
- tasty-quickcheck
- tasty-hunit
- quickcheck-instances
32 changes: 20 additions & 12 deletions src/Pairing/Fq.hs
Original file line number Diff line number Diff line change
@@ -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:
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)


18 changes: 18 additions & 0 deletions src/Pairing/Group.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,9 @@ module Pairing.Group (
g2,
b1,
b2,
hashToG1,
randomG1,
randomG2
) where

import Protolude
Expand All @@ -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
Expand Down Expand Up @@ -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)
86 changes: 86 additions & 0 deletions src/Pairing/Hash.hs
Original file line number Diff line number Diff line change
@@ -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'))
85 changes: 85 additions & 0 deletions src/Pairing/Modular.hs
Original file line number Diff line number Diff line change
@@ -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
3 changes: 2 additions & 1 deletion stack.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -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: {}
Expand Down
9 changes: 8 additions & 1 deletion tests/TestGroups.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

-------------------------------------------------------------------------------
Expand Down Expand Up @@ -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
-------------------------------------------------------------------------------
Expand Down

0 comments on commit f91e493

Please sign in to comment.