diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Change log for pairing +## 0.5 + +* Use `elliptic-curve` for BN254 elliptic curve group operations. +* Refactor Shallue-van de Woestijne encoding for efficiency. +* Temporarily remove serialisation. + ## 0.4.2 * Fix overlapping instances of `Ord`. @@ -11,7 +17,7 @@ ## 0.4 -* Use `galois-field` for tower field underlying BN128 curve. +* Use `galois-field` for tower field underlying BN254 curve. ## 0.3.1 @@ -25,7 +31,7 @@ ## 0.2 -* Add Shallue van de Woestijne encoding for curve hashing. +* Add Shallue-van de Woestijne encoding for curve hashing. ## 0.1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,6 @@

-[![CircleCI](https://circleci.com/gh/adjoint-io/pairing.svg?style=svg&circle-token=ac95d02ba07e02b88585397f91cfe92a8c833343)](https://circleci.com/gh/adjoint-io/pairing) [![Hackage](https://img.shields.io/hackage/v/pairing.svg)](https://hackage.haskell.org/package/pairing) Implementation of the Barreto-Naehrig (BN) curve construction from diff --git a/bench/BenchPairing.hs b/bench/BenchPairing.hs deleted file mode 100644 --- a/bench/BenchPairing.hs +++ /dev/null @@ -1,248 +0,0 @@ -module BenchPairing (benchmarks) where - -import Protolude - -import Criterion.Main -import ExtensionField -import GaloisField -import Pairing.CyclicGroup (asInteger) -import qualified Pairing.Fq as Fq -import qualified Pairing.Fr as Fr -import qualified Pairing.Group as Group -import qualified Pairing.Pairing as Pairing -import qualified Pairing.Point as Point - -------------------------------------------------------------------------------- --- Benchmark Suite -------------------------------------------------------------------------------- - -testFq_1:: Fq.Fq -testFq_1 = 5216004179354450092383934373463611881445186046129513844852096383579774061693 - -testFq_2 :: Fq.Fq -testFq_2 = 10757805228921058098980668000791497318123219899766237205512608761387909753942 - -testFr_1 :: Fr.Fr -testFr_1 = 2695867032484221784304381330654541950835516252740416091986521990446187260192 - -testFr_2 :: Fr.Fr -testFr_2 = 18361718052247311177607809961708721447660708684581683997732416822928487385039 - -testFq2_1 :: Fq.Fq2 -testFq2_1 = toField - [ 19908898611787582971615951530393785823319364696376311494770162270472288380562 - , 2444690988583914246674870181013910409542697083717824402984851238236041783759 ] - -testFq2_2 :: Fq.Fq2 -testFq2_2 = toField - [ 176307305890807650390915550856467756101144733976249050387177647283239486934 - , 9913547941088878400547309488585076816688958962210000330808066250849942240036 ] - -testFq6_1 :: Fq.Fq6 -testFq6_1 = toField - [ toField - [ 8727269669017421992537561450387212506711577304101544328736696625792447584819 - , 14548604791762199086915107662335514800873255588931510951007415299299859294564 ] - , toField - [ 12226353852518517213098257637254082040554292743096797524265221809863992104040 - , 12690801089710533803594523982915673248220237967492611523932652691226365708512 ] - , toField - [ 18336930404004840796680535059992401039831316705513753839479258873269709495858 - , 21634580953983557175729336703450663797341055784728343534694506874757389871868 ] - ] - -testFq6_2 :: Fq.Fq6 -testFq6_2 = toField - [ toField - [ 21427158918811764040959407626476119248515601360702754918240300689672054041331 - , 12750457256357562507331331307761996193149796736574153338180573114576232473092 ] - , toField - [ 19307896751125425658868292427117755307914453765471505616446813557567103424424 - , 11511704315039881938763578963465960361806962511008317843374696569679546862720 ] - , toField - [ 16856354813335682789816416666746807604324955216244680818919639213184967817815 - , 10563739714379631354612735346769824530666877338817980746884577737330686430079 ] - ] - -testFq12_1 :: Fq.Fq12 -testFq12_1 = Fq.construct - [ 4025484419428246835913352650763180341703148406593523188761836807196412398582 - , 5087667423921547416057913184603782240965080921431854177822601074227980319916 - , 8868355606921194740459469119392835913522089996670570126495590065213716724895 - , 12102922015173003259571598121107256676524158824223867520503152166796819430680 - , 92336131326695228787620679552727214674825150151172467042221065081506740785 - , 5482141053831906120660063289735740072497978400199436576451083698548025220729 - , 7642691434343136168639899684817459509291669149586986497725240920715691142493 - , 1211355239100959901694672926661748059183573115580181831221700974591509515378 - , 20725578899076721876257429467489710434807801418821512117896292558010284413176 - , 17642016461759614884877567642064231230128683506116557502360384546280794322728 - , 17449282511578147452934743657918270744212677919657988500433959352763226500950 - , 1205855382909824928004884982625565310515751070464736233368671939944606335817 - ] - -testFq12_2 :: Fq.Fq12 -testFq12_2 = Fq.construct - [ 495492586688946756331205475947141303903957329539236899715542920513774223311 - , 9283314577619389303419433707421707208215462819919253486023883680690371740600 - , 11142072730721162663710262820927009044232748085260948776285443777221023820448 - , 1275691922864139043351956162286567343365697673070760209966772441869205291758 - , 20007029371545157738471875537558122753684185825574273033359718514421878893242 - , 9839139739201376418106411333971304469387172772449235880774992683057627654905 - , 9503058454919356208294350412959497499007919434690988218543143506584310390240 - , 19236630380322614936323642336645412102299542253751028194541390082750834966816 - , 18019769232924676175188431592335242333439728011993142930089933693043738917983 - , 11549213142100201239212924317641009159759841794532519457441596987622070613872 - , 9656683724785441232932664175488314398614795173462019188529258009817332577664 - , 20666848762667934776817320505559846916719041700736383328805334359135638079015 - ] - -test_g1_1 :: Group.G1 -test_g1_1 = Point.Point - 4312786488925573964619847916436127219510912864504589785209181363209026354996 - 16161347681839669251864665467703281411292235435048747094987907712909939880451 - -test_g1_2 :: Group.G1 -test_g1_2 = Point.Point - 19726521232578388179442373599749745040559336202710626280058164737015167983668 - 8916054282623787320277288879860012889871960646705282620719014698393441239502 - -test_g2_1 :: Group.G2 -test_g2_1 = Point.Point - (toField - [ 7883069657575422103991939149663123175414599384626279795595310520790051448551 - , 8346649071297262948544714173736482699128410021416543801035997871711276407441 ] - ) - (toField - [ 3343323372806643151863786479815504460125163176086666838570580800830972412274 - , 16795962876692295166012804782785252840345796645199573986777498170046508450267 ] - ) - -test_g2_2 :: Group.G2 -test_g2_2 = Point.Point - (toField - [ 3243608945627071355385114622932133122087974401138668305336804137033580208808 - , 2403320200938270623472619242963887735471304641554649101656774729615146397552 ] - ) - (toField - [ 7590136428571280465598215063146990078553196689176860926896020586846726844869 - , 8036135660414384292776446470327730948618639044617118659780848199544099832559 ] - ) - -test_hash :: ByteString -test_hash = "TyqIPUBYojDVOnDPacfMGrGOzpaQDWD3KZCpqzLhpE4A3kRUCQFUx040Ok139J8WDVV2C99Sfge3G20Q8MEgu23giWmqRxqOc8pH" - -benchmarks :: [Benchmark] -benchmarks = - [ bgroup "Frobenius in Fq12" - [ bench "naive" - $ whnf (Pairing.frobeniusNaive 1) testFq12_1 - , bench "fast" - $ whnf (Fq.fq12Frobenius 1) testFq12_1 - ] - , bgroup "Final exponentiation" - [ bench "naive" - $ whnf Pairing.finalExponentiationNaive testFq12_1 - , bench "fast" - $ whnf Pairing.finalExponentiation testFq12_1 - ] - , bgroup "Pairing" - [ bench "without final exponentiation" - $ whnf (uncurry Pairing.atePairing) (Group.g1, Group.g2) - , bench "with final exponentiation" - $ whnf (uncurry Pairing.reducedPairing) (Group.g1, Group.g2) - ] - , bgroup "Fq" - [ bench "multiplication" - $ whnf (uncurry (*)) (testFq_1, testFq_2) - , bench "addition" - $ whnf (uncurry (+)) (testFq_1, testFq_2) - , bench "division" - $ whnf (uncurry (/)) (testFq_1, testFq_2) - , bench "pow" - $ whnf (testFq_1 `pow`) (asInteger testFr_1) - , bench "inversion" - $ whnf recip testFq_1 - , bench "fqFromX" - $ whnf (Fq.fqYforX testFq_1) max - ] - , bgroup "Fr" - [ bench "multiplication" - $ whnf (uncurry (*)) (testFr_1, testFr_2) - , bench "addition" - $ whnf (uncurry (+)) (testFr_1, testFr_2) - , bench "division" - $ whnf (uncurry (/)) (testFr_1, testFr_2) - , bench "inversion" - $ whnf recip testFr_1 - , bench "pow" - $ whnf (testFr_1 ^) (asInteger testFr_2) - ] - , bgroup "Fq2" - [ bench "multiplication" - $ whnf (uncurry (*)) (testFq2_1, testFq2_2) - , bench "addition" - $ whnf (uncurry (+)) (testFq2_1, testFq2_2) - , bench "division" - $ whnf (uncurry (/)) (testFq2_1, testFq2_2) - , bench "squaring" - $ whnf (^ 2) testFq2_1 - , bench "pow" - $ whnf (testFq2_1 `pow`) (asInteger testFr_1) - , bench "negation" - $ whnf negate testFq2_1 - , bench "inversion" - $ whnf recip testFq2_1 - , bench "conjugation" - $ whnf Fq.fq2Conj testFq2_1 - , bench "square root" - $ whnf Fq.fq2Sqrt testFq2_1 - , bench "fq2FromX" - $ whnf (Fq.fq2YforX testFq2_1) max - ] - , bgroup "Fq6" - [ bench "multiplication" - $ whnf (uncurry (*)) (testFq6_1, testFq6_2) - , bench "addition" - $ whnf (uncurry (+)) (testFq6_1, testFq6_2) - , bench "division" - $ whnf (uncurry (/)) (testFq6_1, testFq6_2) - , bench "squaring" - $ whnf (^ 2) testFq6_1 - , bench "negation" - $ whnf negate testFq6_1 - , bench "inversion" - $ whnf recip testFq6_1 - ] - , bgroup "Fq12" - [ bench "multiplication" - $ whnf (uncurry (*)) (testFq12_1, testFq12_2) - , bench "addition" - $ whnf (uncurry (+)) (testFq12_1, testFq12_2) - , bench "division" - $ whnf (uncurry (/)) (testFq12_1, testFq12_2) - , bench "negation" - $ whnf negate testFq12_1 - , bench "inversion" - $ whnf recip testFq12_1 - , bench "conjugation" - $ whnf Fq.fq12Conj testFq12_1 - ] - , bgroup "G1" - [ bench "double" - $ whnf Point.gDouble test_g1_1 - , bench "add" - $ 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" - [ bench "double" - $ whnf Point.gDouble test_g2_1 - , bench "add" - $ whnf (uncurry Point.gAdd) (test_g2_1, test_g2_2) - , bench "multiply" - $ whnf (uncurry Point.gMul) (test_g2_1, 42) - ] - ] diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 --- a/bench/Main.hs +++ /dev/null @@ -1,13 +0,0 @@ --- To get the benchmarking data, run "stack bench". - -module Main where - -import Protolude - -import Criterion.Main - -import qualified BenchPairing as Pairing - -main = defaultMain - [ bgroup "Pairing" Pairing.benchmarks - ] diff --git a/benchmarks/HashBenchmarks.hs b/benchmarks/HashBenchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmarks/HashBenchmarks.hs @@ -0,0 +1,17 @@ +module HashBenchmarks where + +import Protolude + +import Criterion.Main +import Pairing.Hash + +benchmarkHash :: Benchmark +benchmarkHash = bgroup "Hash" + [ bgroup "Hash to G1" + [ bench "swEncBN" + $ whnfIO (swEncBN test_hash) + ] + ] + +test_hash :: ByteString +test_hash = "TyqIPUBYojDVOnDPacfMGrGOzpaQDWD3KZCpqzLhpE4A3kRUCQFUx040Ok139J8WDVV2C99Sfge3G20Q8MEgu23giWmqRxqOc8pH" diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Protolude + +import Criterion.Main + +import HashBenchmarks +import PairingBenchmarks + +main :: IO () +main = defaultMain + [benchmarkHash, benchmarkPairing] diff --git a/benchmarks/PairingBenchmarks.hs b/benchmarks/PairingBenchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmarks/PairingBenchmarks.hs @@ -0,0 +1,34 @@ +module PairingBenchmarks where + +import Protolude + +import Control.Monad.Random +import Criterion.Main +import GaloisField +import Pairing.Curve +import Pairing.Pairing + +benchmarkPairing :: Benchmark +benchmarkPairing = bgroup "Pairing" + [ bgroup "Frobenius in Fq12" + [ bench "naive" + $ whnf (frobeniusNaive 1) testFq12 + , bench "fast" + $ whnf (fq12Frobenius 1) testFq12 + ] + , bgroup "Final exponentiation" + [ bench "naive" + $ whnf finalExponentiationNaive testFq12 + , bench "fast" + $ whnf finalExponentiation testFq12 + ] + , bgroup "Pairing" + [ bench "without final exponentiation" + $ whnf (uncurry atePairing) (gG1, gG2) + , bench "with final exponentiation" + $ whnf (uncurry reducedPairing) (gG1, gG2) + ] + ] + +testFq12 :: Fq12 +testFq12 = evalRand rnd (mkStdGen 0) diff --git a/pairing.cabal b/pairing.cabal --- a/pairing.cabal +++ b/pairing.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 8756cf9d25050b2735941c749a9fa41f381c79117dae3353b4453d7d1318c65e +-- hash: 989fbbc05f694224014af023e74794a8b42a03f96549681b5404623aee4ec01c name: pairing -version: 0.4.2 +version: 0.5.0 synopsis: Bilinear pairings description: Optimal Ate pairing over Barreto-Naehrig curves category: Cryptography @@ -27,86 +27,63 @@ library exposed-modules: - Pairing.Params - Pairing.Fq - Pairing.Fr - Pairing.Point - Pairing.Group - Pairing.Pairing - Pairing.Jacobian - Pairing.CyclicGroup + Pairing.ByteRepr + Pairing.Curve Pairing.Hash + Pairing.Pairing Pairing.Serialize.Types Pairing.Serialize.Jivsov Pairing.Serialize.MCLWasm - Pairing.ByteRepr - Pairing.Modular other-modules: Paths_pairing hs-source-dirs: src - default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes BangPatterns DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric GeneralizedNewtypeDeriving MultiParamTypeClasses PatternSynonyms TypeApplications - ghc-options: -fwarn-tabs -fwarn-incomplete-patterns -fwarn-incomplete-record-updates -fwarn-redundant-constraints -fwarn-implicit-prelude -fwarn-overflowed-literals -fwarn-orphans -fwarn-identities -fwarn-dodgy-exports -fwarn-dodgy-imports -fwarn-duplicate-exports -fwarn-overlapping-patterns -fwarn-missing-fields -fwarn-missing-methods -fwarn-missing-signatures -fwarn-noncanonical-monad-instances -fwarn-unused-pattern-binds -fwarn-unused-type-patterns -fwarn-unrecognised-pragmas -fwarn-wrong-do-bind -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind -Wmissing-export-lists + default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes BangPatterns DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric GeneralizedNewtypeDeriving MultiParamTypeClasses PatternSynonyms TypeApplications TypeSynonymInstances + ghc-options: -freverse-errors -Wall build-depends: MonadRandom , QuickCheck - , arithmoi >=0.8 - , base >=4.7 && <5 - , binary + , base >=4.10 && <5 , bytestring + , elliptic-curve >=0.2 && <0.3 , errors - , galois-field ==0.4.0 - , integer-logarithms - , memory + , galois-field >=0.4 && <0.5 , protolude >=0.2 - , random , wl-pprint-text default-language: Haskell2010 test-suite pairing-tests type: exitcode-stdio-1.0 - main-is: Driver.hs + main-is: Main.hs other-modules: Pairing.ByteRepr - Pairing.CyclicGroup - Pairing.Fq - Pairing.Fr - Pairing.Group + Pairing.Curve Pairing.Hash - Pairing.Jacobian - Pairing.Modular Pairing.Pairing - Pairing.Params - Pairing.Point Pairing.Serialize.Jivsov Pairing.Serialize.MCLWasm Pairing.Serialize.Types - TestCommon - TestFields - TestGroups - TestPairing + ByteTests + HashTests + PairingTests + SerializeTests Paths_pairing hs-source-dirs: src tests - default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric MultiParamTypeClasses PatternSynonyms TypeApplications TypeSynonymInstances + default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes BangPatterns DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric GeneralizedNewtypeDeriving MultiParamTypeClasses PatternSynonyms TypeApplications TypeSynonymInstances + ghc-options: -freverse-errors -Wall -main-is Main build-depends: MonadRandom , QuickCheck - , arithmoi >=0.8 - , base >=4.7 && <5 - , binary + , base >=4.10 && <5 , bytestring + , elliptic-curve >=0.2 && <0.3 , errors - , galois-field ==0.4.0 - , hexstring - , integer-logarithms - , memory + , galois-field >=0.4 && <0.5 , protolude >=0.2 , quickcheck-instances - , random , tasty - , tasty-discover , tasty-hunit , tasty-quickcheck , wl-pprint-text @@ -116,26 +93,32 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - BenchPairing + Pairing.ByteRepr + Pairing.Curve + Pairing.Hash + Pairing.Pairing + Pairing.Serialize.Jivsov + Pairing.Serialize.MCLWasm + Pairing.Serialize.Types + HashBenchmarks + PairingBenchmarks + Paths_pairing hs-source-dirs: src - bench - default-extensions: NoImplicitPrelude OverloadedStrings FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric MultiParamTypeClasses PatternSynonyms TypeApplications + benchmarks + default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances FlexibleContexts ScopedTypeVariables RankNTypes BangPatterns DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric GeneralizedNewtypeDeriving MultiParamTypeClasses PatternSynonyms TypeApplications TypeSynonymInstances + ghc-options: -freverse-errors -Wall -main-is Main build-depends: MonadRandom , QuickCheck - , arithmoi >=0.8 - , base >=4.7 && <5 - , binary + , base >=4.10 && <5 , bytestring , criterion + , elliptic-curve >=0.2 && <0.3 , errors - , galois-field ==0.4.0 - , integer-logarithms - , memory + , galois-field >=0.4 && <0.5 , protolude >=0.2 , quickcheck-instances - , random , tasty , tasty-hunit , tasty-quickcheck diff --git a/src/Pairing/ByteRepr.hs b/src/Pairing/ByteRepr.hs --- a/src/Pairing/ByteRepr.hs +++ b/src/Pairing/ByteRepr.hs @@ -1,21 +1,33 @@ -module Pairing.ByteRepr ( - ByteRepr(..), - toBytes, - toPaddedBytes, - fromBytesToInteger, - ByteOrder(..), - ByteOrderLength(..) -) where +module Pairing.ByteRepr + ( ByteOrder(..) + , ByteOrderLength(..) + , ByteRepr(..) + , fromBytesToInteger + , toBytes + , toPaddedBytes + ) where import Protolude -import Data.ByteString as B +import qualified Data.ByteString as B +import PrimeField (toInt) +import ExtensionField (fromField, toField) -data ByteOrder = MostSignificantFirst | LeastSignificantFirst +import Pairing.Curve (Fq, Fq2, Fq6, Fq12) +------------------------------------------------------------------------------- +-- Bytes +------------------------------------------------------------------------------- + +data ByteOrder = MostSignificantFirst + | LeastSignificantFirst + type ElementLength = Int -data ByteOrderLength = ByteOrderLength { byteOrder :: ByteOrder, lenPerElement :: ElementLength } +data ByteOrderLength = ByteOrderLength + { byteOrder :: ByteOrder + , lenPerElement :: ElementLength + } class ByteRepr a where mkRepr :: ByteOrderLength -> a -> Maybe ByteString @@ -29,24 +41,87 @@ changeSign | x < 0 = subtract 1 . negate | otherwise = identity go :: Integer -> (Word8, Maybe Integer) - go x = (b, i) + go y = (b, i) where - b = changeSign (fromInteger x) - i | x >= 128 = Just (x `shiftR` 8) + b = changeSign (fromInteger y) + i | y >= 128 = Just (y `shiftR` 8) | otherwise = Nothing toPaddedBytes :: ByteOrderLength -> Integer -> Maybe ByteString -toPaddedBytes bo a = case byteOrder bo of +toPaddedBytes bo a = case byteOrder bo of LeastSignificantFirst -> B.reverse <$> mkbs (toBytes a) MostSignificantFirst -> mkbs (toBytes a) where mkbs bs - | B.length bs > lenPerElement bo = Nothing + | B.length bs > lenPerElement bo = Nothing | B.length bs == lenPerElement bo = Just bs - | otherwise = Just (B.append (B.replicate (lenPerElement bo - B.length bs) 0x0) bs) + | otherwise = Just (B.append (B.replicate (lenPerElement bo - B.length bs) 0x0) bs) fromBytesToInteger :: ByteOrder -> ByteString -> Integer fromBytesToInteger MostSignificantFirst = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b fromBytesToInteger LeastSignificantFirst = (fromBytesToInteger MostSignificantFirst) . B.reverse + +------------------------------------------------------------------------------- +-- Fields +------------------------------------------------------------------------------- + +instance ByteRepr Fq where + mkRepr bo = toPaddedBytes bo <$> toInt + fromRepr bo _ bs = Just (fromInteger (fromBytesToInteger (byteOrder bo) bs)) + calcReprLength _ n = n + +instance ByteRepr Fq2 where + mkRepr bo f2 = foldl' (<>) mempty (map (mkRepr bo) (fq2Bytes f2)) + where + fq2Bytes w = case fromField w of + [x, y] -> [x, y] + [x] -> [x, 0] + [] -> [0, 0] + _ -> panic "unreachable." + fromRepr bo _ bs = do + let + blen = calcReprLength (1 :: Fq) $ lenPerElement bo + (xbs, ybs) = B.splitAt blen bs + x <- fromRepr bo (1 :: Fq) xbs + y <- fromRepr bo (1 :: Fq) ybs + return (toField [x, y]) + calcReprLength _ n = 2 * calcReprLength (1 :: Fq) n + +instance ByteRepr Fq6 where + mkRepr bo f6 = foldl' (<>) mempty (map (mkRepr bo) (fq6Bytes f6)) + where + fq6Bytes w = case fromField w of + [x, y, z] -> [x, y, z] + [x, y] -> [x, y, 0] + [x] -> [x, 0, 0] + [] -> [0, 0, 0] + _ -> panic "unreachable." + fromRepr bo _ bs = do + let + blen = calcReprLength (1 :: Fq2) $ lenPerElement bo + (xbs, yzbs) = B.splitAt blen bs + (ybs, zbs) = B.splitAt blen yzbs + x <- fromRepr bo (1 :: Fq2) xbs + y <- fromRepr bo (1 :: Fq2) ybs + z <- fromRepr bo (1 :: Fq2) zbs + return (toField [x, y, z]) + calcReprLength _ n = 3 * calcReprLength (1 :: Fq2) n + +instance ByteRepr Fq12 where + mkRepr bo f12 = foldl' (<>) mempty (map (mkRepr bo) (fq12Bytes f12)) + where + fq12Bytes w = case fromField w of + [x, y] -> [x, y] + [x] -> [x, 0] + [] -> [0, 0] + _ -> panic "unreachable." + fromRepr bo _ bs = do + let + blen = calcReprLength (1 :: Fq6) $ lenPerElement bo + (xbs, ybs) = B.splitAt blen bs + x <- fromRepr bo (1 :: Fq6) xbs + y <- fromRepr bo (1 :: Fq6) ybs + return (toField [x, y]) + calcReprLength _ n = 2 * calcReprLength (1 :: Fq6) n diff --git a/src/Pairing/Curve.hs b/src/Pairing/Curve.hs new file mode 100644 --- /dev/null +++ b/src/Pairing/Curve.hs @@ -0,0 +1,285 @@ +module Pairing.Curve + ( + -- * Galois fields + Fq + , Fq2 + , Fq6 + , Fq12 + , Fr + -- * Elliptic curves + , G1 + , G2 + , G2' + , GT + , gG1 + , gG2 + , gGT + , rG1 + , rG2 + , rGT + -- * Parameters + , _a + , _a' + , _b + , _b' + , _k + , _nqr + , _q + , _r + , _t + , _xi + -- * Miscellaneous functions + , conj + , getYfromX + , scale + , mulXi + , fq12Frobenius + , isRootOfUnity + , isPrimitiveRootOfUnity + , primitiveRootOfUnity + , precompRootOfUnity + -- , fromByteStringG1 + -- , fromByteStringG2 + -- , fromByteStringGT + ) where + +import Protolude + +import Curve (Curve(..)) +import qualified Curve.Weierstrass.BN254 as BN254 +import qualified Curve.Weierstrass.BN254T as BN254T +import ExtensionField (ExtensionField, IrreducibleMonic, fromField, toField) +import GaloisField (GaloisField(..)) +import qualified Group.Field.BN254TF as BN254TF + +-- import Pairing.Serialize.Types + +------------------------------------------------------------------------------- +-- Galois fields +------------------------------------------------------------------------------- + +-- | Prime field @Fq@. +type Fq = BN254.Fq + +-- | Quadratic extension field of @Fq@ defined as @Fq2 = Fq[u]/@. +type Fq2 = BN254T.Fq2 + +-- | Cubic extension field of @Fq2@ defined as @Fq6 = Fq2[v]/@. +type Fq6 = BN254TF.Fq6 + +-- | Quadratic extension field of @Fq6@ defined as @Fq12 = Fq6[w]/@. +type Fq12 = BN254TF.Fq12 + +-- | Prime field @Fr@. +type Fr = BN254.Fr + +------------------------------------------------------------------------------- +-- Elliptic curves +------------------------------------------------------------------------------- + +-- | G1 is @E(Fq)@ defined by @y^2 = x^3 + b@. +type G1 = BN254.PA + +-- | G2 is @E'(Fq2)@ defined by @y^2 = x^3 + b / xi@. +type G2 = BN254T.PA + +-- | G2' is G2 in Jacobian coordinates. +type G2' = BN254T.PJ + +-- | GT is subgroup of @r@-th roots of unity of the multiplicative group of @Fq12@. +type GT = BN254TF.P + +-- | Generator of G1. +gG1 :: G1 +gG1 = BN254.gA + +-- | Generator of G2. +gG2 :: G2 +gG2 = BN254T.gA + +-- | Generator of GT. +gGT :: GT +gGT = BN254TF.g_ + +-- | Order of G1. +rG1 :: Integer +rG1 = BN254._r + +-- | Order of G2. +rG2 :: Integer +rG2 = BN254T._r + +-- | Order of GT. +rGT :: Integer +rGT = BN254TF._r + +------------------------------------------------------------------------------- +-- Parameters +------------------------------------------------------------------------------- + +-- | Elliptic curve @E(Fq)@ coefficient @A@, with @y = x^3 + Ax + B@. +_a :: Fq +_a = BN254._a + +-- | Elliptic curve @E(Fq2)@ coefficient @A'@, with @y = x^3 + A'x + B'@. +_a' :: Fq2 +_a' = BN254T._a + +-- | Elliptic curve @E(Fq)@ coefficient @B@, with @y = x^3 + Ax + B@. +_b :: Fq +_b = BN254._b + +-- | Elliptic curve @E(Fq2)@ coefficient @B'@, with @y = x^3 + A'x + B'@. +_b' :: Fq2 +_b' = BN254T._b + +-- | Embedding degree. +_k :: Integer +_k = 12 + +-- | Quadratic nonresidue in @Fq@. +_nqr :: Integer +_nqr = 21888242871839275222246405745257275088696311157297823662689037894645226208582 + +-- | Characteristic of finite fields. +_q :: Integer +_q = BN254._q + +-- | Order of G1 and characteristic of prime field of exponents. +_r :: Integer +_r = BN254._r + +-- | BN parameter that determines the prime @_q@. +_t :: Integer +_t = 4965661367192848881 + +-- | Parameter of twisted curve over @Fq@. +_xi :: Fq2 +_xi = toField [9, 1] + +------------------------------------------------------------------------------- +-- Miscellaneous functions +------------------------------------------------------------------------------- + +-- | Conjugation. +conj :: forall k im . IrreducibleMonic k im + => ExtensionField k im -> ExtensionField k im +conj x + | deg x /= 2 * deg (witness :: k) = panic "conj: extension degree is not two." + | otherwise = case fromField x of + [y, z] -> toField [y, negate z] + [y] -> toField [y] + [] -> 0 + _ -> panic "conj: unreachable." +{-# INLINABLE conj #-} + +-- | Get Y coordinate from X coordinate given a curve and a choice function. +getYfromX :: Curve f c e q r => Point f c e q r -> (q -> q -> q) -> q -> Maybe q +getYfromX curve choose x = choose <*> negate <$> yX curve x +{-# INLINABLE getYfromX #-} + +-- | Scalar multiplication. +scale :: IrreducibleMonic k im => k -> ExtensionField k im -> ExtensionField k im +scale = (*) . toField . return +{-# INLINABLE scale #-} + +------------------------------------------------------------------------------- +-- Miscellaneous functions (temporary) +------------------------------------------------------------------------------- + +-- | Multiply by @_xi@ (cubic nonresidue in @Fq2@) and reorder coefficients. +mulXi :: Fq6 -> Fq6 +mulXi w = case fromField w of + [x, y, z] -> toField [z * _xi, x, y] + [x, y] -> toField [0, x, y] + [x] -> toField [0, x] + [] -> toField [] + _ -> panic "mulXi: not exhaustive." +{-# INLINE mulXi #-} + +-- | Iterated Frobenius automorphism in @Fq12@. +fq12Frobenius :: Int -> Fq12 -> Fq12 +fq12Frobenius i a + | i == 0 = a + | i == 1 = fastFrobenius a + | i > 1 = let prev = fq12Frobenius (i - 1) a in fastFrobenius prev + | otherwise = panic "fq12Frobenius: not defined for negative values of i." +{-# INLINABLE fq12Frobenius #-} + +-- | Fast Frobenius automorphism in @Fq12@. +fastFrobenius :: Fq12 -> Fq12 +fastFrobenius = coll . conv [[0,2,4],[1,3,5]] . cong + where + cong :: Fq12 -> [[Fq2]] + cong = map (map conj . fromField) . fromField + conv :: [[Integer]] -> [[Fq2]] -> [[Fq2]] + conv = zipWith (zipWith (\x y -> pow _xi ((x * (_q - 1)) `div` 6) * y)) + coll :: [[Fq2]] -> Fq12 + coll = toField . map toField +{-# INLINABLE fastFrobenius #-} + +-- | Check if an element is a root of unity. +isRootOfUnity :: Integer -> Fr -> Bool +isRootOfUnity n x + | n > 0 = pow x n == 1 + | otherwise = panic "isRootOfUnity: negative powers not supported." +{-# INLINABLE isRootOfUnity #-} + +-- | Check if an element is a primitive root of unity. +isPrimitiveRootOfUnity :: Integer -> Fr -> Bool +isPrimitiveRootOfUnity n x + | n > 0 = isRootOfUnity n x && all (\m -> not $ isRootOfUnity m x) [1 .. n - 1] + | otherwise = panic "isPrimitiveRootOfUnity: negative powers not supported." +{-# INLINABLE isPrimitiveRootOfUnity #-} + +-- | Compute primitive roots of unity for 2^0, 2^1, ..., 2^28. (2^28 +-- is the largest power of two that divides _r - 1, therefore there +-- are no primitive roots of unity for higher powers of 2 in Fr.) +primitiveRootOfUnity :: Int -> Fr +primitiveRootOfUnity k + | 0 <= k && k <= 28 = 5^((_r - 1) `div` (2^k)) + | otherwise = panic "primitiveRootOfUnity: no primitive root for given power of 2." +{-# INLINABLE primitiveRootOfUnity #-} + +-- | Precompute roots of unity. +precompRootOfUnity :: Int -> Fr +precompRootOfUnity 0 = 1 +precompRootOfUnity 1 = 21888242871839275222246405745257275088548364400416034343698204186575808495616 +precompRootOfUnity 2 = 21888242871839275217838484774961031246007050428528088939761107053157389710902 +precompRootOfUnity 3 = 19540430494807482326159819597004422086093766032135589407132600596362845576832 +precompRootOfUnity 4 = 14940766826517323942636479241147756311199852622225275649687664389641784935947 +precompRootOfUnity 5 = 4419234939496763621076330863786513495701855246241724391626358375488475697872 +precompRootOfUnity 6 = 9088801421649573101014283686030284801466796108869023335878462724291607593530 +precompRootOfUnity 7 = 10359452186428527605436343203440067497552205259388878191021578220384701716497 +precompRootOfUnity 8 = 3478517300119284901893091970156912948790432420133812234316178878452092729974 +precompRootOfUnity 9 = 6837567842312086091520287814181175430087169027974246751610506942214842701774 +precompRootOfUnity 10 = 3161067157621608152362653341354432744960400845131437947728257924963983317266 +precompRootOfUnity 11 = 1120550406532664055539694724667294622065367841900378087843176726913374367458 +precompRootOfUnity 12 = 4158865282786404163413953114870269622875596290766033564087307867933865333818 +precompRootOfUnity 13 = 197302210312744933010843010704445784068657690384188106020011018676818793232 +precompRootOfUnity 14 = 20619701001583904760601357484951574588621083236087856586626117568842480512645 +precompRootOfUnity 15 = 20402931748843538985151001264530049874871572933694634836567070693966133783803 +precompRootOfUnity 16 = 421743594562400382753388642386256516545992082196004333756405989743524594615 +precompRootOfUnity 17 = 12650941915662020058015862023665998998969191525479888727406889100124684769509 +precompRootOfUnity 18 = 11699596668367776675346610687704220591435078791727316319397053191800576917728 +precompRootOfUnity 19 = 15549849457946371566896172786938980432421851627449396898353380550861104573629 +precompRootOfUnity 20 = 17220337697351015657950521176323262483320249231368149235373741788599650842711 +precompRootOfUnity 21 = 13536764371732269273912573961853310557438878140379554347802702086337840854307 +precompRootOfUnity 22 = 12143866164239048021030917283424216263377309185099704096317235600302831912062 +precompRootOfUnity 23 = 934650972362265999028062457054462628285482693704334323590406443310927365533 +precompRootOfUnity 24 = 5709868443893258075976348696661355716898495876243883251619397131511003808859 +precompRootOfUnity 25 = 19200870435978225707111062059747084165650991997241425080699860725083300967194 +precompRootOfUnity 26 = 7419588552507395652481651088034484897579724952953562618697845598160172257810 +precompRootOfUnity 27 = 2082940218526944230311718225077035922214683169814847712455127909555749686340 +precompRootOfUnity 28 = 19103219067921713944291392827692070036145651957329286315305642004821462161904 +precompRootOfUnity _ = panic "precompRootOfUnity: exponent too big for Fr / negative" +{-# INLINABLE precompRootOfUnity #-} + +-- fromByteStringG1 :: FromSerialisedForm u => u -> LByteString -> Either Text G1 +-- fromByteStringG1 unser = unserializePoint unser generatorG1 . toSL + +-- fromByteStringG2 :: FromSerialisedForm u => u -> LByteString -> Either Text G2 +-- fromByteStringG2 unser = unserializePoint unser generatorG2 . toSL + +-- fromByteStringGT :: FromUncompressedForm u => u -> LByteString -> Either Text GT +-- fromByteStringGT unser = unserialize unser 1 . toSL diff --git a/src/Pairing/CyclicGroup.hs b/src/Pairing/CyclicGroup.hs deleted file mode 100644 --- a/src/Pairing/CyclicGroup.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Pairing.CyclicGroup - ( AsInteger(..) - , CyclicGroup(..) - , FromX(..) - , Validate(..) - , sumG - ) where - -import Protolude - -import Control.Monad.Random (MonadRandom) -import PrimeField (PrimeField, toInt) - -class AsInteger a where - asInteger :: a -> Integer - -type LargestY = Bool - -class Monoid g => CyclicGroup g where - generator :: g - order :: Proxy g -> Integer - expn :: AsInteger e => g -> e -> g - inverse :: g -> g - random :: MonadRandom m => m g - --- | Sum all the elements of some container according to its group --- structure. -sumG :: (Foldable t, CyclicGroup g) => t g -> g -sumG = fold - -instance AsInteger Int where - asInteger = toInteger - -instance AsInteger Integer where - asInteger = identity - --- Temporary solution. --- TODO: Maybe move these definitions to galois-field library -instance AsInteger (PrimeField p) where - asInteger = toInt - -class FromX a where - yFromX :: a -> (a -> a -> a) -> Maybe a - isOdd :: a -> Bool - -class Validate a where - isValidElement :: a -> Bool diff --git a/src/Pairing/Fq.hs b/src/Pairing/Fq.hs deleted file mode 100644 --- a/src/Pairing/Fq.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Prime field with characteristic _q, over which the elliptic curve --- is defined and the other finite field extensions. --- --- * Fq --- * Fq2 := Fq[u]/u^2 + 1 --- * Fq6 := Fq2[v]/v^3 - (9 + u) --- * Fq12 := Fq6[w]/w^2 - v -{-# LANGUAGE ViewPatterns #-} - -module Pairing.Fq - ( Fq - , Fq2 - , Fq6 - , Fq12 - , fqSqrt - , fq2Sqrt - , fqYforX - , fq2YforX - , fqNqr - , xi - , mulXi - , fq2Conj - , fq2ScalarMul - , construct - , deconstruct - , fq12Conj - , fq12Frobenius - ) where - -import Protolude - -import Data.ByteString as B (splitAt, length) -import ExtensionField (ExtensionField, IrreducibleMonic(..), fromField, toField, - pattern X, pattern X2, pattern X3, pattern Y) -import GaloisField (GaloisField(..)) -import Math.NumberTheory.Moduli.Class (powMod) -import PrimeField (PrimeField, toInt) - -import Pairing.ByteRepr -import Pairing.CyclicGroup -import Pairing.Modular -import Pairing.Params - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - --- | Prime field @Fq@ with characteristic @_q@ -type Fq = PrimeField 21888242871839275222246405745257275088696311157297823662689037894645226208583 - --- | Quadratic irreducible monic polynomial @f(u) = u^2 + 1@ -data PolynomialU -instance IrreducibleMonic Fq PolynomialU where - split _ = X2 + 1 - --- | Quadratic extension field of @Fq@ defined as @Fq2 = Fq[u]/@ -type Fq2 = ExtensionField Fq PolynomialU - --- | Cubic irreducible monic polynomial @g(v) = v^3 - (9 + u)@ -data PolynomialV -instance IrreducibleMonic Fq2 PolynomialV where - split _ = X3 - (9 + Y X) - --- | Cubic extension field of @Fq2@ defined as @Fq6 = Fq2[v]/@ -type Fq6 = ExtensionField Fq2 PolynomialV - --- | Quadratic irreducible monic polynomial @h(w) = w^2 - v@ -data PolynomialW -instance IrreducibleMonic Fq6 PolynomialW where - split _ = X2 - Y X - --- | Quadratic extension field of @Fq6@ defined as @Fq12 = Fq6[w]/@ -type Fq12 = ExtensionField Fq6 PolynomialW - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance FromX Fq where - yFromX = fqYforX - isOdd y = odd (toInt y) - -instance FromX Fq2 where - yFromX = fq2YforX - isOdd a = case fromField a of -- This is generalised from the MCL implementation where in Fq2 oddness is based on the first element - (x : xs) -> isOdd x - [] -> False -- Assume zero - -instance ByteRepr Fq where - mkRepr bo = toPaddedBytes bo <$> toInt - fromRepr bo _ bs = Just (fromInteger (fromBytesToInteger (byteOrder bo) bs)) - calcReprLength _ n = n - -instance ByteRepr Fq2 where - mkRepr bo f2 = do - bites <- fq2Bytes f2 - (foldl' (<>) mempty . map (mkRepr bo)) bites - fromRepr bo fq2 bs = do - let - blen = calcReprLength (1 :: Fq) $ lenPerElement bo - (xbs, ybs) = B.splitAt blen bs - x <- fromRepr bo (1 :: Fq) xbs - y <- fromRepr bo (1 :: Fq) ybs - return (toField [x, y]) - calcReprLength _ n = 2 * calcReprLength (1 :: Fq) n - -instance ByteRepr Fq6 where - mkRepr bo f6 = do - bites <- fq6Bytes f6 - (foldl' (<>) mempty . map (mkRepr bo)) bites - fromRepr bo fq6 bs = do - let - blen = calcReprLength (1 :: Fq2) $ lenPerElement bo - (xbs, yzbs) = B.splitAt blen bs - (ybs, zbs) = B.splitAt blen yzbs - x <- fromRepr bo (1 :: Fq2) xbs - y <- fromRepr bo (1 :: Fq2) ybs - z <- fromRepr bo (1 :: Fq2) zbs - return (toField [x, y, z]) - calcReprLength _ n = 3 * calcReprLength (1 :: Fq2) n - -instance ByteRepr Fq12 where - mkRepr bo f12= do - bites <- fq12Bytes f12 - (foldl' (<>) mempty . map (mkRepr bo)) bites - fromRepr bo fq12 bs = do - let - blen = calcReprLength (1 :: Fq6) $ lenPerElement bo - (xbs, ybs) = B.splitAt blen bs - x <- fromRepr bo (1 :: Fq6) xbs - y <- fromRepr bo (1 :: Fq6) ybs - return (toField [x, y]) - calcReprLength _ n = 2 * calcReprLength (1 :: Fq6) n - -------------------------------------------------------------------------------- --- Y for X -------------------------------------------------------------------------------- - -fqSqrt :: (Fq -> Fq -> Fq) -> Fq -> Maybe Fq -fqSqrt ysel a = case withQM (modUnOpMTup (toInt a) bothSqrtOf) of - Just (y1, y2) -> Just (ysel (fromInteger y1) (fromInteger y2)) - Nothing -> Nothing - --- | Square root of Fq2 are specified by https://eprint.iacr.org/2012/685.pdf, --- Algorithm 9 with lots of help from https://docs.rs/pairing/0.14.1/src/pairing/bls12_381/fq2.rs.html#162-222 --- This implementation appears to return the larger square root so check the --- return value and negate as necessary -fq2Sqrt :: Fq2 -> Maybe Fq2 -fq2Sqrt a = do - let a1 = pow a qm3by4 - let alpha = pow a1 2 * a - let a0 = pow alpha _q * alpha - if a0 == -1 then Nothing else do - let x0 = a1 * a - if alpha == -1 then Just (a1 * toField [0, 1]) else do - let b = pow (alpha + 1) qm1by2 - Just (b * x0) - where - qm3by4 = withQ (modBinOp (_q -3) 4 (/)) - qm1by2 = withQ (modBinOp (_q -1) 2 (/)) - -fqYforX :: Fq -> (Fq -> Fq -> Fq) -> Maybe Fq -fqYforX x ysel = fqSqrt ysel (pow x 3 + fromInteger _b) - --- https://docs.rs/pairing/0.14.1/src/pairing/bls12_381/ec.rs.html#102-124 -fq2YforX :: Fq2 -> (Fq2 -> Fq2 -> Fq2) -> Maybe Fq2 -fq2YforX x ly = do - y <- newy - pure (ly y (negate y)) - where - newy = fq2Sqrt (pow x 3 + fromInteger _b / xi) - -------------------------------------------------------------------------------- --- Non-residues -------------------------------------------------------------------------------- - --- | Quadratic non-residue -fqNqr :: Fq -fqNqr = fromInteger _nqr -{-# INLINE fqNqr #-} - --- | Cubic non-residue in @Fq2@ -xi :: Fq2 -xi = toField [fromInteger _xiA, fromInteger _xiB] - --- | Multiply by @xi@ (cubic nonresidue in @Fq2@) and reorder coefficients -mulXi :: Fq6 -> Fq6 -mulXi w = case fromField w of - [x, y, z] -> toField [z * xi, x, y] - [x, y] -> toField [0, x, y] - [x] -> toField [0, x] - [] -> toField [] - _ -> panic "mulXi not exhaustive." -{-# INLINE mulXi #-} - -------------------------------------------------------------------------------- --- Byte lists -------------------------------------------------------------------------------- - -fq2Bytes :: Fq2 -> Maybe [Fq] -fq2Bytes w = case fromField w of - [x, y] -> Just [x, y] - [x] -> Just [x, 0] - [] -> Just [0, 0] - _ -> Nothing - -fq6Bytes :: Fq6 -> Maybe [Fq2] -fq6Bytes w = case fromField w of - [x, y, z] -> Just [x, y, z] - [x, y] -> Just [x, y, 0] - [x] -> Just [x, 0, 0] - [] -> Just [0, 0, 0] - _ -> Nothing - -fq12Bytes :: Fq12 -> Maybe [Fq6] -fq12Bytes w = case fromField w of - [x, y] -> Just [x, y] - [x] -> Just [x, 0] - [] -> Just [0, 0] - _ -> Nothing - -------------------------------------------------------------------------------- --- Fq2 and Fq12 -------------------------------------------------------------------------------- - --- | Conjugation -fq2Conj :: Fq2 -> Fq2 -fq2Conj x = case fromField x of - [y, z] -> toField [y, -z] - [y] -> toField [y] - [] -> 0 - _ -> panic "fq2Conj not exhaustive." - --- | Multiplication by a scalar in @Fq@ -fq2ScalarMul :: Fq -> Fq2 -> Fq2 -fq2ScalarMul a x = toField [a] * x - --- | Conjugation -fq12Conj :: Fq12 -> Fq12 -fq12Conj x = case fromField x of - [y, z] -> toField [y, -z] - [y] -> toField [y] - [] -> 0 - _ -> panic "fq12Conj not exhaustive." - --- | Create a new value in @Fq12@ by providing a list of twelve coefficients --- in @Fq@, should be used instead of the @Fq12@ constructor. -construct :: [Fq] -> Fq12 -construct [a, b, c, d, e, f, g, h, i, j, k, l] = toField - [ toField [toField [a, b], toField [c, d], toField [e, f]] - , toField [toField [g, h], toField [i, j], toField [k, l]] ] -construct _ = panic "Invalid arguments to fq12" - --- | Deconstruct a value in @Fq12@ into a list of twelve coefficients in @Fq@. -deconstruct :: Fq12 -> [Fq] -deconstruct = concatMap fromField . concatMap fromField . fromField - --- | Iterated Frobenius automorphism -fq12Frobenius :: Int -> Fq12 -> Fq12 -fq12Frobenius i a - | i == 0 = a - | i == 1 = fastFrobenius a - | i > 1 = let prev = fq12Frobenius (i - 1) a - in fastFrobenius prev - | otherwise = panic "fq12Frobenius not defined for negative values of i" - --- | Fast Frobenius automorphism -fastFrobenius :: Fq12 -> Fq12 -fastFrobenius = collapse . convert [[0,2,4],[1,3,5]] . conjugate - where - conjugate :: Fq12 -> [[Fq2]] - conjugate = map (map fq2Conj . fromField) . fromField - convert :: [[Integer]] -> [[Fq2]] -> [[Fq2]] - convert = zipWith (zipWith (\x y -> pow xi ((x * (_q - 1)) `div` 6) * y)) - collapse :: [[Fq2]] -> Fq12 - collapse = toField . map toField diff --git a/src/Pairing/Fr.hs b/src/Pairing/Fr.hs deleted file mode 100644 --- a/src/Pairing/Fr.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Prime field from which exponents should be chosen -module Pairing.Fr - ( Fr - , isRootOfUnity - , isPrimitiveRootOfUnity - , primitiveRootOfUnity - , precompRootOfUnity - ) where - -import Protolude - -import GaloisField (GaloisField(..)) -import PrimeField (PrimeField, toInt) - -import Pairing.CyclicGroup -import Pairing.Modular -import Pairing.Params - -------------------------------------------------------------------------------- --- Types and instances -------------------------------------------------------------------------------- - --- | Prime field @Fr@ with characteristic @_r@ -type Fr = PrimeField 21888242871839275222246405745257275088548364400416034343698204186575808495617 - -------------------------------------------------------------------------------- --- Roots of unity -------------------------------------------------------------------------------- - -isRootOfUnity :: Integer -> Fr -> Bool -isRootOfUnity n x - | n > 0 = pow x n == 1 - | otherwise = panic "isRootOfUnity: negative powers not supported" - -isPrimitiveRootOfUnity :: Integer -> Fr -> Bool -isPrimitiveRootOfUnity n x - | n > 0 = isRootOfUnity n x && all (\m -> not $ isRootOfUnity m x) [1..n - 1] - | otherwise = panic "isPrimitiveRootOfUnity: negative powers not supported" - --- | Compute primitive roots of unity for 2^0, 2^1, ..., 2^28. (2^28 --- is the largest power of two that divides _r - 1, therefore there --- are no primitive roots of unity for higher powers of 2 in Fr.) -primitiveRootOfUnity :: Int -> Fr -primitiveRootOfUnity k - | 0 <= k && k <= 28 = 5^((_r - 1) `div` (2^k)) - | otherwise = panic "primitiveRootOfUnity: no primitive root for given power of 2" - -precompRootOfUnity :: Int -> Fr -precompRootOfUnity 0 = 1 -precompRootOfUnity 1 = 21888242871839275222246405745257275088548364400416034343698204186575808495616 -precompRootOfUnity 2 = 21888242871839275217838484774961031246007050428528088939761107053157389710902 -precompRootOfUnity 3 = 19540430494807482326159819597004422086093766032135589407132600596362845576832 -precompRootOfUnity 4 = 14940766826517323942636479241147756311199852622225275649687664389641784935947 -precompRootOfUnity 5 = 4419234939496763621076330863786513495701855246241724391626358375488475697872 -precompRootOfUnity 6 = 9088801421649573101014283686030284801466796108869023335878462724291607593530 -precompRootOfUnity 7 = 10359452186428527605436343203440067497552205259388878191021578220384701716497 -precompRootOfUnity 8 = 3478517300119284901893091970156912948790432420133812234316178878452092729974 -precompRootOfUnity 9 = 6837567842312086091520287814181175430087169027974246751610506942214842701774 -precompRootOfUnity 10 = 3161067157621608152362653341354432744960400845131437947728257924963983317266 -precompRootOfUnity 11 = 1120550406532664055539694724667294622065367841900378087843176726913374367458 -precompRootOfUnity 12 = 4158865282786404163413953114870269622875596290766033564087307867933865333818 -precompRootOfUnity 13 = 197302210312744933010843010704445784068657690384188106020011018676818793232 -precompRootOfUnity 14 = 20619701001583904760601357484951574588621083236087856586626117568842480512645 -precompRootOfUnity 15 = 20402931748843538985151001264530049874871572933694634836567070693966133783803 -precompRootOfUnity 16 = 421743594562400382753388642386256516545992082196004333756405989743524594615 -precompRootOfUnity 17 = 12650941915662020058015862023665998998969191525479888727406889100124684769509 -precompRootOfUnity 18 = 11699596668367776675346610687704220591435078791727316319397053191800576917728 -precompRootOfUnity 19 = 15549849457946371566896172786938980432421851627449396898353380550861104573629 -precompRootOfUnity 20 = 17220337697351015657950521176323262483320249231368149235373741788599650842711 -precompRootOfUnity 21 = 13536764371732269273912573961853310557438878140379554347802702086337840854307 -precompRootOfUnity 22 = 12143866164239048021030917283424216263377309185099704096317235600302831912062 -precompRootOfUnity 23 = 934650972362265999028062457054462628285482693704334323590406443310927365533 -precompRootOfUnity 24 = 5709868443893258075976348696661355716898495876243883251619397131511003808859 -precompRootOfUnity 25 = 19200870435978225707111062059747084165650991997241425080699860725083300967194 -precompRootOfUnity 26 = 7419588552507395652481651088034484897579724952953562618697845598160172257810 -precompRootOfUnity 27 = 2082940218526944230311718225077035922214683169814847712455127909555749686340 -precompRootOfUnity 28 = 19103219067921713944291392827692070036145651957329286315305642004821462161904 -precompRootOfUnity _ = panic "precompRootOfUnity: exponent too big for Fr / negative" diff --git a/src/Pairing/Group.hs b/src/Pairing/Group.hs deleted file mode 100644 --- a/src/Pairing/Group.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Definitions of the groups the pairing is defined on -module Pairing.Group - ( CyclicGroup(..) - , G1 - , G2 - , GT - , b1 - , b2 - , g1 - , g2 - , groupFromX - , hashToG1 - , isInGT - , isOnCurveG1 - , isOnCurveG2 - , fromByteStringG1 - , fromByteStringG2 - , fromByteStringGT - ) where - -import Protolude - -import Control.Monad.Random (MonadRandom) -import Data.Semigroup ((<>)) -import ExtensionField (toField) -import GaloisField (GaloisField(..)) -import PrimeField (toInt) -import Test.QuickCheck (Arbitrary(..), Gen) -import Pairing.CyclicGroup -import Pairing.Fq -import Pairing.Hash -import Pairing.Params -import Pairing.Point -import Pairing.Serialize.Types - --- | G1 is E(Fq) defined by y^2 = x^3 + b -type G1 = Point Fq - --- | G2 is E'(Fq2) defined by y^2 = x^3 + b / xi -type G2 = Point Fq2 - --- | GT is subgroup of _r-th roots of unity of the multiplicative --- group of Fq12 -type GT = Fq12 - -instance Semigroup G1 where - (<>) = gAdd - -instance Semigroup G2 where - (<>) = gAdd - -instance Semigroup GT where - (<>) = (*) - -instance Monoid G1 where - mappend = gAdd - mempty = Infinity - -instance CyclicGroup G1 where - generator = g1 - order _ = _r - expn a b = gMul a (asInteger b) - inverse = gNeg - random = randomG1 - -instance Validate G1 where - isValidElement = isOnCurveG1 - -instance Monoid G2 where - mappend = gAdd - mempty = Infinity - -instance CyclicGroup G2 where - generator = g2 - order _ = _r - expn a b = gMul a (asInteger b) - inverse = gNeg - random = randomG2 - -instance Validate G2 where - isValidElement = isOnCurveG2 - -instance Monoid GT where - mappend = (*) - mempty = 1 - -instance CyclicGroup GT where - generator = panic "not implemented." -- this should be the _r-th primitive root of unity - order = panic "not implemented." -- should be a factor of _r - expn a b = pow a (asInteger b) - inverse = recip - random = rnd - -instance Validate GT where - isValidElement = isInGT - --- | Generator for G1 -g1 :: G1 -g1 = Point 1 2 - --- | Generator for G2 -g2 :: G2 -g2 = Point x y - where - x = toField - [ 10857046999023057135944570762232829481370756359578518086990519993285655852781 - , 11559732032986387107991004021392285783925812861821192530917403151452391805634 ] - - y = toField - [ 8495653923123431417604973247489272438418190587263600148770280649306958101930 - , 4082367875863433681332203403145435568316851327593401208105741076214120093531 ] - --- | Test whether a value in G1 satisfies the corresponding curve --- equation -isOnCurveG1 :: G1 -> Bool -isOnCurveG1 Infinity = True -isOnCurveG1 (Point x y) = pow y 2 == pow x 3 + fromInteger _b - --- | Test whether a value in G2 satisfies the corresponding curve --- equation -isOnCurveG2 :: G2 -> Bool -isOnCurveG2 Infinity = True -isOnCurveG2 (Point x y) = pow y 2 == pow x 3 + toField [fromInteger _b] / xi - --- | Test whether a value is an _r-th root of unity -isInGT :: GT -> Bool -isInGT f = pow f _r == 1 - --- | Parameter for curve on Fq -b1 :: Fq -b1 = fromInteger _b - --- | Parameter for twisted curve over Fq2 -b2 :: Fq2 -b2 = toField [b1] / xi - -------------------------------------------------------------------------------- --- Generators -------------------------------------------------------------------------------- - -instance Arbitrary G1 where - arbitrary = gMul g1 . abs <$> (arbitrary :: Gen Integer) - -instance Arbitrary G2 where - arbitrary = gMul g2 . abs <$> (arbitrary :: Gen Integer) - -hashToG1 :: MonadRandom m => ByteString -> m (Maybe G1) -hashToG1 = swEncBN - -randomG1 :: forall m . MonadRandom m => m G1 -randomG1 = expn generator <$> (rnd :: m Fq) - -randomG2 :: forall m . MonadRandom m => m G2 -randomG2 = expn generator <$> (rnd :: m Fq) - -groupFromX :: (Validate (Point a), FromX a) => (a -> a -> a) -> a -> Maybe (Point a) -groupFromX checkF x = do - y <- yFromX x checkF - if isValidElement (Point x y) then Just (Point x y) else Nothing - -fromByteStringG1 :: (FromSerialisedForm u) => u -> LByteString -> Either Text G1 -fromByteStringG1 unser = unserializePoint unser g1 . toSL - -fromByteStringG2 :: (FromSerialisedForm u) => u -> LByteString -> Either Text G2 -fromByteStringG2 unser = unserializePoint unser g2 . toSL - -fromByteStringGT :: (FromUncompressedForm u) => u -> LByteString -> Either Text GT -fromByteStringGT unser = unserialize unser 1 . toSL diff --git a/src/Pairing/Hash.hs b/src/Pairing/Hash.hs --- a/src/Pairing/Hash.hs +++ b/src/Pairing/Hash.hs @@ -4,80 +4,46 @@ import Protolude -import Control.Error (runMaybeT, hoistMaybe) +import Control.Error (hoistMaybe, runMaybeT) import Control.Monad.Random (MonadRandom) -import Data.List (genericIndex) -import Math.NumberTheory.Moduli.Class (Mod, getVal, powMod) - -import Pairing.Params -import Pairing.Point -import Pairing.Modular as M -import Pairing.Fq as Fq -import Pairing.ByteRepr (ByteOrder(..)) - -sqrtOfMinusThree :: forall m . KnownNat m => Proxy m -> Maybe (Mod m) -sqrtOfMinusThree _ = sqrtOf (-3) - -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 -> Maybe (Mod m) -x1 mName t w = do - m3 <- sqrtOfMinusThree mName - pure $ (m3 - 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 +import Curve.Weierstrass (Point(..)) +import Data.List ((!!)) +import GaloisField (GaloisField(..)) -swy :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m -> Mod m -> Mod m -> Maybe Integer -swy mn pr3 pt pxi pb = (ch *) <$> y - where - ch = chi mn ((pr3 `powMod` 2) * pt) - y = getVal <$> sqrtOf ((pxi `powMod` 3) + pb) +import Pairing.ByteRepr (ByteOrder(..), fromBytesToInteger) +import Pairing.Curve (Fq, G1, _b) -- | 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 :: MonadRandom m => ByteString -> m (Maybe (Point Fq)) -swEncBN bs = runMaybeT $ withQM $ \mn -> do - let t = M.fromBytes MostSignificantFirst bs mn - sq3 <- hoistMaybe (sqrtOfMinusThree mn) - let w' = w mn sq3 t - x1' <- hoistMaybe (x1 mn t w') - if (t == 0) then do - onebmn <- hoistMaybe (sqrtOf (1 + (b mn))) - pure $ (Point (fromInteger (getVal x1')) (fromInteger (getVal $ onebmn))) - else do - let x2' = x2 mn x1' - let x3' = x3 mn w' - let lst = [x1', x2', x3'] - r1 <- lift $ randomMod mn - r2 <- lift $ randomMod mn - r3 <- lift $ randomMod mn - let al = alphaBeta mn r1 x1' - let bet = alphaBeta mn r2 x2' - let i' = i al bet - swy' <- hoistMaybe (swy mn r3 t (genericIndex lst (i' - 1)) (b mn)) - pure $ (Point (fromInteger (getVal $ genericIndex lst (i' - 1))) (fromInteger swy')) +-- The implementation uses the Shallue-van de Woestijne encoding to BN curves as +-- specified 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 Definition 2 +-- of the paper is sent to an arbitrary point on the curve. +swEncBN :: MonadRandom m => ByteString -> m (Maybe G1) +swEncBN bs = runMaybeT $ do + sqrt3 <- hoistMaybe $ sr (-3) + let t = fromInteger (fromBytesToInteger MostSignificantFirst bs) + s1 = (sqrt3 - 1) / 2 + b1 = 1 + _b + guard (b1 + t * t /= 0) + if t == 0 + then + A s1 <$> hoistMaybe (sr b1) + else do + let w = sqrt3 * t / (b1 + t * t) + x1 = s1 - t * w + x2 = -1 - x1 + x3 = 1 + 1 / (w * w) + r1 <- rnd + r2 <- rnd + r3 <- rnd + let a = ch $ r1 * r1 * (x1 * x1 * x1 + _b) + b = ch $ r2 * r2 * (x2 * x2 * x2 + _b) + c = ch $ r3 * r3 * t + i = mod ((a - 1) * b) 3 + x = [x1, x2, x3] !! i + y = sr $ x * x * x + _b + A x . (fromIntegral c *) <$> hoistMaybe y + where + ch :: Fq -> Int + ch x = if x == 0 then 0 else if qr x then 1 else -1 diff --git a/src/Pairing/Jacobian.hs b/src/Pairing/Jacobian.hs deleted file mode 100644 --- a/src/Pairing/Jacobian.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | Jacobian representation of points on an elliptic curve. --- --- In Jacobian coordinates the triple @(x, y, z)@ represents the affine point --- @(X / Z^2, Y / Z^3)@. Curve operations are more optimal in Jacobian --- coordinates when the time complexity for underlying field inversions is --- significantly higher than field multiplications. -module Pairing.Jacobian - ( JPoint - , toJacobian - , fromJacobian - ) where - -import Protolude - -import GaloisField (GaloisField(..)) - -import Pairing.Point - --- | Jacobian coordinates for points on an elliptic curve over a field @k@. -type JPoint k = (k, k, k) - --- | Convert affine coordinates to Jacobian coordinates -toJacobian :: GaloisField k => Point k -> JPoint k -toJacobian Infinity = (1, 1, 0) -toJacobian (Point x y) = (x, y, 1) - --- | Convert Jacobian coordinates to affine coordinates -fromJacobian :: GaloisField k => JPoint k -> Point k -fromJacobian (_, _, 0) = Infinity -fromJacobian (x, y, z) = Point (x * pow z (-2)) (y * pow z (-3)) diff --git a/src/Pairing/Modular.hs b/src/Pairing/Modular.hs deleted file mode 100644 --- a/src/Pairing/Modular.hs +++ /dev/null @@ -1,99 +0,0 @@ -module Pairing.Modular where - -import Protolude - -import Math.NumberTheory.Moduli.Class -import Math.NumberTheory.Moduli.Sqrt - -import Control.Monad.Random (MonadRandom(..)) - -import Pairing.Params -import Pairing.ByteRepr -import qualified Data.ByteString as BS - -withMod :: Integer -> (forall m . KnownNat m => Proxy m -> r) -> r -withMod n cont = case someNatVal n of - Nothing -> panic ("Somehow " <> show n <> " was not a Nat") - Just (SomeNat mName) -> cont mName - -withModM :: Integer -> (forall n. KnownNat n => Proxy n -> m r) -> m r -withModM n cont = case someNatVal n of - Nothing -> panic ("Somehow " <> show n <> " was not a Nat") - Just (SomeNat mName) -> cont mName - --- Mod conversion and management -withQ :: (forall m . KnownNat m => Proxy m -> r) -> r -withQ = withMod _q - --- Mod conversion and management -withQM :: (forall n. KnownNat n => Proxy n -> m r) -> m r -withQM = withModM _q - -withR :: (forall m . KnownNat m => Proxy m -> r) -> r -withR = withMod _r - --- Mod conversion and management -withRM :: (forall n. KnownNat n => Proxy n -> m r) -> m r -withRM = withModM _r - -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) - -modUnOpMTup :: forall m a . (KnownNat m, Monad a) => Integer -> (Mod m -> a (Mod m, Mod m)) -> Proxy m -> a (Integer, Integer) -modUnOpMTup n f mName = do - (a, b) <- f (fromInteger @(Mod m) n) - pure (getVal a, getVal b) - -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 (getMod a)) then (length kp > 0) else False - where - kp = sqrtsMod a - --- | --- Picks the postive square root only --- | - -sqrtOf :: forall m . KnownNat m => Mod m -> Maybe (Mod m) -sqrtOf i = fst <$> bothSqrtOf i - -bothSqrtOf :: forall m . KnownNat m => Mod m -> Maybe (Mod m, Mod m) -bothSqrtOf i = case sqrtsMod i of - [] -> Nothing - (x : x1 : xs) -> Just (x, x1) - [_] -> Nothing - -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 n = fromInteger <$> getRandomR (0, natVal n - 1) - -fromBytes :: forall n. (KnownNat n) => ByteOrder -> ByteString -> Proxy n -> Mod n -fromBytes bo bs = newMod (fromBytesToInteger bo bs) diff --git a/src/Pairing/Pairing.hs b/src/Pairing/Pairing.hs --- a/src/Pairing/Pairing.hs +++ b/src/Pairing/Pairing.hs @@ -11,18 +11,13 @@ import Protolude +import Curve.Weierstrass (Curve(..), Group(..), Point(..)) import Data.List ((!!)) import ExtensionField (toField) import GaloisField (GaloisField(..)) - -import Pairing.Fq -import Pairing.Group -import Pairing.Jacobian -import Pairing.Params -import Pairing.Point +import Group.Field (Element(..)) --- G2, but using Jacobian coordinates -type JG2 = JPoint Fq2 +import Pairing.Curve -- ell0, ellVW, ellVV data EllCoeffs @@ -31,21 +26,17 @@ -- | Optimal Ate pairing (including final exponentiation step) reducedPairing :: G1 -> G2 -> GT -reducedPairing p@(Point _ _) q@(Point _ _) - = finalExponentiation $ atePairing p q -reducedPairing _ _ - = 1 +reducedPairing p@(A _ _) q@(A _ _) = finalExponentiation <$> atePairing p q +reducedPairing _ _ = F 1 ------------------------------------------------------------------------------- -- Miller loop ------------------------------------------------------------------------------- -- | Optimal Ate pairing without the final exponentiation step -atePairing :: G1 -> G2 -> Fq12 -atePairing p@(Point _ _) q@(Point _ _) - = ateMillerLoop p (atePrecomputeG2 q) -atePairing _ _ - = 1 +atePairing :: G1 -> G2 -> GT +atePairing p@(A _ _) q@(A _ _) = ateMillerLoop p (atePrecomputeG2 q) +atePairing _ _ = F 1 -- | Binary expansion (missing the most-significant bit) representing -- the number 6 * _t + 2. @@ -66,31 +57,30 @@ -- | Miller loop with precomputed values for G2 ateMillerLoop :: G1 -> [EllCoeffs] -> GT ateMillerLoop p coeffs = let - (postLoopIx, postLoopF) = foldl' (ateLoopBody p coeffs) (0, 1) ateLoopCountBinary + (postLoopIx, postLoopF) = foldl' (ateLoopBody p coeffs) (0, F 1) ateLoopCountBinary almostF = mulBy024 postLoopF (prepareCoeffs coeffs p postLoopIx) finalF = mulBy024 almostF (prepareCoeffs coeffs p (postLoopIx + 1)) in finalF -ateLoopBody :: G1 -> [EllCoeffs] -> (Int, Fq12) -> Bool -> (Int, Fq12) -ateLoopBody p coeffs (oldIx, oldF) currentBit - = let - fFirst = mulBy024 (pow oldF 2) (prepareCoeffs coeffs p oldIx) +ateLoopBody :: G1 -> [EllCoeffs] -> (Int, GT) -> Bool -> (Int, GT) +ateLoopBody p coeffs (oldIx, F oldF) currentBit = let + fFirst = mulBy024 (F (pow oldF 2)) (prepareCoeffs coeffs p oldIx) (nextIx, nextF) = if currentBit - then (oldIx + 2, mulBy024 fFirst (prepareCoeffs coeffs p (oldIx + 1))) - else (oldIx + 1, fFirst) + then (oldIx + 2, mulBy024 fFirst (prepareCoeffs coeffs p (oldIx + 1))) + else (oldIx + 1, fFirst) in (nextIx, nextF) prepareCoeffs :: [EllCoeffs] -> G1 -> Int -> EllCoeffs -prepareCoeffs _ Infinity _ = panic "prepareCoeffs: received trivial point" -prepareCoeffs coeffs (Point px py) ix = +prepareCoeffs coeffs (A px py) ix = let (EllCoeffs ell0 ellVW ellVV) = coeffs !! ix - in EllCoeffs ell0 (fq2ScalarMul py ellVW) (fq2ScalarMul px ellVV) + in EllCoeffs ell0 (scale py ellVW) (scale px ellVV) +prepareCoeffs _ _ _ = panic "prepareCoeffs: received trivial point" {-# INLINEABLE mulBy024 #-} -mulBy024 :: Fq12 -> EllCoeffs -> Fq12 -mulBy024 this (EllCoeffs ell0 ellVW ellVV) +mulBy024 :: GT -> EllCoeffs -> GT +mulBy024 (F this) (EllCoeffs ell0 ellVW ellVV) = let a = toField [toField [ell0, 0, ellVV], toField [0, ellVW, 0]] - in this * a + in F (this * a) ------------------------------------------------------------------------------- -- Precomputation on G2 @@ -107,38 +97,30 @@ in prev ^ _q | otherwise = panic "frobeniusNaive: received negative input" -{-# INLINEABLE mulByQ #-} -mulByQ :: JG2 -> JG2 -mulByQ (x, y, z) - = ( twistMulX * frobeniusNaive 1 x - , twistMulY * frobeniusNaive 1 y - , frobeniusNaive 1 z - ) +{-# INLINEABLE mulByQ #-} +mulByQ :: G2' -> G2' +mulByQ (J x y z) = J (twistMulX * pow x _q) (twistMulY * pow y _q) (pow z _q) -- xi ^ ((_q - 1) `div` 3) twistMulX :: Fq2 -twistMulX = pow xi ((_q - 1) `div` 3) -- Fq2 +twistMulX = pow _xi ((_q - 1) `div` 3) -- Fq2 -- 21575463638280843010398324269430826099269044274347216827212613867836435027261 -- 10307601595873709700152284273816112264069230130616436755625194854815875713954 -- xi ^ ((_q - 1) `div` 2) twistMulY :: Fq2 -twistMulY = pow xi ((_q - 1) `div` 2) -- Fq2 +twistMulY = pow _xi ((_q - 1) `div` 2) -- Fq2 -- 2821565182194536844548159561693502659359617185244120367078079554186484126554 -- 3505843767911556378687030309984248845540243509899259641013678093033130930403 -mirrorY :: JG2 -> JG2 -mirrorY (x,y,z) = (x,-y,z) - atePrecomputeG2 :: G2 -> [EllCoeffs] -atePrecomputeG2 Infinity = [] -atePrecomputeG2 origPt@(Point _ _) +atePrecomputeG2 origPt@(A _ _) = let - bigQ = toJacobian origPt + bigQ = fromA origPt (postLoopR, postLoopCoeffs) = runLoop bigQ bigQ1 = mulByQ bigQ - bigQ2 = mirrorY $ mulByQ bigQ1 + bigQ2 = inv $ mulByQ bigQ1 (newR, coeffs1) = mixedAdditionStepForFlippedMillerLoop bigQ1 postLoopR (_, coeffs2) = mixedAdditionStepForFlippedMillerLoop bigQ2 newR @@ -148,7 +130,7 @@ -- Assumes q to have z coordinate to be 1 runLoop q = foldl' (loopBody q) (q, []) ateLoopCountBinary - loopBody :: JG2 -> (JG2, [EllCoeffs]) -> Bool -> (JG2, [EllCoeffs]) + loopBody :: G2' -> (G2', [EllCoeffs]) -> Bool -> (G2', [EllCoeffs]) loopBody q (oldR, oldCoeffs) currentBit = let (currentR, currentCoeff) = doublingStepForFlippedMillerLoop oldR @@ -160,25 +142,23 @@ in (resultR, currentCoeffs ++ [resultCoeff]) else (currentR, currentCoeffs) in (nextR, nextCoeffs) - -twoInv :: Fq -twoInv = 0.5 +atePrecomputeG2 _ = [] twistCoeffB :: Fq2 -twistCoeffB = fq2ScalarMul (fromInteger _b) (1 / xi) +twistCoeffB = scale _b (1 / _xi) -doublingStepForFlippedMillerLoop :: JG2 -> (JG2, EllCoeffs) -doublingStepForFlippedMillerLoop (oldX, oldY, oldZ) +doublingStepForFlippedMillerLoop :: G2' -> (G2', EllCoeffs) +doublingStepForFlippedMillerLoop (J oldX oldY oldZ) = let a, b, c, d, e, f, g, h, i, j, eSquared :: Fq2 - a = fq2ScalarMul twoInv (oldX * oldY) + a = scale 0.5 (oldX * oldY) b = oldY * oldY c = oldZ * oldZ d = c + c + c e = twistCoeffB * d f = e + e + e - g = fq2ScalarMul twoInv (b + f) + g = scale 0.5 (b + f) h = (oldY + oldZ) * (oldY + oldZ) - (b + c) i = e - b j = oldX * oldX @@ -188,16 +168,14 @@ newY = g * g - (eSquared + eSquared + eSquared) newZ = b * h - ell0 = xi * i + ell0 = _xi * i ellVV = j + j + j ellVW = - h - in ( (newX, newY, newZ) - , EllCoeffs ell0 ellVW ellVV - ) + in (J newX newY newZ, EllCoeffs ell0 ellVW ellVV) -mixedAdditionStepForFlippedMillerLoop :: JG2 -> JG2 -> (JG2, EllCoeffs) -mixedAdditionStepForFlippedMillerLoop _base@(x2, y2, _z2) _current@(x1, y1, z1) +mixedAdditionStepForFlippedMillerLoop :: G2' -> G2' -> (G2', EllCoeffs) +mixedAdditionStepForFlippedMillerLoop (J x2 y2 _) (J x1 y1 z1) = let d, e, f, g, h, i, j :: Fq2 d = x1 - (x2 * z1) @@ -212,36 +190,34 @@ newY = e * (i - j) - (h * y1) newZ = z1 * h - ell0 = xi * (e * x2 - d * y2) + ell0 = _xi * (e * x2 - d * y2) ellVV = - e ellVW = d - in ( (newX, newY, newZ) - , EllCoeffs ell0 ellVW ellVV - ) + in (J newX newY newZ, EllCoeffs ell0 ellVW ellVV) ------------------------------------------------------------------------------- -- Final exponentiation ------------------------------------------------------------------------------- -- | Naive implementation of the final exponentiation step -finalExponentiationNaive :: Fq12 -> GT +finalExponentiationNaive :: Fq12 -> Fq12 finalExponentiationNaive f = pow f expVal where expVal :: Integer expVal = div (_q ^ _k - 1) _r -- | A faster way of performing the final exponentiation step -finalExponentiation :: Fq12 -> GT +finalExponentiation :: Fq12 -> Fq12 finalExponentiation f = pow (finalExponentiationFirstChunk f) expVal where - expVal = div (_q ^ 4 - _q ^ 2 + 1) _r + expVal = div (qq * (qq - 1) + 1) _r + qq = _q * _q -finalExponentiationFirstChunk :: Fq12 -> GT +finalExponentiationFirstChunk :: Fq12 -> Fq12 finalExponentiationFirstChunk f | f == 0 = 0 - | otherwise = let - f1 = fq12Conj f - f2 = recip f - newf0 = f1 * f2 -- == f^(_q ^6 - 1) - in fq12Frobenius 2 newf0 * newf0 -- == f^((_q ^ 6 - 1) * (_q ^ 2 + 1)) + | otherwise = let f1 = conj f + f2 = recip f + newf0 = f1 * f2 -- == f^(_q ^6 - 1) + in fq12Frobenius 2 newf0 * newf0 -- == f^((_q ^ 6 - 1) * (_q ^ 2 + 1)) diff --git a/src/Pairing/Params.hs b/src/Pairing/Params.hs deleted file mode 100644 --- a/src/Pairing/Params.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | Parameters chosen for the pairing. The parameters chosen here --- correspond to the BN128 curve (aka CurveSNARK). --- --- > a = 0 --- > b = 3 --- > k = 12 --- > t = 4965661367192848881 --- > q = 21888242871839275222246405745257275088696311157297823662689037894645226208583 --- > r = 21888242871839275222246405745257275088548364400416034343698204186575808495617 --- > ΞΎ = 9 + u -module Pairing.Params - ( _a - , _b - , _q - , _r - , _k - , _nqr - , _xiA - , _xiB - ) where - -import Protolude - --- | Elliptic curve coefficent -_b :: Integer -_b = 3 - --- | Elliptic curve coefficent -_a :: Integer -_a = 0 - --- | Embedding degree -_k :: Integer -_k = 12 - --- | BN parameter that determines the prime -_t :: Integer -_t = 4965661367192848881 - --- | Characteristic of the finite fields we work with -_q :: Integer -_q = 36*_t^4 + 36*_t^3 + 24*_t^2 + 6*_t + 1 - --- | Order of elliptic curve E(Fq) G1, and therefore also the characteristic --- of the prime field we choose our exponents from -_r :: Integer -_r = 36*_t^4 + 36*_t^3 + 18*_t^2 + 6*_t + 1 - --- | Parameter used to define the twisted curve over Fq, with xi = --- xi_a + xi_b * i -_xiA :: Integer -_xiA = 9 - --- | Parameter used to define the twisted curve over Fq, with xi = --- xi_a + xi_b * i -_xiB :: Integer -_xiB = 1 - --- | Quadratic nonresidue in Fq -_nqr :: Integer -_nqr = 21888242871839275222246405745257275088696311157297823662689037894645226208582 diff --git a/src/Pairing/Point.hs b/src/Pairing/Point.hs deleted file mode 100644 --- a/src/Pairing/Point.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | Affine point arithmetic defining the group operation on an --- elliptic curve E(F), for some field F. In our case the field F is --- given as some type t with Num and Fractional instances. -module Pairing.Point - ( Point(..) - , gDouble - , gAdd - , gNeg - , gMul - ) where - -import Protolude - -import GaloisField (GaloisField(..)) - -import Pairing.Fq (Fq, Fq2) - --- | Points on a curve over a field @a@ represented as either affine --- coordinates or as a point at infinity. -data Point a - = Point a a -- ^ Affine point - | Infinity -- ^ Point at infinity - deriving (Eq, Ord, Show, Functor, Generic, NFData) - -{-# SPECIALISE gDouble :: Point Fq -> Point Fq #-} -{-# SPECIALISE gDouble :: Point Fq2 -> Point Fq2 #-} - -{-# SPECIALISE gAdd :: Point Fq -> Point Fq -> Point Fq #-} -{-# SPECIALISE gAdd :: Point Fq2 -> Point Fq2 -> Point Fq2 #-} - -{-# SPECIALISE gNeg :: Point Fq -> Point Fq #-} -{-# SPECIALISE gNeg :: Point Fq2 -> Point Fq2 #-} - -{-# SPECIALISE gMul :: Point Fq -> Integer -> Point Fq #-} -{-# SPECIALISE gMul :: Point Fq2 -> Integer -> Point Fq2 #-} - --- | Point addition, provides a group structure on an elliptic curve --- with the point at infinity as its unit. -gAdd :: GaloisField k => Point k -> Point k -> Point k -gAdd Infinity a = a -gAdd a Infinity = a -gAdd (Point x1 y1) (Point x2 y2) - | x2 == x1 && y2 == y1 = gDouble (Point x1 y1) - | x2 == x1 = Infinity - | otherwise = Point x' y' - where - l = (y2 - y1) / (x2 - x1) - x' = pow l 2 - x1 - x2 - y' = -l * x' + l * x1 - y1 - --- | Point doubling -gDouble :: GaloisField k => Point k -> Point k -gDouble Infinity = Infinity -gDouble (Point _ 0) = Infinity -gDouble (Point x y) = Point x' y' - where - l = 3 * pow x 2 / (2 * y) - x' = pow l 2 - 2 * x - y' = -l * x' + l * x - y - --- | Negation (flipping the y component) -gNeg :: GaloisField k => Point k -> Point k -gNeg Infinity = Infinity -gNeg (Point x y) = Point x (-y) - --- | Multiplication by a scalar -gMul :: (Integral a, GaloisField k) => Point k -> a -> Point k -gMul _ 0 = Infinity -gMul pt 1 = pt -gMul pt n - | n < 0 = panic "gMul: negative scalar not supported" - | even n = gMul (gDouble pt) (div n 2) - | otherwise = gAdd (gMul (gDouble pt) (div n 2)) pt diff --git a/src/Pairing/Serialize/Jivsov.hs b/src/Pairing/Serialize/Jivsov.hs --- a/src/Pairing/Serialize/Jivsov.hs +++ b/src/Pairing/Serialize/Jivsov.hs @@ -5,113 +5,113 @@ -- 03 - Compressed repr i.e. x only but use largest y on decode -- 04 -- Uncompressed repr i.e. x & y -module Pairing.Serialize.Jivsov ( - Jivsov(..) -) where - -import Protolude hiding (putByteString) -import Pairing.Point -import Pairing.Serialize.Types -import Pairing.Fq -import Data.ByteString.Builder -import Data.ByteString as B hiding (length) -import qualified Data.ByteString as B -import Data.Binary.Get -import Data.Binary.Put (Put, putWord8, putWord16le, runPut, putByteString) -import Control.Error -import Pairing.ByteRepr -import Pairing.CyclicGroup - -data Jivsov = Jivsov - -instance MkCompressedForm Jivsov where - serializeCompressed _ = toCompressedForm - -instance MkUncompressedForm Jivsov where - serializePointUncompressed _ = toUncompressedForm - serializeUncompressed _ = elementToUncompressedForm - -instance FromSerialisedForm Jivsov where - unserializePoint _ = pointFromByteString - -instance FromUncompressedForm Jivsov where - unserialize _ = elementReadUncompressed - -putCompressionType :: Word8 -> Put -putCompressionType n = putWord8 0 >> putWord8 n - -getCompressionType :: Get Word8 -getCompressionType = getWord8 >> getWord8 - -------------------------------------------------------------------------------- --- Element specific Serailisation -------------------------------------------------------------------------------- - -elementToUncompressedForm :: (ByteRepr a) => a -> Maybe LByteString -elementToUncompressedForm a = do - repr <- mkRepr (ByteOrderLength MostSignificantFirst minReprLength) a - pure $ runPut $ do - putCompressionType 4 - putByteString repr - -elementReadUncompressed :: (Validate a, Show a, ByteRepr a) => a -> LByteString -> Either Text a -elementReadUncompressed ele = parseBS runc - where - runc = do - ctype <- getCompressionType - if ctype == 4 then do - let xlen = calcReprLength ele minReprLength - bs <- getByteString xlen - pure (fromRepr (ByteOrderLength MostSignificantFirst minReprLength) ele bs) - else - pure Nothing - -------------------------------------------------------------------------------- --- Point specific serialisation -------------------------------------------------------------------------------- - -toUncompressedForm :: (ByteRepr a) => Point a -> Maybe LByteString -toUncompressedForm (Point x y) = do - rx <- mkRepr (ByteOrderLength MostSignificantFirst minReprLength) x - ry <- mkRepr (ByteOrderLength MostSignificantFirst minReprLength) y - pure $ runPut $ do - putCompressionType 4 - putByteString rx - putByteString ry -toUncompressedForm Infinity = pure $ runPut (putCompressionType 1) - -toCompressedForm :: (ByteRepr a, FromX a, Ord a) => Point a -> Maybe LByteString -toCompressedForm (Point x y) = do - ny <- yFromX x max - let yform = if ny == y then 3 else 2 - rx <- mkRepr (ByteOrderLength MostSignificantFirst minReprLength) x - pure (runPut $ do - putCompressionType yform - putByteString rx) -toCompressedForm Infinity = Just (toLazyByteString (word8 0 <> word8 1)) - -pointFromByteString :: (Show a, Validate (Point a), ByteRepr a, FromX a, Ord a) => Point a -> LByteString -> Either Text (Point a) -pointFromByteString (Point a _) bs = parseBS fromByteStringGet bs - where - fromByteStringGet = do - ctype <- getCompressionType - processCompressed a ctype -pointFromByteString Infinity _ = Left "Cannot use infinity to extract from bytestring" - -processCompressed :: forall a . (ByteRepr a, FromX a, Ord a) => a -> Word8 -> Get (Maybe (Point a)) -processCompressed one ct - | ct == 4 = do - xbs <- getByteString blen - ybs <- getByteString blen - pure (buildPoint one (ByteOrderLength MostSignificantFirst minReprLength) xbs (ByteOrderLength MostSignificantFirst minReprLength) ybs) - | ct == 2 = fromCompressed False - | ct == 3 = fromCompressed True - | ct == 1 = pure (Just Infinity) - | otherwise = pure Nothing - where - blen = calcReprLength one minReprLength - fromCompressed largestY = runMaybeT $ do - xbs <- lift $ getByteString blen - x <- hoistMaybe $ fromRepr (ByteOrderLength MostSignificantFirst minReprLength) one xbs - y <- hoistMaybe $ yFromX x (\y1 y2 -> if largestY then max y1 y2 else min y1 y2) - pure (Point x y) +module Pairing.Serialize.Jivsov where +-- ( Jivsov(..) +-- ) where +-- +-- import Protolude hiding (putByteString) +-- import Pairing.Point +-- import Pairing.Serialize.Types +-- import Pairing.Fq +-- import Data.ByteString.Builder +-- import Data.ByteString as B hiding (length) +-- import qualified Data.ByteString as B +-- import Data.Binary.Get +-- import Data.Binary.Put (Put, putWord8, putWord16le, runPut, putByteString) +-- import Control.Error +-- import Pairing.ByteRepr +-- import Pairing.CyclicGroup +-- +-- data Jivsov = Jivsov +-- +-- instance MkCompressedForm Jivsov where +-- serializeCompressed _ = toCompressedForm +-- +-- instance MkUncompressedForm Jivsov where +-- serializePointUncompressed _ = toUncompressedForm +-- serializeUncompressed _ = elementToUncompressedForm +-- +-- instance FromSerialisedForm Jivsov where +-- unserializePoint _ = pointFromByteString +-- +-- instance FromUncompressedForm Jivsov where +-- unserialize _ = elementReadUncompressed +-- +-- putCompressionType :: Word8 -> Put +-- putCompressionType n = putWord8 0 >> putWord8 n +-- +-- getCompressionType :: Get Word8 +-- getCompressionType = getWord8 >> getWord8 +-- +-- ------------------------------------------------------------------------------- +-- -- Element specific Serailisation +-- ------------------------------------------------------------------------------- +-- +-- elementToUncompressedForm :: (ByteRepr a) => a -> Maybe LByteString +-- elementToUncompressedForm a = do +-- repr <- mkRepr (ByteOrderLength MostSignificantFirst minReprLength) a +-- pure $ runPut $ do +-- putCompressionType 4 +-- putByteString repr +-- +-- elementReadUncompressed :: (Validate a, Show a, ByteRepr a) => a -> LByteString -> Either Text a +-- elementReadUncompressed ele = parseBS runc +-- where +-- runc = do +-- ctype <- getCompressionType +-- if ctype == 4 then do +-- let xlen = calcReprLength ele minReprLength +-- bs <- getByteString xlen +-- pure (fromRepr (ByteOrderLength MostSignificantFirst minReprLength) ele bs) +-- else +-- pure Nothing +-- +-- ------------------------------------------------------------------------------- +-- -- Point specific serialisation +-- ------------------------------------------------------------------------------- +-- +-- toUncompressedForm :: (ByteRepr a) => Point a -> Maybe LByteString +-- toUncompressedForm (Point x y) = do +-- rx <- mkRepr (ByteOrderLength MostSignificantFirst minReprLength) x +-- ry <- mkRepr (ByteOrderLength MostSignificantFirst minReprLength) y +-- pure $ runPut $ do +-- putCompressionType 4 +-- putByteString rx +-- putByteString ry +-- toUncompressedForm Infinity = pure $ runPut (putCompressionType 1) +-- +-- toCompressedForm :: (ByteRepr a, FromX a, Ord a) => Point a -> Maybe LByteString +-- toCompressedForm (Point x y) = do +-- ny <- yFromX x max +-- let yform = if ny == y then 3 else 2 +-- rx <- mkRepr (ByteOrderLength MostSignificantFirst minReprLength) x +-- pure (runPut $ do +-- putCompressionType yform +-- putByteString rx) +-- toCompressedForm Infinity = Just (toLazyByteString (word8 0 <> word8 1)) +-- +-- pointFromByteString :: (Show a, Validate (Point a), ByteRepr a, FromX a, Ord a) => Point a -> LByteString -> Either Text (Point a) +-- pointFromByteString (Point a _) bs = parseBS fromByteStringGet bs +-- where +-- fromByteStringGet = do +-- ctype <- getCompressionType +-- processCompressed a ctype +-- pointFromByteString Infinity _ = Left "Cannot use infinity to extract from bytestring" +-- +-- processCompressed :: forall a . (ByteRepr a, FromX a, Ord a) => a -> Word8 -> Get (Maybe (Point a)) +-- processCompressed one ct +-- | ct == 4 = do +-- xbs <- getByteString blen +-- ybs <- getByteString blen +-- pure (buildPoint one (ByteOrderLength MostSignificantFirst minReprLength) xbs (ByteOrderLength MostSignificantFirst minReprLength) ybs) +-- | ct == 2 = fromCompressed False +-- | ct == 3 = fromCompressed True +-- | ct == 1 = pure (Just Infinity) +-- | otherwise = pure Nothing +-- where +-- blen = calcReprLength one minReprLength +-- fromCompressed largestY = runMaybeT $ do +-- xbs <- lift $ getByteString blen +-- x <- hoistMaybe $ fromRepr (ByteOrderLength MostSignificantFirst minReprLength) one xbs +-- y <- hoistMaybe $ yFromX x (\y1 y2 -> if largestY then max y1 y2 else min y1 y2) +-- pure (Point x y) diff --git a/src/Pairing/Serialize/MCLWasm.hs b/src/Pairing/Serialize/MCLWasm.hs --- a/src/Pairing/Serialize/MCLWasm.hs +++ b/src/Pairing/Serialize/MCLWasm.hs @@ -10,55 +10,55 @@ -- and appended as a continuous bytestring, using the element length to split -- each point -module Pairing.Serialize.MCLWasm ( - MCLWASM(..) - ) where - -import Protolude hiding (putByteString) -import Pairing.Serialize.Types -import Pairing.Point -import Pairing.ByteRepr -import Pairing.CyclicGroup -import Data.Binary.Put (Put, putWord8, putWord16le, runPut, putByteString) -import Data.ByteString.Builder -import Data.ByteString as B hiding (length) -import qualified Data.ByteString as B - -data MCLWASM = MCLWASM deriving (Eq, Show) - -instance MkCompressedForm MCLWASM where - serializeCompressed _ = toCompressedForm - -instance FromSerialisedForm MCLWASM where - unserializePoint _ = fromCompressedForm - -toCompressedForm :: (ByteRepr a, FromX a) => Point a -> Maybe LByteString -toCompressedForm (Point x y) = do - ny <- yFromX x (\y1 y2 -> if isOdd y1 then y1 else y2) - rx <- mkRepr (ByteOrderLength LeastSignificantFirst minReprLength) x - bs <- if isOdd y then do - k <- toPaddedBytes (ByteOrderLength MostSignificantFirst (calcReprLength x minReprLength)) 0x80 - pure (B.pack $ B.zipWith (.|.) rx k) - else - pure rx - pure (runPut $ putByteString bs) -toCompressedForm Infinity = Just (toLazyByteString (word8 0)) - -fromCompressedForm :: (ByteRepr a, FromX a) => Point a -> LByteString -> Either Text (Point a) -fromCompressedForm (Point onex _) bs = if isInfinity then pure Infinity else do - k <- note "Padding failed" (toPaddedBytes (ByteOrderLength MostSignificantFirst (calcReprLength onex minReprLength)) 0x80) - let - nbs = B.pack $ B.zipWith (.&.) (toS bs) k - (xbs, yodd) = if fromBytesToInteger MostSignificantFirst nbs == 0x80 then - (B.pack (B.zipWith xor (toS bs) k), True) - else - (toS bs, False) - x <- note "Failed to deserialise x" (fromRepr (ByteOrderLength LeastSignificantFirst minReprLength) onex xbs) - y <- note "Failed to get y from x" (yFromX x (selOdd yodd)) - pure (Point x y) - where - selOdd yesOdd y1 y2 = if yesOdd then whichOdd y1 y2 else whichEven y1 y2 - whichOdd y1 y2 = if isOdd y1 then y1 else y2 - whichEven y1 y2 = if isOdd y1 then y2 else y1 - isInfinity = fromBytesToInteger MostSignificantFirst (toS bs) == 0 -fromCompressedForm Infinity _ = Left "Cannot use infinity to extract from bytestring" +module Pairing.Serialize.MCLWasm where +-- ( MCLWASM(..) +-- ) where +-- +-- import Protolude hiding (putByteString) +-- import Pairing.Serialize.Types +-- import Pairing.Point +-- import Pairing.ByteRepr +-- import Pairing.CyclicGroup +-- import Data.Binary.Put (Put, putWord8, putWord16le, runPut, putByteString) +-- import Data.ByteString.Builder +-- import Data.ByteString as B hiding (length) +-- import qualified Data.ByteString as B +-- +-- data MCLWASM = MCLWASM deriving (Eq, Show) +-- +-- instance MkCompressedForm MCLWASM where +-- serializeCompressed _ = toCompressedForm +-- +-- instance FromSerialisedForm MCLWASM where +-- unserializePoint _ = fromCompressedForm +-- +-- toCompressedForm :: (ByteRepr a, FromX a) => Point a -> Maybe LByteString +-- toCompressedForm (Point x y) = do +-- ny <- yFromX x (\y1 y2 -> if isOdd y1 then y1 else y2) +-- rx <- mkRepr (ByteOrderLength LeastSignificantFirst minReprLength) x +-- bs <- if isOdd y then do +-- k <- toPaddedBytes (ByteOrderLength MostSignificantFirst (calcReprLength x minReprLength)) 0x80 +-- pure (B.pack $ B.zipWith (.|.) rx k) +-- else +-- pure rx +-- pure (runPut $ putByteString bs) +-- toCompressedForm Infinity = Just (toLazyByteString (word8 0)) +-- +-- fromCompressedForm :: (ByteRepr a, FromX a) => Point a -> LByteString -> Either Text (Point a) +-- fromCompressedForm (Point onex _) bs = if isInfinity then pure Infinity else do +-- k <- note "Padding failed" (toPaddedBytes (ByteOrderLength MostSignificantFirst (calcReprLength onex minReprLength)) 0x80) +-- let +-- nbs = B.pack $ B.zipWith (.&.) (toS bs) k +-- (xbs, yodd) = if fromBytesToInteger MostSignificantFirst nbs == 0x80 then +-- (B.pack (B.zipWith xor (toS bs) k), True) +-- else +-- (toS bs, False) +-- x <- note "Failed to deserialise x" (fromRepr (ByteOrderLength LeastSignificantFirst minReprLength) onex xbs) +-- y <- note "Failed to get y from x" (yFromX x (selOdd yodd)) +-- pure (Point x y) +-- where +-- selOdd yesOdd y1 y2 = if yesOdd then whichOdd y1 y2 else whichEven y1 y2 +-- whichOdd y1 y2 = if isOdd y1 then y1 else y2 +-- whichEven y1 y2 = if isOdd y1 then y2 else y1 +-- isInfinity = fromBytesToInteger MostSignificantFirst (toS bs) == 0 +-- fromCompressedForm Infinity _ = Left "Cannot use infinity to extract from bytestring" diff --git a/src/Pairing/Serialize/Types.hs b/src/Pairing/Serialize/Types.hs --- a/src/Pairing/Serialize/Types.hs +++ b/src/Pairing/Serialize/Types.hs @@ -2,56 +2,56 @@ Base API for Point serialisation for G1, G2 and GT -} -module Pairing.Serialize.Types ( - MkCompressedForm(..), - MkUncompressedForm(..), - FromSerialisedForm(..), - FromUncompressedForm(..), - minReprLength, - buildPoint, - parseBS -) where - -import Protolude hiding (putByteString) -import Pairing.Point -import Pairing.Fq -import Data.ByteString.Builder -import Data.ByteString as B hiding (length) -import qualified Data.ByteString as B -import Data.Binary.Get -import Data.Binary.Put (Put, putWord8, putWord16le, runPut, putByteString) -import Control.Error -import Pairing.ByteRepr -import Pairing.CyclicGroup - -class MkCompressedForm a where - -- | The serialisation may fail if y cannot be obtained from x - serializeCompressed :: (ByteRepr b, FromX b, Ord b) => a -> Point b -> Maybe LByteString - -class MkUncompressedForm a where - serializePointUncompressed :: (ByteRepr b, FromX b, Eq b) => a -> Point b -> Maybe LByteString - serializeUncompressed :: (ByteRepr c) => a -> c -> Maybe LByteString - -class FromSerialisedForm a where - unserializePoint :: (ByteRepr b, FromX b, Ord b, Show b, Validate (Point b)) => a -> Point b -> LByteString -> Either Text (Point b) - -class FromUncompressedForm a where - unserialize :: (ByteRepr b, Validate b, Eq b, Show b) => a -> b -> LByteString -> Either Text b - -minReprLength :: Int -minReprLength = B.length $ toBytes p - where - p = natVal (witness :: Fq) - -buildPoint :: ByteRepr a => a -> ByteOrderLength -> ByteString -> ByteOrderLength -> ByteString -> Maybe (Point a) -buildPoint one xlen xbs ylen ybs = do - x <- fromRepr xlen one xbs - y <- fromRepr ylen one ybs - pure (Point x y) - -parseBS :: (Validate a, Show a) => Get (Maybe a) -> LByteString -> Either Text a -parseBS f bs = do - (_, _, mpt) <- first (\(_,_,err) -> toS err) (runGetOrFail f bs) - case mpt of - Just pt -> if isValidElement pt then (Right pt) else Left ("Element was not valid after deserialisation: " <> show pt) - Nothing -> Left "Point could not be parsed" +module Pairing.Serialize.Types where +-- ( MkCompressedForm(..) +-- , MkUncompressedForm(..) +-- , FromSerialisedForm(..) +-- , FromUncompressedForm(..) +-- , minReprLength +-- , buildPoint +-- , parseBS +-- ) where +-- +-- import Protolude hiding (putByteString) +-- import Pairing.Point +-- import Pairing.Fq +-- import Data.ByteString.Builder +-- import Data.ByteString as B hiding (length) +-- import qualified Data.ByteString as B +-- import Data.Binary.Get +-- import Data.Binary.Put (Put, putWord8, putWord16le, runPut, putByteString) +-- import Control.Error +-- import Pairing.ByteRepr +-- import Pairing.CyclicGroup +-- +-- class MkCompressedForm a where +-- -- | The serialisation may fail if y cannot be obtained from x +-- serializeCompressed :: (ByteRepr b, FromX b, Ord b) => a -> Point b -> Maybe LByteString +-- +-- class MkUncompressedForm a where +-- serializePointUncompressed :: (ByteRepr b, FromX b, Eq b) => a -> Point b -> Maybe LByteString +-- serializeUncompressed :: (ByteRepr c) => a -> c -> Maybe LByteString +-- +-- class FromSerialisedForm a where +-- unserializePoint :: (ByteRepr b, FromX b, Ord b, Show b, Validate (Point b)) => a -> Point b -> LByteString -> Either Text (Point b) +-- +-- class FromUncompressedForm a where +-- unserialize :: (ByteRepr b, Validate b, Eq b, Show b) => a -> b -> LByteString -> Either Text b +-- +-- minReprLength :: Int +-- minReprLength = B.length $ toBytes p +-- where +-- p = natVal (witness :: Fq) +-- +-- buildPoint :: ByteRepr a => a -> ByteOrderLength -> ByteString -> ByteOrderLength -> ByteString -> Maybe (Point a) +-- buildPoint one xlen xbs ylen ybs = do +-- x <- fromRepr xlen one xbs +-- y <- fromRepr ylen one ybs +-- pure (Point x y) +-- +-- parseBS :: (Validate a, Show a) => Get (Maybe a) -> LByteString -> Either Text a +-- parseBS f bs = do +-- (_, _, mpt) <- first (\(_,_,err) -> toS err) (runGetOrFail f bs) +-- case mpt of +-- Just pt -> if isValidElement pt then (Right pt) else Left ("Element was not valid after deserialisation: " <> show pt) +-- Nothing -> Left "Point could not be parsed" diff --git a/tests/ByteTests.hs b/tests/ByteTests.hs new file mode 100644 --- /dev/null +++ b/tests/ByteTests.hs @@ -0,0 +1,61 @@ +module ByteTests where + +import Protolude + +import ExtensionField +import GaloisField +import Pairing.ByteRepr +import Pairing.Curve +import PrimeField +import Test.QuickCheck.Monadic +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +testByte :: TestTree +testByte = testGroup "Byte" + [ testProperty "Fq" prop_fqByteRepr + , testProperty "Fq2" prop_fq2ByteRepr + , testProperty "Fq6" prop_fq6ByteRepr + , testProperty "Fq12" prop_fq12ByteRepr + ] + +byteReprTest :: (ByteRepr k, GaloisField k) + => k -> Pairing.ByteRepr.ByteOrder -> Int -> Assertion +byteReprTest f bo sz = do + let t = mkRepr (ByteOrderLength bo sz) f + assertBool ("mkRepr " <> show f) (isJust t) + let bs = fromMaybe (panic "unreachable.") t + let d = fromRepr (ByteOrderLength bo sz) f bs + assertBool ("fromRepr " <> show f) (isJust d) + d @?= Just f + +primeFieldTest :: (ByteRepr (PrimeField p), KnownNat p) + => PrimeField p -> Assertion +primeFieldTest f = do + byteReprTest f MostSignificantFirst 32 + byteReprTest f LeastSignificantFirst 32 + byteReprTest f MostSignificantFirst 64 + byteReprTest f LeastSignificantFirst 64 + +extensionFieldTest :: (ByteRepr (ExtensionField k im), IrreducibleMonic k im) + => ExtensionField k im -> Assertion +extensionFieldTest f = case fromField f of + [] -> pure () + _ -> do + byteReprTest f MostSignificantFirst 32 + byteReprTest f LeastSignificantFirst 32 + byteReprTest f MostSignificantFirst 64 + byteReprTest f LeastSignificantFirst 64 + +prop_fqByteRepr :: Fq -> Property +prop_fqByteRepr = monadicIO . run . primeFieldTest + +prop_fq2ByteRepr :: Fq2 -> Property +prop_fq2ByteRepr = monadicIO . run . extensionFieldTest + +prop_fq6ByteRepr :: Fq6 -> Property +prop_fq6ByteRepr = monadicIO . run . extensionFieldTest + +prop_fq12ByteRepr :: Fq12 -> Property +prop_fq12ByteRepr = monadicIO . run . extensionFieldTest diff --git a/tests/Driver.hs b/tests/Driver.hs deleted file mode 100644 --- a/tests/Driver.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/tests/HashTests.hs b/tests/HashTests.hs new file mode 100644 --- /dev/null +++ b/tests/HashTests.hs @@ -0,0 +1,22 @@ +module HashTests where + +import Protolude + +import Curve +import Pairing.Hash +import Test.QuickCheck.Instances () +import Test.QuickCheck.Monadic +import Test.Tasty +import Test.Tasty.QuickCheck + +testHash :: TestTree +testHash = testGroup "Hash" + [ testProperty "swEncBN" prop_swEncBN + ] + +prop_swEncBN :: ByteString -> Property +prop_swEncBN bs = monadicIO $ do + toCurveMay <- run $ swEncBN bs + assert $ isJust toCurveMay + let toCurve = fromMaybe (panic "unreachable.") toCurveMay + assert $ def toCurve diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Protolude + +import Test.Tasty + +import ByteTests +import HashTests +import PairingTests +import SerializeTests + +main :: IO () +main = defaultMain $ + testGroup "Pairing" [testByte, testHash, testPairing, testSerialize] diff --git a/tests/PairingTests.hs b/tests/PairingTests.hs new file mode 100644 --- /dev/null +++ b/tests/PairingTests.hs @@ -0,0 +1,147 @@ +module PairingTests where + +import Protolude + +import Curve.Weierstrass +import ExtensionField +import Group.Field +import Pairing.Curve +import Pairing.Pairing +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +testPairing :: TestTree +testPairing = testGroup "Pairing" + [ testCase "input G1 valid" unit_inpG1_valid + , testCase "input G2 valid" unit_inpG2_valid + , testCase "pairing libff 0" unit_pairingLibff_0 + , testCase "pairing libff 1" unit_pairingLibff_1 + , testProperty "pairing bilinear" prop_pairingBilinear + , testProperty "pairing non degenerate" prop_pairingNonDegenerate + , testProperty "pairing power test" prop_pairingPowerTest + , testProperty "correct Frobenius Fq12" prop_frobeniusFq12Correct + , testProperty "correct final exponentiation" prop_finalExponentiationCorrect + ] + +-- Random points in G1, G2 as generated by libff. +inpG1 :: G1 +inpG1 = A + 1368015179489954701390400359078579693043519447331113978918064868415326638035 + 9918110051302171585080402603319702774565515993150576347155970296011118125764 + +inpG2 :: G2 +inpG2 = A + ( toField [ 2725019753478801796453339367788033689375851816420509565303521482350756874229 + , 7273165102799931111715871471550377909735733521218303035754523677688038059653 + ] + ) + ( toField [ 2512659008974376214222774206987427162027254181373325676825515531566330959255 + , 957874124722006818841961785324909313781880061366718538693995380805373202866 + ] + ) + +beforeExponentiation :: GT +beforeExponentiation = F $ + toField [ toField [ toField [ 10244919957345566208036224388367387294947954375520342002142038721148536068658 + , 20520725903107462730350108147804326707908059028221039276493719519842949720531 + ] + , toField [ 6086095302240468555411758663466251351417777262748587710512082696159022563215 + , 3498483043828007000664704983384438380014626741459095899124517210966193962189 + ] + , toField [ 9839947403899670326057934148290729066991318244952536153418081752510541932805 + , 9202072764973620760720243946210007480782851719144203914690329192926361472509 + ] + ] + , toField [ toField [ 10396963991176748371570893144856868074352236348257264320828640725417622807401 + , 16918234646064442383576265933863121396979541666923405352165222603555475148795 + ] + , toField [ 1146287855099517708899800840204495527878843746533321795244252048321172986641 + , 15272723827732170058231690870045992172379497733734277515700990114389642596090 + ] + , toField [ 6026541190208646112995382377707652888403252171847993766999540977939986078453 + , 4033750506662808934164561353819561401109395743946249795674228367029912558059 + ] + ] + ] + +afterExponentiation :: GT +afterExponentiation = F $ + toField [ toField [ toField [ 7297928317524675251652102644847406639091474940444702627333408876432772026640 + , 18010865284024443253481973710158529446817119443459787454101328040744995455319 + ] + , toField [ 14179125828660221708486990054318233868908974550229474018509093903907472063156 + , 19672547343219696395323430329000470270122259521813831378125910505067755316037 + ] + , toField [ 10811020225621941034352015694422164943041584464746963243431262955968538467312 + , 18591344525433923700278298641693487837785792806011751060570085671866249379154 + ] + ] + , toField [ toField [ 18214296718386486500838507024306049626571830525675768493345345883297201451077 + , 19227311731387426597265504864999881769743583647552324796732605660514141916117 + ] + , toField [ 15463354980731838106439887363063618463783317416732018231077874458188347926701 + , 3765441250413579779915094051038487360437654739171671492016287185303087270469 + ] + , toField [ 21029416079740174485345021549306749850075185576152640151652655104272393297142 + , 19736982780723093346009254617143639137054958583796054069884522103959451721163 + ] + ] + ] + +-- Sanity check test inputs +unit_inpG1_valid :: Assertion +unit_inpG1_valid + = assertBool "inpG1 does not satisfy curve equation" $ def inpG1 + +unit_inpG2_valid :: Assertion +unit_inpG2_valid + = assertBool "inpG2 does not satisfy curve equation" $ def inpG2 + +-- Test our pairing ouput against that of libff. +unit_pairingLibff_0 :: Assertion +unit_pairingLibff_0 = beforeExponentiation @=? atePairing inpG1 inpG2 + +unit_pairingLibff_1 :: Assertion +unit_pairingLibff_1 = afterExponentiation @=? reducedPairing inpG1 inpG2 + +pairingTestCount :: Int +pairingTestCount = 10 + +prop_pairingBilinear :: Property +prop_pairingBilinear = withMaxSuccess pairingTestCount prop + where + prop :: G1 -> G2 -> Integer -> Integer -> Bool + prop e1 e2 preExp1 preExp2 + = reducedPairing (mul' e1 exp1) (mul' e2 exp2) + == mul' (reducedPairing e1 e2) (exp1 * exp2) + where + -- Quickcheck might give us negative integers or 0, so we + -- take the absolute values instead and add one. + exp1 = abs preExp1 + 1 + exp2 = abs preExp2 + 1 + +prop_pairingNonDegenerate :: Property +prop_pairingNonDegenerate = withMaxSuccess pairingTestCount prop + where + prop :: G1 -> G2 -> Bool + prop e1 e2 = or [ e1 == mempty + , e2 == mempty + , reducedPairing e1 e2 /= mempty + ] + +-- Output of the pairing to the power _r should be the unit of GT. +prop_pairingPowerTest :: Property +prop_pairingPowerTest = withMaxSuccess pairingTestCount prop + where + prop :: G1 -> G2 -> Bool + prop e1 e2 = def (reducedPairing e1 e2) + +prop_frobeniusFq12Correct :: Fq12 -> Bool +prop_frobeniusFq12Correct f = frobeniusNaive 1 f == fq12Frobenius 1 f + +prop_finalExponentiationCorrect :: Property +prop_finalExponentiationCorrect = withMaxSuccess pairingTestCount prop + where + prop :: Fq12 -> Bool + prop f = finalExponentiation f == finalExponentiationNaive f diff --git a/tests/SerializeTests.hs b/tests/SerializeTests.hs new file mode 100644 --- /dev/null +++ b/tests/SerializeTests.hs @@ -0,0 +1,61 @@ +module SerializeTests where + +import Test.Tasty + +testSerialize :: TestTree +testSerialize = testGroup "Serialize" + [ + ] + +-- serializeTest pt compFunc testFunc = do +-- let (Just cbs) = compFunc pt +-- let npt2e = testFunc cbs +-- isRight npt2e @? (Protolude.show npt2e) +-- let (Right npt2) = npt2e +-- pt @=? npt2 +-- +-- serializeUncompProp :: (Ord b, Show b, MkUncompressedForm a, ByteRepr b, FromX b) => (a -> LByteString -> Either Text (Point b)) -> a -> Point b -> Property +-- serializeUncompProp f a g = TQM.monadicIO $ TQM.run $ serializeTest g (serializePointUncompressed a) (f a) +-- +-- serializeCompProp :: (Ord b, Show b, MkCompressedForm a, ByteRepr b, FromX b) => (a -> LByteString -> Either Text (Point b)) -> a -> Point b -> Property +-- serializeCompProp f a g = TQM.monadicIO $ TQM.run $ serializeTest g (serializeCompressed a) (f a) +-- +-- unit_g1SerializeCompMCLWasm :: Assertion +-- unit_g1SerializeCompMCLWasm = do +-- let g1pt = Point (9314493114755198232379544958894901330290171903936264295471737527783061073337 :: Fq) (3727704492399430267836652969370123320076852948746739702603703543134592597527 :: Fq) +-- let hs = hexString "b92db2fcfcba5ad9f6b676de13a5488b54dfd537ae5c96291f399284f7d09794" +-- let Right np = unserializePoint MCLWASM g1 (toSL $ H.toBytes hs) +-- np @=? g1pt +-- +-- prop_g1SerializeUncompJivsov :: G1 -> Property +-- prop_g1SerializeUncompJivsov g = serializeUncompProp fromByteStringG1 Jivsov g +-- +-- prop_g1SerializeCompJivsov :: G1 -> Property +-- prop_g1SerializeCompJivsov g = serializeCompProp fromByteStringG1 Jivsov g +-- +-- prop_g1SerializeCompMCLWasm :: G1 -> Property +-- prop_g1SerializeCompMCLWasm g = serializeCompProp fromByteStringG1 MCLWASM g +-- +-- unit_g2SerializeCompMCLWasm :: Assertion +-- unit_g2SerializeCompMCLWasm = do +-- let fq2x = toField ([6544947162799133903546594463061476713923884516504213524167597810128866380952, 1440920261338086273401746857890494196693993714596389710801111883382590011446] :: [Fq]) :: Fq2 +-- let fq2y = toField ([7927561822697823059695659663409507948904771679743888257723485312240532833493, 2189896469972867352153851473169755334250894385106289486234761879693772655721] :: [Fq]) :: Fq2 +-- let g2pt = Point fq2x fq2y +-- let hs = hexString "980cf2acdb1645247a512f91cbbbbb1f4fa2328c979ae26d550ec7b80e4f780e36f82f7090c4d516a2257fcee804df8421af857b2f80ffccfc11c6f52e882f83" +-- let Right np = unserializePoint MCLWASM g2 (toSL $ H.toBytes hs) +-- np @=? g2pt +-- +-- prop_g2SerializeUncompJivsov :: G2 -> Property +-- prop_g2SerializeUncompJivsov g = serializeUncompProp fromByteStringG2 Jivsov g +-- +-- prop_g2SerializeCompJivsov :: G2 -> Property +-- prop_g2SerializeCompJivsov g = serializeCompProp fromByteStringG2 Jivsov g +-- +-- prop_g2SerializeCompMCLWasm :: G2 -> Property +-- prop_g2SerializeCompMCLWasm g = serializeCompProp fromByteStringG2 MCLWASM g +-- +-- gtSerializeTest :: G1 -> G2 -> Assertion +-- gtSerializeTest g1 g2 = serializeTest (reducedPairing g1 g2) (serializeUncompressed Jivsov) (fromByteStringGT Jivsov) +-- +-- prop_gtSerializeUncomp :: G1 -> G2 -> Property +-- prop_gtSerializeUncomp g1 g2 = TQM.monadicIO $ TQM.run $ gtSerializeTest g1 g2 diff --git a/tests/TestCommon.hs b/tests/TestCommon.hs deleted file mode 100644 --- a/tests/TestCommon.hs +++ /dev/null @@ -1,53 +0,0 @@ -module TestCommon - ( commutes - , associates - , isIdentity - , isInverse - , distributes - ) where - -import Protolude - -commutes - :: Eq a - => (a -> a -> a) - -> a -> a -> Bool -commutes op x y - = (x `op` y) == (y `op` x) - -associates - :: Eq a - => (a -> a -> a) - -> a -> a -> a -> Bool -associates op x y z - = (x `op` (y `op` z)) == ((x `op` y) `op` z) - -isIdentity - :: Eq a - => (a -> a -> a) - -> a - -> a - -> Bool -isIdentity op e x - = (x `op` e == x) && (e `op` x == x) - -isInverse - :: Eq a - => (a -> a -> a) - -> (a -> a) - -> a - -> a - -> Bool -isInverse op inv e x - = (x `op` inv x == e) && (inv x `op` x == e) - -distributes - :: Eq a - => (a -> a -> a) - -> (a -> a -> a) - -> a - -> a - -> a - -> Bool -distributes mult add x y z - = x `mult` (y `add` z) == (x `mult` y) `add` (x `mult` z) diff --git a/tests/TestFields.hs b/tests/TestFields.hs deleted file mode 100644 --- a/tests/TestFields.hs +++ /dev/null @@ -1,157 +0,0 @@ -module TestFields where - -import Protolude - -import GaloisField -import ExtensionField -import Pairing.Fq -import Pairing.Fr -import Pairing.ByteRepr -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import qualified Test.QuickCheck.Monadic as TQM (monadicIO, assert, run) - -import TestCommon - -------------------------------------------------------------------------------- --- Laws of field operations -------------------------------------------------------------------------------- - -testFieldLaws - :: forall a . (Num a, Fractional a, Eq a, Arbitrary a, Show a) - => Proxy a - -> TestName - -> TestTree -testFieldLaws _ descr - = testGroup ("Test field laws of " <> descr) - [ testProperty "commutativity of addition" - $ commutes ((+) :: a -> a -> a) - , testProperty "commutativity of multiplication" - $ commutes ((*) :: a -> a -> a) - , testProperty "associativity of addition" - $ associates ((+) :: a -> a -> a) - , testProperty "associativity of multiplication" - $ associates ((*) :: a -> a -> a) - , testProperty "additive identity" - $ isIdentity ((+) :: a -> a -> a) 0 - , testProperty "multiplicative identity" - $ isIdentity ((*) :: a -> a -> a) 1 - , testProperty "additive inverse" - $ isInverse ((+) :: a -> a -> a) negate 0 - , testProperty "multiplicative inverse" - $ \x -> (x /= (0 :: a)) ==> isInverse ((*) :: a -> a -> a) recip 1 x - , testProperty "multiplication distributes over addition" - $ distributes ((*) :: a -> a -> a) (+) - ] - -------------------------------------------------------------------------------- --- Fq -------------------------------------------------------------------------------- - -test_fieldLaws_Fq :: TestTree -test_fieldLaws_Fq = testFieldLaws (Proxy :: Proxy Fq) "Fq" - -------------------------------------------------------------------------------- --- Fq2 -------------------------------------------------------------------------------- - -test_fieldLaws_Fq2 :: TestTree -test_fieldLaws_Fq2 = testFieldLaws (Proxy :: Proxy Fq2) "Fq2" - --- Defining property for Fq2 as an extension over Fq: u^2 = -1 -unit_uRoot :: Assertion -unit_uRoot = u^2 @=? -1 - where - u = toField [0, 1] :: Fq2 - -unit_fq2Pow :: Assertion -unit_fq2Pow = do - fq2 :: Fq2 <- rnd - let pow5 = ((fq2 ^ 2) ^ 2) * fq2 - pow5 @=? fq2 ^ 5 - let pow10 = ((((fq2 ^ 2) ^ 2) ^ 2) * fq2) * fq2 - pow10 @=? fq2 ^ 10 - -unit_fq2Sqrt :: Assertion -unit_fq2Sqrt = do - fq2 :: Fq2 <- rnd - let sq = fq2 ^ 2 - let (Just rt) = fq2Sqrt sq - sq @=? rt ^ 2 - -------------------------------------------------------------------------------- --- Fq6 -------------------------------------------------------------------------------- - -test_fieldLaws_Fq6 :: TestTree -test_fieldLaws_Fq6 = testFieldLaws (Proxy :: Proxy Fq6) "Fq6" - --- Defining property for Fq6 as an extension over Fq2: v^3 = 9 + u -unit_vRoot :: Assertion -unit_vRoot = v^3 @=? 9 + u - where - v = toField [0, 1] :: Fq6 - u = toField [toField [0, 1]] - -------------------------------------------------------------------------------- --- Fq12 -------------------------------------------------------------------------------- - -test_fieldLaws_Fq12 :: TestTree -test_fieldLaws_Fq12 = testFieldLaws (Proxy :: Proxy Fq12) "Fq12" - --- Defining property for Fq12 as an extension over Fq6: w^2 = v -unit_wRoot :: Assertion -unit_wRoot = w^2 @=? v - where - w = toField [0, 1] :: Fq12 - v = toField [toField [0, 1]] - -------------------------------------------------------------------------------- --- Fr -------------------------------------------------------------------------------- - -test_fieldLaws_Fr :: TestTree -test_fieldLaws_Fr = testFieldLaws (Proxy :: Proxy Fr) "Fr" - -------------------------------------------------------------------------------- --- Byte Representation -------------------------------------------------------------------------------- - -primeFieldByteRepresentationTest :: Fq -> Assertion -primeFieldByteRepresentationTest f = do - byteReprTest f MostSignificantFirst 32 - byteReprTest f LeastSignificantFirst 32 - byteReprTest f MostSignificantFirst 64 - byteReprTest f LeastSignificantFirst 64 - -extensionFieldByteRepresentationTest :: (Show a, Eq a, ByteRepr (ExtensionField a b)) => ExtensionField a b -> Assertion -extensionFieldByteRepresentationTest f = case fromField f of - [] -> pure () - _ -> do - byteReprTest f MostSignificantFirst 32 - byteReprTest f LeastSignificantFirst 32 - byteReprTest f MostSignificantFirst 64 - byteReprTest f LeastSignificantFirst 64 - -byteReprTest :: (Show a, Eq a, ByteRepr a) => a -> Pairing.ByteRepr.ByteOrder -> Int -> Assertion -byteReprTest f bo sz = do - let t = mkRepr (ByteOrderLength bo sz) f - assertBool ("mkRepr " <> show f) (isJust t) - let Just bs = t - let d = fromRepr (ByteOrderLength bo sz) f bs - assertBool ("fromRepr " <> show f) (isJust d) - (Just f) @=? d - -prop_fqByteRepr :: Fq -> Property -prop_fqByteRepr a = TQM.monadicIO $ TQM.run $ primeFieldByteRepresentationTest a - -prop_fq2ByteRepr :: Fq2 -> Property -prop_fq2ByteRepr a = TQM.monadicIO $ TQM.run $ extensionFieldByteRepresentationTest a - -prop_fq6ByteRepr :: Fq6 -> Property -prop_fq6ByteRepr a = TQM.monadicIO $ TQM.run $ extensionFieldByteRepresentationTest a - -prop_fq12ByteRepr :: Fq12 -> Property -prop_fq12ByteRepr a = TQM.monadicIO $ TQM.run $ extensionFieldByteRepresentationTest a diff --git a/tests/TestGroups.hs b/tests/TestGroups.hs deleted file mode 100644 --- a/tests/TestGroups.hs +++ /dev/null @@ -1,182 +0,0 @@ -module TestGroups where - -import Protolude - -import Data.ByteString as BS (null, dropWhile) -import Pairing.Fq -import Pairing.Fr -import Pairing.Group -import Pairing.CyclicGroup -import Pairing.Pairing -import Pairing.Params -import Pairing.Point -import Pairing.ByteRepr -import Pairing.Serialize.Types -import Pairing.Serialize.Jivsov -import Pairing.Serialize.MCLWasm -import ExtensionField (toField) -import Test.Tasty -import Test.Tasty.HUnit -import Test.QuickCheck.Instances -import qualified Test.QuickCheck.Monadic as TQM (monadicIO, assert, run) -import Test.Tasty.QuickCheck -import Data.HexString as H -import TestCommon - -------------------------------------------------------------------------------- --- Laws of group operations -------------------------------------------------------------------------------- - -testAbelianGroupLaws - :: (Eq a, Arbitrary a, Show a) - => (a -> a -> a) - -> (a -> a) - -> a - -> TestName - -> TestTree -testAbelianGroupLaws binOp neg ident descr - = testGroup ("Test Abelian group laws of " <> descr) - [ testProperty "commutativity of addition" - $ commutes binOp - , testProperty "associavity of addition" - $ associates binOp - , testProperty "additive identity" - $ isIdentity binOp ident - , testProperty "additive inverse" - $ isInverse binOp neg ident - ] - -serializeTest pt compFunc testFunc = do - let (Just cbs) = compFunc pt - let npt2e = testFunc cbs - isRight npt2e @? (Protolude.show npt2e) - let (Right npt2) = npt2e - pt @=? npt2 - -g1FromXTest :: G1 -> Assertion -g1FromXTest Infinity = pure () -g1FromXTest pt@(Point x y) = do - let ysq = y ^ 2 - let (Just lysqrt) = fqSqrt max ysq - let (Just sysqrt) = fqSqrt max ysq - let egly = groupFromX max x - let egsy = groupFromX max x - isJust egly @=? True - isJust egsy @=? True - let Just lyg = egly - let Just syg = egsy - (Point x lysqrt) @=? lyg - (Point x sysqrt) @=? syg - -serializeUncompProp :: (Ord b, Show b, MkUncompressedForm a, ByteRepr b, FromX b) => (a -> LByteString -> Either Text (Point b)) -> a -> Point b -> Property -serializeUncompProp f a g = TQM.monadicIO $ TQM.run $ serializeTest g (serializePointUncompressed a) (f a) - -serializeCompProp :: (Ord b, Show b, MkCompressedForm a, ByteRepr b, FromX b) => (a -> LByteString -> Either Text (Point b)) -> a -> Point b -> Property -serializeCompProp f a g = TQM.monadicIO $ TQM.run $ serializeTest g (serializeCompressed a) (f a) - -------------------------------------------------------------------------------- --- G1 -------------------------------------------------------------------------------- - -prop_g1Double :: Point Fq -> Bool -prop_g1Double a = gDouble a == gAdd a a - -test_groupLaws_G1 :: TestTree -test_groupLaws_G1 - = testAbelianGroupLaws gAdd gNeg (Infinity :: G1) "G1" - --- Sanity check our generators/inputs -unit_g1_valid :: Assertion -unit_g1_valid - = assertBool "generator g1 does not satisfy curve equation" $ isOnCurveG1 g1 - -unit_order_g1_valid :: Assertion -unit_order_g1_valid - = gMul g1 _r @=? Infinity - -prop_hashToG1 :: ByteString -> Property -prop_hashToG1 bs = TQM.monadicIO $ do - toCurveMay <- TQM.run (hashToG1 bs) - TQM.assert (isJust toCurveMay) - let Just toCurve = toCurveMay - TQM.assert (isOnCurveG1 toCurve) - -prop_g1FromX :: G1 -> Property -prop_g1FromX g = TQM.monadicIO $ do - TQM.run $ g1FromXTest g - -unit_g1SerializeCompMCLWasm :: Assertion -unit_g1SerializeCompMCLWasm = do - let g1pt = Point (9314493114755198232379544958894901330290171903936264295471737527783061073337 :: Fq) (3727704492399430267836652969370123320076852948746739702603703543134592597527 :: Fq) - let hs = hexString "b92db2fcfcba5ad9f6b676de13a5488b54dfd537ae5c96291f399284f7d09794" - let Right np = unserializePoint MCLWASM g1 (toSL $ H.toBytes hs) - np @=? g1pt - -prop_g1SerializeUncompJivsov :: G1 -> Property -prop_g1SerializeUncompJivsov g = serializeUncompProp fromByteStringG1 Jivsov g - -prop_g1SerializeCompJivsov :: G1 -> Property -prop_g1SerializeCompJivsov g = serializeCompProp fromByteStringG1 Jivsov g - -prop_g1SerializeCompMCLWasm :: G1 -> Property -prop_g1SerializeCompMCLWasm g = serializeCompProp fromByteStringG1 MCLWASM g - -------------------------------------------------------------------------------- --- G2 -------------------------------------------------------------------------------- - -prop_g2Double :: Point Fq2 -> Bool -prop_g2Double a = gDouble a == gAdd a a - -test_groupLaws_G2 :: TestTree -test_groupLaws_G2 - = testAbelianGroupLaws gAdd gNeg (Infinity :: G2) "G2" - -unit_g2_valid :: Assertion -unit_g2_valid - = assertBool "generator g2 does not satisfy curve equation" $ isOnCurveG2 g2 - -unit_order_g2_valid :: Assertion -unit_order_g2_valid - = gMul g2 _r @=? Infinity - -g2FromXTest :: G2 -> Assertion -g2FromXTest Infinity = pure () -g2FromXTest pt@(Point x y) = do - let ysq = y ^ 2 - let (Just ny) = fq2YforX x (\y1 y2 -> if isOdd y1 then y1 else y2) - if (ny /= y) then (Point x y) @=? (Point x (negate ny)) else (Point x y) @=? (Point x ny) - -prop_g2FromX :: G2 -> Property -prop_g2FromX g = TQM.monadicIO $ do - TQM.run $ g2FromXTest g - -unit_g2SerializeCompMCLWasm :: Assertion -unit_g2SerializeCompMCLWasm = do - let fq2x = toField ([6544947162799133903546594463061476713923884516504213524167597810128866380952, 1440920261338086273401746857890494196693993714596389710801111883382590011446] :: [Fq]) :: Fq2 - let fq2y = toField ([7927561822697823059695659663409507948904771679743888257723485312240532833493, 2189896469972867352153851473169755334250894385106289486234761879693772655721] :: [Fq]) :: Fq2 - let g2pt = Point fq2x fq2y - let hs = hexString "980cf2acdb1645247a512f91cbbbbb1f4fa2328c979ae26d550ec7b80e4f780e36f82f7090c4d516a2257fcee804df8421af857b2f80ffccfc11c6f52e882f83" - let Right np = unserializePoint MCLWASM g2 (toSL $ H.toBytes hs) - np @=? g2pt - -prop_g2SerializeUncompJivsov :: G2 -> Property -prop_g2SerializeUncompJivsov g = serializeUncompProp fromByteStringG2 Jivsov g - -prop_g2SerializeCompJivsov :: G2 -> Property -prop_g2SerializeCompJivsov g = serializeCompProp fromByteStringG2 Jivsov g - -prop_g2SerializeCompMCLWasm :: G2 -> Property -prop_g2SerializeCompMCLWasm g = serializeCompProp fromByteStringG2 MCLWASM g - -------------------------------------------------------------------------------- --- GT -------------------------------------------------------------------------------- - --- The group laws for GT are implied by the field tests for Fq12. - -gtSerializeTest :: G1 -> G2 -> Assertion -gtSerializeTest g1 g2 = serializeTest (reducedPairing g1 g2) (serializeUncompressed Jivsov) (fromByteStringGT Jivsov) - -prop_gtSerializeUncomp :: G1 -> G2 -> Property -prop_gtSerializeUncomp g1 g2 = TQM.monadicIO $ TQM.run $ gtSerializeTest g1 g2 diff --git a/tests/TestPairing.hs b/tests/TestPairing.hs deleted file mode 100644 --- a/tests/TestPairing.hs +++ /dev/null @@ -1,121 +0,0 @@ -module TestPairing where - -import Protolude - -import ExtensionField - -import Pairing.Group -import Pairing.Pairing -import Pairing.Point -import Pairing.Fq -import Test.QuickCheck -import Test.Tasty.HUnit - --- Random points in G1, G2 as generated by libff. -inpG1 :: G1 -inpG1 = Point - 1368015179489954701390400359078579693043519447331113978918064868415326638035 - 9918110051302171585080402603319702774565515993150576347155970296011118125764 - - -inpG2 :: G2 -inpG2 = Point - (toField - [ 2725019753478801796453339367788033689375851816420509565303521482350756874229 - , 7273165102799931111715871471550377909735733521218303035754523677688038059653 ] - ) - (toField - [ 2512659008974376214222774206987427162027254181373325676825515531566330959255 - , 957874124722006818841961785324909313781880061366718538693995380805373202866 ] - ) - -beforeExponentiation :: Fq12 -beforeExponentiation - = construct - [ 10244919957345566208036224388367387294947954375520342002142038721148536068658 - , 20520725903107462730350108147804326707908059028221039276493719519842949720531 - , 6086095302240468555411758663466251351417777262748587710512082696159022563215 - , 3498483043828007000664704983384438380014626741459095899124517210966193962189 - , 9839947403899670326057934148290729066991318244952536153418081752510541932805 - , 9202072764973620760720243946210007480782851719144203914690329192926361472509 - , 10396963991176748371570893144856868074352236348257264320828640725417622807401 - , 16918234646064442383576265933863121396979541666923405352165222603555475148795 - , 1146287855099517708899800840204495527878843746533321795244252048321172986641 - , 15272723827732170058231690870045992172379497733734277515700990114389642596090 - , 6026541190208646112995382377707652888403252171847993766999540977939986078453 - , 4033750506662808934164561353819561401109395743946249795674228367029912558059 - ] - -afterExponentiation :: Fq12 -afterExponentiation - = construct - [ 7297928317524675251652102644847406639091474940444702627333408876432772026640 - , 18010865284024443253481973710158529446817119443459787454101328040744995455319 - , 14179125828660221708486990054318233868908974550229474018509093903907472063156 - , 19672547343219696395323430329000470270122259521813831378125910505067755316037 - , 10811020225621941034352015694422164943041584464746963243431262955968538467312 - , 18591344525433923700278298641693487837785792806011751060570085671866249379154 - , 18214296718386486500838507024306049626571830525675768493345345883297201451077 - , 19227311731387426597265504864999881769743583647552324796732605660514141916117 - , 15463354980731838106439887363063618463783317416732018231077874458188347926701 - , 3765441250413579779915094051038487360437654739171671492016287185303087270469 - , 21029416079740174485345021549306749850075185576152640151652655104272393297142 - , 19736982780723093346009254617143639137054958583796054069884522103959451721163 - ] - --- Sanity check test inputs -unit_inpG1_valid :: Assertion -unit_inpG1_valid - = assertBool "inpG1 does not satisfy curve equation" $ isOnCurveG1 inpG1 - -unit_inpG2_valid :: Assertion -unit_inpG2_valid - = assertBool "inpG2 does not satisfy curve equation" $ isOnCurveG2 inpG2 - --- Test our pairing ouput against that of libff. -unit_pairingLibff_0 :: Assertion -unit_pairingLibff_0 = beforeExponentiation @=? atePairing inpG1 inpG2 - -unit_pairingLibff_1 :: Assertion -unit_pairingLibff_1 = afterExponentiation @=? reducedPairing inpG1 inpG2 - -pairingTestCount :: Int -pairingTestCount = 10 - -prop_pairingBilinear :: Property -prop_pairingBilinear = withMaxSuccess pairingTestCount prop - where - prop :: G1 -> G2 -> Integer -> Integer -> Bool - prop e1 e2 preExp1 preExp2 - = reducedPairing (gMul e1 exp1) (gMul e2 exp2) - == (reducedPairing e1 e2)^(exp1 * exp2) - where - -- Quickcheck might give us negative integers or 0, so we - -- take the absolute values instead and add one. - exp1 = abs preExp1 + 1 - exp2 = abs preExp2 + 1 - -prop_pairingNonDegenerate :: Property -prop_pairingNonDegenerate = withMaxSuccess pairingTestCount prop - where - prop :: G1 -> G2 -> Bool - prop e1 e2 = or [ e1 == Infinity - , e2 == Infinity - , reducedPairing e1 e2 /= 1 - ] - --- Output of the pairing to the power _r should be the unit of GT. -prop_pairingPowerTest :: Property -prop_pairingPowerTest = withMaxSuccess pairingTestCount prop - where - prop :: G1 -> G2 -> Bool - prop e1 e2 = isInGT (reducedPairing e1 e2) - -prop_frobeniusFq12Correct :: Fq12 -> Bool -prop_frobeniusFq12Correct f = frobeniusNaive 1 f == fq12Frobenius 1 f - -prop_finalExponentiationCorrect :: Property -prop_finalExponentiationCorrect = withMaxSuccess 10 prop - where - prop :: Fq12 -> Bool - prop f = finalExponentiation f == finalExponentiationNaive f