packages feed

pairing 0.2 → 0.3.0

raw patch · 16 files changed

+531/−114 lines, 16 filesdep +binarydep +errorsdep +integer-logarithms

Dependencies added: binary, errors, integer-logarithms

Files

ChangeLog.md view
@@ -1,5 +1,13 @@ # Changelog for pairing +## 0.3++- Square root calculation on Fq2+- Both square roots returned on Fq+- Point serialisation for G1, G2 and GT++## 0.2+ ## 0.1  * Initial release.
bench/BenchPairing.hs view
@@ -8,7 +8,7 @@ import qualified Pairing.Group as Group import qualified Pairing.Point as Point import qualified Pairing.Pairing as Pairing-+import Pairing.CyclicGroup (asInteger) import qualified Pairing.Fq as Fq import qualified Pairing.Fr as Fr import qualified Pairing.Fq2 as Fq2@@ -159,8 +159,12 @@               $ whnf (uncurry (+)) (testFq_1, testFq_2)           , bench "division"               $ whnf (uncurry (/)) (testFq_1, testFq_2)+          , bench "pow"+              $ whnf (Fq.fqPow testFq_1) (asInteger testFr_1)           , bench "inversion"               $ whnf Fq.fqInv testFq_1+          , bench "fqFromX"+              $ whnf (Fq.fqYforX testFq_1) True           ]        , bgroup "Fr"@@ -172,6 +176,8 @@               $ whnf (uncurry (/)) (testFr_1, testFr_2)           , bench "inversion"               $ whnf Fr.frInv testFr_1+          , bench "pow"+              $ whnf (Fr.frPow testFr_1) (asInteger testFr_2)           ]        , bgroup "Fq2"@@ -183,12 +189,18 @@               $ whnf (uncurry (/)) (testFq2_1, testFq2_2)           , bench "squaring"               $ whnf Fq2.fq2sqr testFq2_1+          , bench "pow"+              $ whnf (Fq2.fq2pow testFq2_1) (asInteger testFr_1)           , bench "negation"               $ whnf negate testFq2_1           , bench "inversion"               $ whnf Fq2.fq2inv testFq2_1           , bench "conjugation"               $ whnf Fq2.fq2conj testFq2_1+          , bench "square root"+              $ whnf Fq2.fq2sqrt testFq2_1+          , bench "fq2FromX"+              $ whnf (Fq2.fq2YforX testFq2_1) True            ]        , bgroup "Fq6"
pairing.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: dabb8024b0664bed6aa89f042dbbc95b098bf5f62fb35bd2d70d4a79992e2314+-- hash: d047536a7348fa341206f72c42c935d58cf595375dbccae1dbcf0789040cbeb0  name:           pairing-version:        0.2+version:        0.3.0 synopsis:       Optimal ate pairing over Barreto-Naehrig curves description:    Optimal ate pairing over Barreto-Naehrig curves category:       Cryptography@@ -48,18 +48,23 @@       Pairing.Jacobian       Pairing.CyclicGroup       Pairing.Hash+      Pairing.Serialize+      Pairing.ByteRepr   other-modules:       Pairing.Modular   hs-source-dirs:       src-  default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances ExplicitForAll RankNTypes DataKinds KindSignatures GeneralizedNewtypeDeriving TypeApplications ExistentialQuantification ScopedTypeVariables DeriveGeneric+  default-extensions: LambdaCase RecordWildCards OverloadedStrings NoImplicitPrelude FlexibleInstances ExplicitForAll RankNTypes DataKinds KindSignatures GeneralizedNewtypeDeriving TypeApplications ExistentialQuantification ScopedTypeVariables DeriveGeneric BangPatterns FlexibleContexts   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   build-depends:       QuickCheck     , arithmoi     , base >=4.7 && <5+    , binary     , bytestring     , cryptonite+    , errors+    , integer-logarithms     , memory     , protolude >=0.2     , random@@ -77,12 +82,16 @@       Paths_pairing   hs-source-dirs:       tests+  default-extensions: FlexibleContexts   build-depends:       QuickCheck     , arithmoi     , base+    , binary     , bytestring     , cryptonite+    , errors+    , integer-logarithms     , memory     , pairing     , protolude >=0.2@@ -106,9 +115,12 @@       QuickCheck     , arithmoi     , base >=4.7 && <5+    , binary     , bytestring     , criterion     , cryptonite+    , errors+    , integer-logarithms     , memory     , pairing     , protolude >=0.2
+ src/Pairing/ByteRepr.hs view
@@ -0,0 +1,33 @@+module Pairing.ByteRepr where
+
+import Protolude
+import Data.ByteString as B
+import Data.ByteString.Builder
+
+class ByteRepr a where
+  mkRepr :: a -> Maybe ByteString
+  fromRepr :: a -> ByteString -> Maybe a
+  reprLength :: a -> Int
+
+toBytes :: Integer -> ByteString
+toBytes x = B.reverse . B.unfoldr (fmap go) . Just $ changeSign x
+  where
+    changeSign :: Num a => a -> a
+    changeSign | x < 0     = subtract 1 . negate
+               | otherwise = identity
+    go :: Integer -> (Word8, Maybe Integer)
+    go x = ( b, i )
+      where
+        b = changeSign (fromInteger x)
+        i | x >= 128  = Just (x `shiftR` 8 )
+          | otherwise = Nothing
+
+toPaddedBytes :: Int -> Integer -> Maybe ByteString
+toPaddedBytes len a = if B.length bs > len then Nothing else Just (B.append (B.replicate (len - B.length bs) 0x0)  bs)
+  where
+    bs = toBytes a
+
+fromBytesToInteger :: ByteString -> Integer
+fromBytesToInteger = B.foldl' f 0
+  where
+    f a b = a `shiftL` 8 .|. fromIntegral b
src/Pairing/CyclicGroup.hs view
@@ -2,18 +2,26 @@   ( AsInteger(..)   , CyclicGroup(..)   , sumG+  , FromX(..)+  , Validate (..)   ) where  import Protolude+import Crypto.Random (MonadRandom)+import Data.ByteString.Builder+import Data.ByteString as BS  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) => g -> m g  -- | Sum all the elements of some container according to its group -- structure.@@ -22,3 +30,14 @@  instance AsInteger Int where   asInteger = toInteger++instance AsInteger Integer where+  asInteger = identity++class FromX a where+  yFromX :: a -> LargestY -> Maybe a+  isLargestY :: a -> Bool++class Validate a where+  isValidElement :: a -> Bool+
src/Pairing/Fq.hs view
@@ -14,18 +14,20 @@   fqZero,   fqOne,   fqNqr,-  euclidean,+  fqPow,+  fqSqrt,   random,-  Pairing.Fq.fromBytes+  fqYforX,+  fromBytesToInteger ) where  import Protolude import Crypto.Random (MonadRandom) import Crypto.Number.Generate (generateMax) import Pairing.Params as Params-import Pairing.CyclicGroup+import Pairing.CyclicGroup (AsInteger(..), FromX(..))+import Pairing.ByteRepr import Pairing.Modular as M-import Data.Bits import qualified Data.ByteString as BS import Data.Bits import Math.NumberTheory.Moduli.Class@@ -56,14 +58,19 @@   (/) = fqDiv   fromRational (a :% b) = Fq a / Fq b +instance FromX Fq where+  yFromX = fqYforX+  isLargestY y = y > negate y++instance ByteRepr Fq where+  mkRepr f@(Fq a) = toPaddedBytes (reprLength f) a+  fromRepr _ bs = Just (Fq $ fromBytesToInteger bs)+  reprLength _ = 32+ -- | Turn an integer into an @Fq@ number, should be used instead of -- the @Fq@ constructor. new :: Integer -> Fq-new a = Fq $ withQ $ (getVal . newMod a)--{-# INLINE norm #-}-norm :: Fq -> Fq-norm (Fq a) = new a+new a = Fq $ withQ (getVal . newMod a)  {-# INLINE fqAdd #-} fqAdd :: Fq -> Fq -> Fq@@ -89,6 +96,10 @@ fqDiv :: Fq -> Fq -> Fq fqDiv (Fq a) (Fq b) = Fq $ withQ (modBinOp a b (/)) +{-# INLINE fqPow #-}+fqPow :: Integral e => Fq -> e -> Fq+fqPow (Fq a) b = Fq $ withQ (modUnOp a (flip powMod b))+ {-# INLINE fqNqr #-} -- | Quadratic non-residue fqNqr :: Fq@@ -109,30 +120,17 @@ fqOne :: Fq fqOne = Fq 1 -inv :: Fq -> Fq-inv (Fq a) = Fq $ euclidean a _q `mod` _q---- | Euclidean algorithm to compute inverse in an integral domain @a@-euclidean :: (Integral a) => a -> a -> a-euclidean a b = fst (inv' a b)--{-# INLINEABLE inv' #-}-{-# SPECIALISE inv' :: Integer -> Integer -> (Integer, Integer) #-}-inv' :: (Integral a) => a -> a -> (a, a)-inv' a b =-  case b of-   1 -> (0, 1)-   _ -> let (e, f) = inv' b d-        in (f, e - c*f)-  where c = a `div` b-        d = a `mod` b+fqSqrt :: Bool -> Fq -> Maybe Fq+fqSqrt largestY (Fq a) = do+  (y1, y2) <- withQM (modUnOpMTup a bothSqrtOf)+  Fq <$> if largestY then Just (max y1 y2) else Just (min y1 y2)  random :: MonadRandom m => m Fq random = do   seed <- generateMax _q   pure (Fq seed) -fromBytes :: ByteString -> Fq-fromBytes bs = Fq $ withQ (M.toInteger . M.fromBytes bs) -+fqYforX :: Fq -> Bool -> Maybe Fq+fqYforX x largestY = fqSqrt largestY (x `fqPow` 3 + new _b)+
src/Pairing/Fq12.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Strict #-}+{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}  -- | Final quadratic extension of the tower: --@@ -29,12 +30,15 @@ import Pairing.Fq6 (Fq6(..)) import qualified Pairing.Fq2 as Fq2 import qualified Pairing.Fq6 as Fq6+import Pairing.CyclicGroup (AsInteger(..), FromX(..)) import Pairing.Params+import Pairing.ByteRepr+import Data.ByteString as B (length, splitAt)  -- | Field extension defined as Fq6[w]/w^2 - v data Fq12 = Fq12 { fq12x :: Fq6, fq12y :: Fq6 } -- ^ Use @new@ instead                                                 -- of this constructor-  deriving (Eq, Show)+  deriving (Eq, Show, Generic, NFData)  instance Num Fq12 where   (+)         = fq12add@@ -47,6 +51,15 @@ instance Fractional Fq12 where   (/) = fq12div   fromRational (a :% b) = fq12int a / fq12int b++instance ByteRepr Fq12 where+  mkRepr (Fq12 x y) = mkRepr x <> mkRepr y+  fromRepr (Fq12 x _) bs = do+    let (xbs, ybs) = B.splitAt (reprLength x) bs+    x <- fromRepr Fq6.fq6one xbs+    y <- fromRepr Fq6.fq6one ybs+    Just (Fq12 x y)+  reprLength (Fq12 x y)  = reprLength x + reprLength y  -- | Create a new value in @Fq12@ by providing a list of twelve -- coefficients in @Fq@, should be used instead of the @Fq12@
src/Pairing/Fq2.hs view
@@ -20,17 +20,24 @@   fq2zero,   fq2conj,   fq2sqr,+  fq2sqrt,+  fq2pow,+  fq2YforX,   mulXi,   divXi,   xi,-  Pairing.Fq2.random+  Pairing.Fq2.random, ) where  import Protolude import Crypto.Random (MonadRandom)-+import Pairing.Modular import Pairing.Fq as Fq import qualified Pairing.Params as Params+import Data.Bits+import Data.ByteString as B (length, splitAt)+import Pairing.CyclicGroup (AsInteger(..), FromX(..))+import Pairing.ByteRepr  -- | Quadratic extension of @Fq@ defined as @Fq[u]/x^2 + 1@ data Fq2 = Fq2 { fq2x :: Fq, fq2y :: Fq } -- ^ Use @new@ instead of@@ -53,6 +60,22 @@   (/) = fq2div   fromRational (a :% b) = fq2int a / fq2int b +instance Ord Fq2 where+  compare (Fq2 x y) (Fq2 a b)+    | compare x a == EQ = compare y b+    | otherwise = compare x a++instance FromX Fq2 where+  yFromX = fq2YforX+  isLargestY y = y > negate y++instance ByteRepr Fq2 where+  mkRepr (Fq2 x y) = mkRepr x <> mkRepr y+  fromRepr (Fq2 x _) bs = do+    let (xbs, ybs) = B.splitAt (reprLength x) bs+    Just (Fq2 (Fq $ fromBytesToInteger xbs) (Fq $ fromBytesToInteger ybs))+  reprLength (Fq2 x y) = reprLength x + reprLength y+ -- | Cubic non-residue in @Fq2@ xi :: Fq2 xi = Fq2 xiA xiB@@ -110,6 +133,13 @@     c0 = bb * fqNqr + aa     c1 = (a0 + a1) * (a0 + a1) - aa - bb +{-# INLINE fq2pow #-}+fq2pow :: Fq2 -> Integer -> Fq2+fq2pow b 0 = fq2one+fq2pow b e = t * fq2pow (b * b) (shiftR e 1)+  where +    t = if testBit e 0 then b else fq2one+ -- | Multiplicative inverse fq2inv :: Fq2 -> Fq2 fq2inv (Fq2 a0 a1) = Fq2 c0 c1@@ -122,9 +152,41 @@ fq2conj :: Fq2 -> Fq2 fq2conj (Fq2 x y) = Fq2 x (negate y) +-- | 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 = a `fq2pow` qm3by4+  let alpha = (fq2sqr a1) * a+  let a0 = (alpha `fq2pow` Params._q) * alpha+  if  a0 == neg1 then Nothing else do+    let x0 = a1 * a+    if alpha == neg1 then Just (a1 `fq2mul` Pairing.Fq2.new fqZero fqOne) else do+      let b = (alpha + fq2one) `fq2pow` qm1by2+      Just (b * x0)+  where+    neg1 = Pairing.Fq2.new (negate fqOne) fqZero+    qm3by4 = withQ (modBinOp (Params._q -3) 4 (/))+    qm1by2 = withQ (modBinOp (Params._q -1) 2 (/))  random :: MonadRandom m => m Fq2 random = do   x <- Fq.random   y <- Fq.random   pure (Fq2 x y)++-- https://docs.rs/pairing/0.14.1/src/pairing/bls12_381/ec.rs.html#102-124+fq2YforX :: Fq2 -> Bool -> Maybe Fq2+fq2YforX x ly +  | ly = newy+  | otherwise = negate <$> newy+  where+    newy = fq2sqrt (x `fq2pow` 3 + Fq2 (b * inv_xi_a) (b * inv_xi_b))+    (Fq2 inv_xi_a inv_xi_b) = fq2inv xi+    b = Fq Params._b++++
src/Pairing/Fq6.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Strict #-}+{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}  -- | Cubic extension of the tower: --@@ -26,6 +27,9 @@  import Pairing.Fq2 (Fq2) import qualified Pairing.Fq2 as Fq2+import Pairing.CyclicGroup (AsInteger(..), FromX(..))+import Data.ByteString as B (length, splitAt)+import Pairing.ByteRepr  -- | Field extension defined as Fq2[v]/v^3 - (9 + u) data Fq6@@ -34,7 +38,7 @@     , fq6y :: Fq2     , fq6z :: Fq2     }-  deriving (Eq, Show)+  deriving (Eq, Show, Generic, NFData)  instance Num Fq6 where   (+)         = fq6add@@ -47,6 +51,17 @@ instance Fractional Fq6 where   (/) = fq6div   fromRational (a :% b) = fq6int a / fq6int b++instance ByteRepr Fq6 where+  mkRepr (Fq6 x y z) = mkRepr x <> mkRepr y <> mkRepr z+  fromRepr (Fq6 x _ _) bs = do+    let (xbs, yzbs) = B.splitAt (reprLength x) bs+    let (ybs, zbs) = B.splitAt (reprLength x) yzbs+    x <- fromRepr Fq2.fq2one xbs+    y <- fromRepr Fq2.fq2one ybs+    z <- fromRepr Fq2.fq2one zbs+    Just (Fq6 x y z)+  reprLength (Fq6 x y z) = reprLength x + reprLength y + reprLength z  -- | Create a new value in @Fq6@, should be used instead of the @Fq6@ -- constructor.
src/Pairing/Fr.hs view
@@ -6,6 +6,9 @@   Fr(..),   new,   frInv,+  frPow,+  frAdd,+  frNeg,   random,   isRootOfUnity,   isPrimitiveRootOfUnity,@@ -20,8 +23,9 @@ import Text.PrettyPrint.Leijen.Text  import Pairing.Params-import Pairing.CyclicGroup-import Pairing.Fq (euclidean)+import Pairing.CyclicGroup (AsInteger(..))+import Pairing.Modular+import Math.NumberTheory.Moduli.Class  instance AsInteger Fr where   asInteger (Fr n) = n@@ -48,19 +52,15 @@ -- | Turn an integer into an @Fr@ number, should be used instead of -- the @Fr@ constructor. new :: Integer -> Fr-new a = Fr (a `mod` _r)--{-# INLINE norm #-}-norm :: Fr -> Fr-norm (Fr a) = Fr (a `mod` _r)+new a = Fr $ withR (getVal . newMod a)  {-# INLINE frAdd #-} frAdd :: Fr -> Fr -> Fr-frAdd (Fr a) (Fr b) = norm (Fr (a+b))+frAdd (Fr a) (Fr b) = Fr $ withR (modBinOp a b (+))  {-# INLINE frMul #-} frMul :: Fr -> Fr -> Fr-frMul (Fr a) (Fr b) = norm (Fr (a*b))+frMul (Fr a) (Fr b) = Fr $ withR (modBinOp a b (*))  {-# INLINE frAbs #-} frAbs :: Fr -> Fr@@ -68,21 +68,21 @@  {-# INLINE frSig #-} frSig :: Fr -> Fr-frSig (Fr a) = Fr (signum a  `mod` _r)+frSig (Fr a) = Fr $ withR (modUnOp a signum)  {-# INLINE frNeg #-} frNeg :: Fr -> Fr-frNeg (Fr a) = Fr ((-a) `mod` _r)+frNeg (Fr a) = Fr $ withR (modUnOp a negate)  {-# INLINE frDiv #-} frDiv :: Fr -> Fr -> Fr-frDiv a b = frMul a (inv b)--inv :: Fr -> Fr-inv (Fr a) = Fr $ euclidean a _r `mod` _r+frDiv (Fr a) (Fr b) = Fr $ withR (modBinOp a b (/))  frInv :: Fr -> Fr-frInv = inv+frInv a = 1 / a++frPow :: Integral e => Fr -> e -> Fr+frPow (Fr a) b = Fr $ withQ (modUnOp a (`powMod` b))  random :: MonadRandom m => m Fr random = do
src/Pairing/Group.hs view
@@ -15,8 +15,10 @@   b1,   b2,   hashToG1,-  randomG1,-  randomG2+  groupFromX,+  fromByteStringG1,+  fromByteStringG2,+  fromByteStringGT ) where  import Protolude@@ -25,12 +27,17 @@ import Pairing.Fq as Fq import Pairing.Fq2 as Fq2 import Pairing.Fq12 as Fq12+import Pairing.Fr as Fr import Pairing.Point import Pairing.Params import Pairing.CyclicGroup import Test.QuickCheck import Pairing.Hash import Crypto.Random (MonadRandom)+import Pairing.Modular+import System.Random+import Pairing.Serialize+import Pairing.ByteRepr  -- | G1 is E(Fq) defined by y^2 = x^3 + b type G1 = Point Fq@@ -60,7 +67,17 @@   order _ = _r   expn a b = gMul a (asInteger b)   inverse = gNeg+  random _ = randomG1 +instance Validate G1 where+  isValidElement = isOnCurveG1++instance ToCompressedForm G1 where+  serializeCompressed = fmap toS . toCompressedForm++instance ToUncompressedForm G1 where+  serializeUncompressed = fmap toS . toUncompressedForm+ instance Monoid G2 where   mappend = gAdd   mempty = Infinity@@ -70,7 +87,17 @@   order _ = _r   expn a b = gMul a (asInteger b)   inverse = gNeg+  random _ = randomG2 +instance Validate G2 where+  isValidElement = isOnCurveG2++instance ToCompressedForm G2 where+  serializeCompressed = fmap toS . toCompressedForm++instance ToUncompressedForm G2 where+  serializeUncompressed = fmap toS . toUncompressedForm+ instance Monoid GT where   mappend = (*)   mempty = 1@@ -80,7 +107,14 @@   order = notImplemented -- should be a factor of _r   expn a b = a ^ asInteger b   inverse = recip+  random _ = Fq12.random +instance ToUncompressedForm GT where+  serializeUncompressed = fmap toS . elementToUncompressedForm++instance Validate GT where+  isValidElement = isInGT+ -- | Generator for G1 g1 :: G1 g1 = Point 1 2@@ -103,7 +137,7 @@ isOnCurveG1 Infinity   = True isOnCurveG1 (Point x y)-  = (y ^ 2 == x ^ 3 + Fq _b)+  = (y `fqPow` 2 == x `fqPow` 3 + Fq _b)  -- | Test whether a value in G2 satisfies the corresponding curve -- equation@@ -111,7 +145,7 @@ isOnCurveG2 Infinity   = True isOnCurveG2 (Point x y)-  = (y ^ 2 == x ^ 3 + (Fq2 (b * inv_xi_a) (b * inv_xi_b)))+  = y `fq2pow` 2 == x `fq2pow` 3 + Fq2 (b * inv_xi_a) (b * inv_xi_b)   where     (Fq2 inv_xi_a inv_xi_b) = Fq2.fq2inv Fq2.xi     b = Fq _b@@ -138,15 +172,30 @@ instance Arbitrary (Point Fq2) where -- G2   arbitrary = gMul g2 . abs <$> (arbitrary :: Gen Integer) -hashToG1 :: (MonadIO m, MonadRandom m) => ByteString -> m G1+hashToG1 :: MonadIO m => ByteString -> m (Maybe G1) hashToG1 = swEncBN -randomG1 :: (MonadIO m, MonadRandom m) => m G1+randomG1 :: (MonadRandom m) => m G1 randomG1 = do   Fq r <- Fq.random   pure (gMul g1 r) -randomG2 :: (MonadIO m, MonadRandom m) => m G2+randomG2 :: (MonadRandom m) => m G2 randomG2 = do   Fq r <- Fq.random   pure (gMul g2 r)++groupFromX :: (Validate (Point a), FromX a) => Bool -> a -> Maybe (Point a)+groupFromX largestY x = do+  y <- yFromX x largestY+  if isValidElement (Point x y) then Just (Point x y) else Nothing++fromByteStringG1 :: ByteString -> Either Text G1+fromByteStringG1 = pointFromByteString fqOne . toSL++fromByteStringG2 :: ByteString -> Either Text G2+fromByteStringG2 = pointFromByteString fq2one . toSL++fromByteStringGT :: ByteString -> Either Text GT+fromByteStringGT = elementReadUncompressed fq12one . toSL+
src/Pairing/Hash.hs view
@@ -11,18 +11,10 @@ import Math.NumberTheory.Moduli.Sqrt import Crypto.Random (MonadRandom) import Data.List--sqrtOfMinusThree :: forall m . KnownNat m => Proxy m -> Mod m-sqrtOfMinusThree mName = sqrtOf mName (-3)---- |--- Picks the postive square root only--- |+import Control.Error (runMaybeT, hoistMaybe) -sqrtOf :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m-sqrtOf mName i = case sqrtsMod i of-  [] -> panic ("Could not calculate sqrt " <> show i)-  (x:_) -> x+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))@@ -30,8 +22,10 @@ b ::  forall m . KnownNat m => Proxy m -> Mod m b mName = fromInteger @(Mod m) _b -x1 :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m -> Mod m-x1 mName t w = ((sqrtOfMinusThree mName) - 1) / 2 - (t * w)+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'@@ -51,11 +45,11 @@ i :: Integer -> Integer -> Integer i pa pb = (((pa - 1) * pb) `mod` 3) + 1 -swy :: forall m . KnownNat m => Proxy m -> Mod m -> Mod m -> Mod m -> Mod m -> Integer-swy mn pr3 pt pxi pb = ch * y+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 mn ((pxi `powMod` 3) + pb)+    y = getVal <$> sqrtOf ((pxi `powMod` 3) + pb)  -- | Encodes a given byte string to a point on the BN curve. -- The implemenation uses the Shallue van de Woestijne encoding to BN curves as specifed@@ -64,23 +58,24 @@ -- This function evaluates an empty bytestring or one that contains \NUL to zero -- which according to Definiton 2 of the paper is sent to an arbitrary point on the curve ---swEncBN :: (MonadIO m, MonadRandom m) => ByteString -> m (Point Fq)-swEncBN bs = withQM $ \mn -> do+swEncBN :: MonadIO m => ByteString -> m (Maybe (Point Fq))+swEncBN bs = runMaybeT $ withQM $ \mn -> do   let t = M.fromBytes bs mn-  let sq3 = sqrtOfMinusThree mn+  sq3 <- hoistMaybe (sqrtOfMinusThree mn)   let w' = w mn sq3 t-  let x1' = x1 mn t w'-  if (t == 0) then-    pure $ (Point (Fq.new (getVal x1')) (Fq.new (getVal $ sqrtOf mn (1 + (b mn)))))+  x1' <- hoistMaybe (x1 mn t w')+  if (t == 0) then do+    onebmn <- hoistMaybe (sqrtOf (1 + (b mn)))+    pure $ (Point (Fq.new (getVal x1')) (Fq.new (getVal $ onebmn)))   else do     let x2' = x2 mn x1'     let x3' = x3 mn w'     let lst = [x1', x2', x3']-    r1 <- randomMod mn-    r2 <- randomMod mn-    r3 <- randomMod mn+    r1 <- liftIO (randomMod mn)+    r2 <- liftIO (randomMod mn)+    r3 <- liftIO (randomMod mn)     let al = alphaBeta mn r1 x1'     let bet = alphaBeta mn r2 x2'     let i' = i al bet-    let swy' = swy mn r3 t (genericIndex lst (i' -  1)) (b mn)-    pure (Point (Fq.new (getVal $ genericIndex lst (i' - 1))) (Fq.new swy'))+    swy' <- hoistMaybe (swy mn r3 t (genericIndex lst (i' -  1)) (b mn))+    pure $ (Point (Fq.new (getVal $ genericIndex lst (i' - 1))) (Fq.new swy'))
src/Pairing/Modular.hs view
@@ -5,22 +5,37 @@ import Math.NumberTheory.Moduli.Sqrt
 import Math.NumberTheory.UniqueFactorisation
 import Pairing.Params
+import Pairing.ByteRepr
 import Crypto.Random (MonadRandom)
 import Crypto.Number.Generate (generateMax)
 import qualified Data.ByteString as BS
+import Math.NumberTheory.Logarithms
 
+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 cont = case someNatVal _q of 
-  Nothing -> panic ("Somehow " <> show _q <> " was not a Nat")
-  Just (SomeNat mName) -> cont mName
+withQ = withMod _q
 
 -- Mod conversion and management
 withQM :: (forall n. KnownNat n => Proxy n -> m r) -> m r
-withQM cont = case someNatVal _q of 
-  Nothing -> panic ("Somehow " <> show _q <> " was not a Nat")
-  Just (SomeNat mName) -> cont mName
+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
 
@@ -44,27 +59,32 @@   a <- f (fromInteger @(Mod m) n)
   pure (getVal a)
 
-modPow :: Integral p => Integer -> p -> Integer
-modPow a b = withQ (modUnOp a (flip powMod b))
-
-modSqrt :: Integer -> [Integer]
-modSqrt a = withQ (modUnOpM a sqrtsMod)
+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 _q) then (length kp > 0) else False
+isSquare _ a = if (threeModFourCongruence (getMod a)) then (length kp > 0) else False
   where
     kp = sqrtsMod a
 
-isSquareIn3Mod4 :: Integer -> Integer
-isSquareIn3Mod4 a = if (threeModFourCongruence _q) then sq else 0
-  where
-    sq = withQ (modUnOp a f)
-    f m = m `powMod` p2
-    p2 = (_q + 1) `quot` 4
+-- |
+-- 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
@@ -78,8 +98,4 @@   pure (fromInteger @(Mod n) seed)
 
 fromBytes :: forall n. (KnownNat n) => ByteString -> Proxy n -> Mod n
-fromBytes bs mn = newMod (fromBytes' bs) mn
-  where
-    fromBytes' :: ByteString -> Integer
-    fromBytes' = BS.foldl' f 0
-    f a b = a `shiftL` 8 .|. fromIntegral b+fromBytes bs mn = newMod (fromBytesToInteger bs) mn
+ src/Pairing/Serialize.hs view
@@ -0,0 +1,105 @@+module Pairing.Serialize where
+
+import Protolude hiding (putByteString)
+import Pairing.Point
+import Data.ByteString.Builder
+import Data.ByteString as B
+import Data.Binary.Get
+import Data.Binary.Put (Put, putWord8, runPut, putByteString)
+import Control.Error
+import Pairing.ByteRepr
+import Pairing.CyclicGroup
+
+class ToCompressedForm a where
+  -- | The serialisation may fail if y cannot be obtained from x
+  serializeCompressed :: a -> Maybe ByteString
+
+class ToUncompressedForm a where
+  serializeUncompressed :: a -> Maybe ByteString
+
+-- | Point serialisation using https://tools.ietf.org/id/draft-jivsov-ecc-compact-05.html
+-- It is unclear if 02 is smallest y or not so the following is used in the first 2 bytes
+-- 01 - Point at infinity
+-- 02 - Compressed repr i.e. x only but use smallest y on decode
+-- 03 - Compressed repr i.e. x only but use largest y on decode
+-- 04 -- Uncompressed repr i.e. x & y
+
+header :: Word8 -> Put
+header n = putWord8 0 >> putWord8 n
+
+elementToUncompressedForm :: (ByteRepr a) => a -> Maybe LByteString
+elementToUncompressedForm a = do
+  repr <- mkRepr a
+  pure $ runPut $ do 
+    header 4 
+    putByteString repr
+
+toUncompressedForm :: (ByteRepr a) => Point a -> Maybe LByteString
+toUncompressedForm (Point x y) = do
+  rx <- mkRepr x
+  ry <- mkRepr y
+  pure $ runPut $ do
+    header 4 
+    putByteString rx
+    putByteString ry
+toUncompressedForm Infinity = pure $ runPut (header 1)
+
+toCompressedForm :: (ByteRepr a, FromX a, Eq a) => Point a -> Maybe LByteString
+toCompressedForm (Point x y) = do
+  ny <- yFromX x True
+  let yform = if ny == y then 3 else 2
+  rx <- mkRepr x
+  pure (runPut $ header yform >> putByteString rx)
+toCompressedForm Infinity = Just (toLazyByteString (word8 0 <> word8 1))
+
+pointFromByteString :: (Show a, Validate (Point a), ByteRepr a, FromX a) => a -> LByteString -> Either Text (Point a)
+pointFromByteString a = parseBS fromByteStringGet
+  where
+    fromByteStringGet = do
+      ctype <- getCompressionType
+      processCompressed a ctype
+
+processCompressed :: forall a . (ByteRepr a, FromX a) => a -> Word8 -> Get (Maybe (Point a))
+processCompressed one ct
+  | ct == 4 = do
+      xbs <- getByteString rlen
+      ybs <- getByteString rlen
+      pure (buildPoint one xbs ybs)
+  | ct == 2 = fromCompressed False
+  | ct == 3 = fromCompressed True
+  | ct == 1 = pure (Just Infinity)
+  | otherwise = pure Nothing
+  where
+    rlen = reprLength one
+    fromCompressed largestY = runMaybeT $ do
+      xbs <- lift $ getByteString rlen
+      x <- hoistMaybe $ fromRepr one xbs
+      y <- hoistMaybe $ yFromX x largestY
+      pure (Point x y)
+      
+buildPoint :: ByteRepr a => a -> ByteString -> ByteString -> Maybe (Point a)
+buildPoint one xbs ybs = do
+  x <- fromRepr one xbs
+  y <- fromRepr one ybs
+  pure (Point x y)
+
+getCompressionType :: Get Word8
+getCompressionType = getWord8 >> getWord8
+
+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
+        bs <- getByteString (reprLength ele)
+        pure (fromRepr ele bs)
+      else 
+        pure Nothing
+
+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/TestFields.hs view
@@ -97,6 +97,24 @@     u = Fq2.new 0 1     minusOne = Fq2.new (-1) 0 +unit_fq2pow :: Assertion+unit_fq2pow = do+  fq2 <- Fq2.random+  let pow5 = fq2sqr (fq2sqr fq2) * fq2+  pow5 @=?  fq2pow fq2 5+  let pow10 = ((fq2sqr (fq2sqr (fq2sqr fq2))) * fq2) * fq2+  pow10 @=?  fq2pow fq2 10+  where+    u = Fq2.new 0 1+    minusOne = Fq2.new (-1) 0++unit_fq2sqrt :: Assertion+unit_fq2sqrt = do+  fq2 <- Fq2.random+  let sq = fq2sqr fq2+  let (Just rt) = fq2sqrt sq+  sq @=? fq2sqr rt+ ------------------------------------------------------------------------------- -- Fq6 -------------------------------------------------------------------------------
tests/TestGroups.hs view
@@ -5,15 +5,18 @@ import Protolude  import Pairing.Fq as Fq+import Pairing.Fr as Fr import Pairing.Fq2+import Pairing.Fq12 import Pairing.Point-import Pairing.Group +import Pairing.Group as G import Pairing.Params-+import Pairing.Serialize+import Pairing.Pairing import Test.Tasty import Test.Tasty.QuickCheck import Test.Tasty.HUnit-import qualified Test.QuickCheck.Monadic as TQM (monadicIO, assert)+import qualified Test.QuickCheck.Monadic as TQM (monadicIO, assert, run) import Test.QuickCheck.Instances () import Data.ByteString as BS (null, dropWhile) import TestCommon@@ -41,6 +44,28 @@       $ 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 = fqPow y 2+  let (Just lysqrt) = fqSqrt True ysq+  let (Just sysqrt) = fqSqrt False ysq+  let egly = groupFromX True x+  let egsy = groupFromX False x+  isJust egly @=? True+  isJust egsy @=? True+  let Just lyg = egly+  let Just syg = egsy+  (Point x lysqrt) @=? lyg+  (Point x sysqrt) @=? syg+ ------------------------------------------------------------------------------- -- G1 -------------------------------------------------------------------------------@@ -63,9 +88,21 @@  prop_hashToG1 :: ByteString -> Property prop_hashToG1 bs = TQM.monadicIO $ do-  toCurve <- liftIO (hashToG1 bs) +  toCurveMay <- liftIO (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++prop_g1SerializeUncomp :: G1 -> Property+prop_g1SerializeUncomp g = TQM.monadicIO $ TQM.run $ serializeTest g serializeUncompressed G.fromByteStringG1++prop_g1SerializeComp :: G1 -> Property+prop_g1SerializeComp g = TQM.monadicIO $ TQM.run $ serializeTest g serializeCompressed G.fromByteStringG1+ ------------------------------------------------------------------------------- -- G2 -------------------------------------------------------------------------------@@ -85,8 +122,33 @@ unit_order_g2_valid   = gMul g2 _r @=? Infinity +g2FromXTest :: G2 -> Assertion+g2FromXTest Infinity = pure ()+g2FromXTest pt@(Point x y) = do+  let ysq = fq2pow y 2+  let (Just ny) = fq2YforX x True+  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++prop_g2SerializeUncomp :: G2 -> Property+prop_g2SerializeUncomp g = TQM.monadicIO $ TQM.run $ serializeTest g serializeUncompressed G.fromByteStringG2++prop_g2SerializeComp :: G2 -> Property+prop_g2SerializeComp g = TQM.monadicIO $ TQM.run $ serializeTest g serializeUncompressed G.fromByteStringG2+ ------------------------------------------------------------------------------- -- GT -------------------------------------------------------------------------------  -- The group laws for GT are implied by the field tests for Fq12.++gtSerializeTest :: G1 -> G2 -> Assertion+gtSerializeTest g1 g2 = do+  let gt = reducedPairing g1 g2+  serializeTest gt serializeUncompressed fromByteStringGT++prop_gtSerializeUncomp :: G1 -> G2 -> Property+prop_gtSerializeUncomp g1 g2 = TQM.monadicIO $ TQM.run $ gtSerializeTest g1 g2