pairing 0.4.2 → 0.5.0
raw patch · 33 files changed
+1094/−2049 lines, 33 filesdep +elliptic-curvedep −arithmoidep −binarydep −hexstringdep ~basedep ~galois-field
Dependencies added: elliptic-curve
Dependencies removed: arithmoi, binary, hexstring, integer-logarithms, memory, random, tasty-discover
Dependency ranges changed: base, galois-field
Files
- ChangeLog.md +8/−2
- README.md +0/−1
- bench/BenchPairing.hs +0/−248
- bench/Main.hs +0/−13
- benchmarks/HashBenchmarks.hs +17/−0
- benchmarks/Main.hs +12/−0
- benchmarks/PairingBenchmarks.hs +34/−0
- pairing.cabal +37/−54
- src/Pairing/ByteRepr.hs +92/−17
- src/Pairing/Curve.hs +285/−0
- src/Pairing/CyclicGroup.hs +0/−47
- src/Pairing/Fq.hs +0/−278
- src/Pairing/Fr.hs +0/−80
- src/Pairing/Group.hs +0/−170
- src/Pairing/Hash.hs +39/−73
- src/Pairing/Jacobian.hs +0/−30
- src/Pairing/Modular.hs +0/−99
- src/Pairing/Pairing.hs +50/−74
- src/Pairing/Params.hs +0/−61
- src/Pairing/Point.hs +0/−73
- src/Pairing/Serialize/Jivsov.hs +110/−110
- src/Pairing/Serialize/MCLWasm.hs +52/−52
- src/Pairing/Serialize/Types.hs +53/−53
- tests/ByteTests.hs +61/−0
- tests/Driver.hs +0/−1
- tests/HashTests.hs +22/−0
- tests/Main.hs +14/−0
- tests/PairingTests.hs +147/−0
- tests/SerializeTests.hs +61/−0
- tests/TestCommon.hs +0/−53
- tests/TestFields.hs +0/−157
- tests/TestGroups.hs +0/−182
- tests/TestPairing.hs +0/−121
ChangeLog.md view
@@ -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
README.md view
@@ -4,7 +4,6 @@ </a> </p> -[](https://circleci.com/gh/adjoint-io/pairing) [](https://hackage.haskell.org/package/pairing) Implementation of the Barreto-Naehrig (BN) curve construction from
− bench/BenchPairing.hs
@@ -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)- ]- ]
− bench/Main.hs
@@ -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- ]
+ benchmarks/HashBenchmarks.hs view
@@ -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"
+ benchmarks/Main.hs view
@@ -0,0 +1,12 @@+module Main where++import Protolude++import Criterion.Main++import HashBenchmarks+import PairingBenchmarks++main :: IO ()+main = defaultMain+ [benchmarkHash, benchmarkPairing]
+ benchmarks/PairingBenchmarks.hs view
@@ -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)
pairing.cabal view
@@ -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
src/Pairing/ByteRepr.hs view
@@ -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
+ src/Pairing/Curve.hs view
@@ -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]/<u^2 + 1>@.+type Fq2 = BN254T.Fq2++-- | Cubic extension field of @Fq2@ defined as @Fq6 = Fq2[v]/<v^3 - (9 + u)>@.+type Fq6 = BN254TF.Fq6++-- | Quadratic extension field of @Fq6@ defined as @Fq12 = Fq6[w]/<w^2 - v>@.+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
− src/Pairing/CyclicGroup.hs
@@ -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
− src/Pairing/Fq.hs
@@ -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]/<f(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]/<g(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]/<h(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
− src/Pairing/Fr.hs
@@ -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"
− src/Pairing/Group.hs
@@ -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
src/Pairing/Hash.hs view
@@ -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
− src/Pairing/Jacobian.hs
@@ -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))
− src/Pairing/Modular.hs
@@ -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)
src/Pairing/Pairing.hs view
@@ -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))
− src/Pairing/Params.hs
@@ -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
− src/Pairing/Point.hs
@@ -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
src/Pairing/Serialize/Jivsov.hs view
@@ -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)
src/Pairing/Serialize/MCLWasm.hs view
@@ -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"
src/Pairing/Serialize/Types.hs view
@@ -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"
+ tests/ByteTests.hs view
@@ -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
− tests/Driver.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
+ tests/HashTests.hs view
@@ -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
+ tests/Main.hs view
@@ -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]
+ tests/PairingTests.hs view
@@ -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
+ tests/SerializeTests.hs view
@@ -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
− tests/TestCommon.hs
@@ -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)
− tests/TestFields.hs
@@ -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
− tests/TestGroups.hs
@@ -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
− tests/TestPairing.hs
@@ -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