-- SPDX-FileCopyrightText: 2021 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Support for BLS12-381 elliptic curve.
--
-- Some general hints on the implementation can be found in this python
-- re-implementation used by Tezos for testing:
-- <https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf#80b4b1585c1e6fa82f2cfaf75001c490613f22c3>.
-- And it uses this library inside: <https://github.com/ethereum/py_ecc/tree/master/py_ecc/optimized_bls12_381>.
module Tezos.Crypto.BLS12381
  ( Bls12381Fr
  , Bls12381G1
  , Bls12381G2
  , CurveObject (..)
  , unsafeFromMichelsonBytes
  , MultiplyPoint (..)
  , DeserializationError (..)
  , checkPairing

    -- * Playground
  , unsafeReadFromHex
  , generateFrom
  , g1One
  , g2One
  ) where

import Prelude hiding (negate, one)
import qualified Prelude

import Control.Exception (assert)
import Control.Lens (each, toListOf)
import Control.Monad.Random (MonadRandom, evalRand, getRandom, mkStdGen)
import Data.Bits (bit, complement, setBit, testBit, (.&.))
import qualified Data.ByteString as BS
import qualified Data.Curve as C
import qualified Data.Curve.Weierstrass as CW
import qualified Data.Curve.Weierstrass.BLS12381 as CW.BLS
import qualified Data.Field.Galois as GF
import qualified Data.Pairing.BLS12381 as BLS
import Fmt (Buildable(..), pretty)
import Named (arg, type (:!), (!))
import Text.Hex (decodeHex, encodeHex)
import Text.PrettyPrint.Leijen.Text ((<+>), int, integer)
import Util.Instances ()
import Util.Named ()
import Util.Num

import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable, buildRenderDoc)

-- | Methods common for all BLS12-381 primitives.
class CurveObject a where
  -- | Representation of @0@, aka additive identity.
  zero :: a

  -- | Negate a value.
  negate :: a -> a

  -- | Add up two values.
  add :: a -> a -> a

  -- | Generate a random value.
  generate :: MonadRandom m => m a

  -- | Read a value from Michelson's bytes form.
  --
  -- Michelson tends to represent all BLS12-381 types in bytes form,
  -- some special types also allow other forms.
  fromMichelsonBytes :: ByteString -> Either DeserializationError a

  -- | Produce Michelson's bytes representation.
  toMichelsonBytes :: a -> ByteString

-- | Generate a random value from given seed.
generateFrom :: (CurveObject a) => Int -> a
generateFrom :: Int -> a
generateFrom = Rand StdGen a -> StdGen -> a
forall g a. Rand g a -> g -> a
evalRand Rand StdGen a
forall a (m :: * -> *). (CurveObject a, MonadRandom m) => m a
generate (StdGen -> a) -> (Int -> StdGen) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StdGen
mkStdGen

-- | Read a value from Michelson's bytes form assuming that it is correct.
unsafeFromMichelsonBytes :: (CurveObject a, HasCallStack) => ByteString -> a
unsafeFromMichelsonBytes :: ByteString -> a
unsafeFromMichelsonBytes = (DeserializationError -> a)
-> (a -> a) -> Either DeserializationError a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> a
forall a. HasCallStack => Text -> a
error (Text -> a)
-> (DeserializationError -> Text) -> DeserializationError -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeserializationError -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) a -> a
forall a. a -> a
id (Either DeserializationError a -> a)
-> (ByteString -> Either DeserializationError a) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either DeserializationError a
forall a.
CurveObject a =>
ByteString -> Either DeserializationError a
fromMichelsonBytes

-- | Reads an object from hex string.
--
-- To be used only in playground and tests.
unsafeReadFromHex :: (CurveObject a, HasCallStack) => String -> a
unsafeReadFromHex :: String -> a
unsafeReadFromHex String
hex =
  let bs :: ByteString
bs = Text -> Maybe ByteString
decodeHex (String -> Text
forall a. ToText a => a -> Text
toText String
hex) Maybe ByteString -> ByteString -> ByteString
forall a. Maybe a -> a -> a
?: Text -> ByteString
forall a. HasCallStack => Text -> a
error Text
"bad hex"
  in ByteString -> a
forall a. (CurveObject a, HasCallStack) => ByteString -> a
unsafeFromMichelsonBytes ByteString
bs

-- | Multiplication operations on BLS12-381 objects.
class MultiplyPoint scalar point where
  -- | Multiply point value by scalar value.
  multiply :: scalar -> point -> point

-- | G1 point on the curve.
newtype Bls12381G1 = Bls12381G1 { Bls12381G1 -> G1'
unBls12381G1 :: BLS.G1' }
  deriving stock (Int -> Bls12381G1 -> ShowS
[Bls12381G1] -> ShowS
Bls12381G1 -> String
(Int -> Bls12381G1 -> ShowS)
-> (Bls12381G1 -> String)
-> ([Bls12381G1] -> ShowS)
-> Show Bls12381G1
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bls12381G1] -> ShowS
$cshowList :: [Bls12381G1] -> ShowS
show :: Bls12381G1 -> String
$cshow :: Bls12381G1 -> String
showsPrec :: Int -> Bls12381G1 -> ShowS
$cshowsPrec :: Int -> Bls12381G1 -> ShowS
Show, Bls12381G1 -> Bls12381G1 -> Bool
(Bls12381G1 -> Bls12381G1 -> Bool)
-> (Bls12381G1 -> Bls12381G1 -> Bool) -> Eq Bls12381G1
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bls12381G1 -> Bls12381G1 -> Bool
$c/= :: Bls12381G1 -> Bls12381G1 -> Bool
== :: Bls12381G1 -> Bls12381G1 -> Bool
$c== :: Bls12381G1 -> Bls12381G1 -> Bool
Eq)
  deriving newtype (Bls12381G1 -> ()
(Bls12381G1 -> ()) -> NFData Bls12381G1
forall a. (a -> ()) -> NFData a
rnf :: Bls12381G1 -> ()
$crnf :: Bls12381G1 -> ()
NFData)

instance CurveObject Bls12381G1 where
  zero :: Bls12381G1
zero = G1' -> Bls12381G1
Bls12381G1 G1'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r
C.id
  negate :: Bls12381G1 -> Bls12381G1
negate (Bls12381G1 G1'
v) = G1' -> Bls12381G1
Bls12381G1 (G1' -> G1'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r -> Point f c e q r
C.inv G1'
v)
  add :: Bls12381G1 -> Bls12381G1 -> Bls12381G1
add (Bls12381G1 G1'
a) (Bls12381G1 G1'
b) = G1' -> Bls12381G1
Bls12381G1 (G1' -> G1' -> G1'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r -> Point f c e q r -> Point f c e q r
C.add G1'
a G1'
b)
  generate :: m Bls12381G1
generate = G1' -> Bls12381G1
Bls12381G1 (G1' -> Bls12381G1) -> m G1' -> m Bls12381G1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m G1'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r (m :: * -> *).
(Curve f c e q r, MonadRandom m) =>
m (Point f c e q r)
C.rnd
  fromMichelsonBytes :: ByteString -> Either DeserializationError Bls12381G1
fromMichelsonBytes =
    let bsToCoord :: ByteString -> Prime Q
bsToCoord = Natural -> Prime Q
forall (p :: Nat). KnownNat p => Natural -> Prime p
toPrime (Natural -> Prime Q)
-> (ByteString -> Natural) -> ByteString -> Prime Q
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Natural
fromBigEndian
    in (G1' -> Bls12381G1)
-> Either DeserializationError G1'
-> Either DeserializationError Bls12381G1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap G1' -> Bls12381G1
Bls12381G1 (Either DeserializationError G1'
 -> Either DeserializationError Bls12381G1)
-> (ByteString -> Either DeserializationError G1')
-> ByteString
-> Either DeserializationError Bls12381G1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> (ByteString -> Prime Q)
-> ByteString
-> Either DeserializationError G1'
forall fq.
(WJCurve BLS12381 fq Fr, WACurve BLS12381 fq Fr) =>
Int
-> (ByteString -> fq)
-> ByteString
-> Either DeserializationError (WAPoint BLS12381 fq Fr)
parseJA2WAPoint Int
g1CoordLen ByteString -> Prime Q
bsToCoord
  toMichelsonBytes :: Bls12381G1 -> ByteString
toMichelsonBytes =
    let coordToBs :: Prime Q -> ByteString
coordToBs = Int -> Natural -> ByteString
toBigEndian Int
g1CoordLen (Natural -> ByteString)
-> (Prime Q -> Natural) -> Prime Q -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prime Q -> Natural
forall (p :: Nat). KnownNat p => Prime p -> Natural
fromPrime
    in Int -> (Prime Q -> ByteString) -> G1' -> ByteString
forall fq.
(WJCurve BLS12381 fq Fr, WACurve BLS12381 fq Fr) =>
Int -> (fq -> ByteString) -> WAPoint BLS12381 fq Fr -> ByteString
convertWA2JAPoint Int
g1CoordLen Prime Q -> ByteString
coordToBs (G1' -> ByteString)
-> (Bls12381G1 -> G1') -> Bls12381G1 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bls12381G1 -> G1'
unBls12381G1

instance MultiplyPoint Integer Bls12381G1 where
  multiply :: Integer -> Bls12381G1 -> Bls12381G1
multiply Integer
s (Bls12381G1 G1'
p) = G1' -> Bls12381G1
Bls12381G1 (G1' -> Integer -> G1'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r n.
(Curve f c e q r, Integral n) =>
Point f c e q r -> n -> Point f c e q r
C.mul' G1'
p Integer
s)

-- | G2 point on the curve.
newtype Bls12381G2 = Bls12381G2 { Bls12381G2 -> G2'
unBls12381G2 :: BLS.G2' }
  deriving stock (Int -> Bls12381G2 -> ShowS
[Bls12381G2] -> ShowS
Bls12381G2 -> String
(Int -> Bls12381G2 -> ShowS)
-> (Bls12381G2 -> String)
-> ([Bls12381G2] -> ShowS)
-> Show Bls12381G2
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bls12381G2] -> ShowS
$cshowList :: [Bls12381G2] -> ShowS
show :: Bls12381G2 -> String
$cshow :: Bls12381G2 -> String
showsPrec :: Int -> Bls12381G2 -> ShowS
$cshowsPrec :: Int -> Bls12381G2 -> ShowS
Show, Bls12381G2 -> Bls12381G2 -> Bool
(Bls12381G2 -> Bls12381G2 -> Bool)
-> (Bls12381G2 -> Bls12381G2 -> Bool) -> Eq Bls12381G2
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bls12381G2 -> Bls12381G2 -> Bool
$c/= :: Bls12381G2 -> Bls12381G2 -> Bool
== :: Bls12381G2 -> Bls12381G2 -> Bool
$c== :: Bls12381G2 -> Bls12381G2 -> Bool
Eq)
  deriving newtype (Bls12381G2 -> ()
(Bls12381G2 -> ()) -> NFData Bls12381G2
forall a. (a -> ()) -> NFData a
rnf :: Bls12381G2 -> ()
$crnf :: Bls12381G2 -> ()
NFData)

instance CurveObject Bls12381G2 where
  zero :: Bls12381G2
zero = G2' -> Bls12381G2
Bls12381G2 G2'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r
C.id
  negate :: Bls12381G2 -> Bls12381G2
negate (Bls12381G2 G2'
v) = G2' -> Bls12381G2
Bls12381G2 (G2' -> G2'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r -> Point f c e q r
C.inv G2'
v)
  add :: Bls12381G2 -> Bls12381G2 -> Bls12381G2
add (Bls12381G2 G2'
a) (Bls12381G2 G2'
b) = G2' -> Bls12381G2
Bls12381G2 (G2' -> G2' -> G2'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r -> Point f c e q r -> Point f c e q r
C.add G2'
a G2'
b)
  generate :: m Bls12381G2
generate = G2' -> Bls12381G2
Bls12381G2 (G2' -> Bls12381G2) -> m G2' -> m Bls12381G2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m G2'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r (m :: * -> *).
(Curve f c e q r, MonadRandom m) =>
m (Point f c e q r)
C.rnd
  fromMichelsonBytes :: ByteString -> Either DeserializationError Bls12381G2
fromMichelsonBytes =
    let fromBsPair :: ByteString -> [Natural]
fromBsPair = (ByteString -> Natural) -> [ByteString] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ByteString -> Natural
fromBigEndian ([ByteString] -> [Natural])
-> (ByteString -> [ByteString]) -> ByteString -> [Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [ByteString]) (ByteString, ByteString) ByteString
-> (ByteString, ByteString) -> [ByteString]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [ByteString]) (ByteString, ByteString) ByteString
forall s t a b. Each s t a b => Traversal s t a b
each ((ByteString, ByteString) -> [ByteString])
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Int
g2CoordLen Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
        bsToCoord :: ByteString -> Extension U (Prime Q)
bsToCoord = [Prime Q] -> Extension U (Prime Q)
forall k p. IrreducibleMonic p k => [k] -> Extension p k
GF.toE ([Prime Q] -> Extension U (Prime Q))
-> (ByteString -> [Prime Q]) -> ByteString -> Extension U (Prime Q)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Prime Q] -> [Prime Q]
forall a. [a] -> [a]
reverse ([Prime Q] -> [Prime Q])
-> (ByteString -> [Prime Q]) -> ByteString -> [Prime Q]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Prime Q) -> [Natural] -> [Prime Q]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Natural -> Prime Q
forall (p :: Nat). KnownNat p => Natural -> Prime p
toPrime ([Natural] -> [Prime Q])
-> (ByteString -> [Natural]) -> ByteString -> [Prime Q]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Natural]
fromBsPair
    in (G2' -> Bls12381G2)
-> Either DeserializationError G2'
-> Either DeserializationError Bls12381G2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap G2' -> Bls12381G2
Bls12381G2 (Either DeserializationError G2'
 -> Either DeserializationError Bls12381G2)
-> (ByteString -> Either DeserializationError G2')
-> ByteString
-> Either DeserializationError Bls12381G2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> (ByteString -> Extension U (Prime Q))
-> ByteString
-> Either DeserializationError G2'
forall fq.
(WJCurve BLS12381 fq Fr, WACurve BLS12381 fq Fr) =>
Int
-> (ByteString -> fq)
-> ByteString
-> Either DeserializationError (WAPoint BLS12381 fq Fr)
parseJA2WAPoint Int
g2CoordLen ByteString -> Extension U (Prime Q)
bsToCoord
  toMichelsonBytes :: Bls12381G2 -> ByteString
toMichelsonBytes =
    let toBsPair :: [Natural] -> ByteString
toBsPair = (Element [Natural] -> ByteString) -> [Natural] -> ByteString
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap (Int -> Natural -> ByteString
toBigEndian (Int -> Natural -> ByteString) -> Int -> Natural -> ByteString
forall a b. (a -> b) -> a -> b
$ Int
g2CoordLen Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
        coordToBs :: Extension U (Prime Q) -> ByteString
coordToBs = [Natural] -> ByteString
toBsPair ([Natural] -> ByteString)
-> (Extension U (Prime Q) -> [Natural])
-> Extension U (Prime Q)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Prime Q -> Natural) -> [Prime Q] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Prime Q -> Natural
forall (p :: Nat). KnownNat p => Prime p -> Natural
fromPrime ([Prime Q] -> [Natural])
-> (Extension U (Prime Q) -> [Prime Q])
-> Extension U (Prime Q)
-> [Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Prime Q] -> [Prime Q]
forall a. [a] -> [a]
reverse ([Prime Q] -> [Prime Q])
-> (Extension U (Prime Q) -> [Prime Q])
-> Extension U (Prime Q)
-> [Prime Q]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension U (Prime Q) -> [Prime Q]
forall k l p.
(ExtensionField k, GaloisField l, IrreducibleMonic p l,
 k ~ Extension p l) =>
k -> [l]
GF.fromE
    in Int -> (Extension U (Prime Q) -> ByteString) -> G2' -> ByteString
forall fq.
(WJCurve BLS12381 fq Fr, WACurve BLS12381 fq Fr) =>
Int -> (fq -> ByteString) -> WAPoint BLS12381 fq Fr -> ByteString
convertWA2JAPoint Int
g1CoordLen Extension U (Prime Q) -> ByteString
coordToBs (G2' -> ByteString)
-> (Bls12381G2 -> G2') -> Bls12381G2 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bls12381G2 -> G2'
unBls12381G2

instance MultiplyPoint Integer Bls12381G2 where
  multiply :: Integer -> Bls12381G2 -> Bls12381G2
multiply Integer
s (Bls12381G2 G2'
p) = G2' -> Bls12381G2
Bls12381G2 (G2' -> Integer -> G2'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r n.
(Curve f c e q r, Integral n) =>
Point f c e q r -> n -> Point f c e q r
C.mul' G2'
p Integer
s)

-- | An element of an algebraic number field (scalar), used for multiplying
-- 'Bls12381G1' and 'Bls12381G2'.
newtype Bls12381Fr = Bls12381Fr { Bls12381Fr -> Fr
unBls12381Fr :: BLS.Fr }
  deriving stock (Int -> Bls12381Fr -> ShowS
[Bls12381Fr] -> ShowS
Bls12381Fr -> String
(Int -> Bls12381Fr -> ShowS)
-> (Bls12381Fr -> String)
-> ([Bls12381Fr] -> ShowS)
-> Show Bls12381Fr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bls12381Fr] -> ShowS
$cshowList :: [Bls12381Fr] -> ShowS
show :: Bls12381Fr -> String
$cshow :: Bls12381Fr -> String
showsPrec :: Int -> Bls12381Fr -> ShowS
$cshowsPrec :: Int -> Bls12381Fr -> ShowS
Show, Bls12381Fr -> Bls12381Fr -> Bool
(Bls12381Fr -> Bls12381Fr -> Bool)
-> (Bls12381Fr -> Bls12381Fr -> Bool) -> Eq Bls12381Fr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bls12381Fr -> Bls12381Fr -> Bool
$c/= :: Bls12381Fr -> Bls12381Fr -> Bool
== :: Bls12381Fr -> Bls12381Fr -> Bool
$c== :: Bls12381Fr -> Bls12381Fr -> Bool
Eq, Eq Bls12381Fr
Eq Bls12381Fr
-> (Bls12381Fr -> Bls12381Fr -> Ordering)
-> (Bls12381Fr -> Bls12381Fr -> Bool)
-> (Bls12381Fr -> Bls12381Fr -> Bool)
-> (Bls12381Fr -> Bls12381Fr -> Bool)
-> (Bls12381Fr -> Bls12381Fr -> Bool)
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> Ord Bls12381Fr
Bls12381Fr -> Bls12381Fr -> Bool
Bls12381Fr -> Bls12381Fr -> Ordering
Bls12381Fr -> Bls12381Fr -> Bls12381Fr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$cmin :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
max :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$cmax :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
>= :: Bls12381Fr -> Bls12381Fr -> Bool
$c>= :: Bls12381Fr -> Bls12381Fr -> Bool
> :: Bls12381Fr -> Bls12381Fr -> Bool
$c> :: Bls12381Fr -> Bls12381Fr -> Bool
<= :: Bls12381Fr -> Bls12381Fr -> Bool
$c<= :: Bls12381Fr -> Bls12381Fr -> Bool
< :: Bls12381Fr -> Bls12381Fr -> Bool
$c< :: Bls12381Fr -> Bls12381Fr -> Bool
compare :: Bls12381Fr -> Bls12381Fr -> Ordering
$ccompare :: Bls12381Fr -> Bls12381Fr -> Ordering
$cp1Ord :: Eq Bls12381Fr
Ord)
  deriving newtype (Integer -> Bls12381Fr
Bls12381Fr -> Bls12381Fr
Bls12381Fr -> Bls12381Fr -> Bls12381Fr
(Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr)
-> (Integer -> Bls12381Fr)
-> Num Bls12381Fr
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Bls12381Fr
$cfromInteger :: Integer -> Bls12381Fr
signum :: Bls12381Fr -> Bls12381Fr
$csignum :: Bls12381Fr -> Bls12381Fr
abs :: Bls12381Fr -> Bls12381Fr
$cabs :: Bls12381Fr -> Bls12381Fr
negate :: Bls12381Fr -> Bls12381Fr
$cnegate :: Bls12381Fr -> Bls12381Fr
* :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$c* :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
- :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$c- :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
+ :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$c+ :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
Num, Int -> Bls12381Fr
Bls12381Fr -> Int
Bls12381Fr -> [Bls12381Fr]
Bls12381Fr -> Bls12381Fr
Bls12381Fr -> Bls12381Fr -> [Bls12381Fr]
Bls12381Fr -> Bls12381Fr -> Bls12381Fr -> [Bls12381Fr]
(Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr)
-> (Int -> Bls12381Fr)
-> (Bls12381Fr -> Int)
-> (Bls12381Fr -> [Bls12381Fr])
-> (Bls12381Fr -> Bls12381Fr -> [Bls12381Fr])
-> (Bls12381Fr -> Bls12381Fr -> [Bls12381Fr])
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr -> [Bls12381Fr])
-> Enum Bls12381Fr
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr -> [Bls12381Fr]
$cenumFromThenTo :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr -> [Bls12381Fr]
enumFromTo :: Bls12381Fr -> Bls12381Fr -> [Bls12381Fr]
$cenumFromTo :: Bls12381Fr -> Bls12381Fr -> [Bls12381Fr]
enumFromThen :: Bls12381Fr -> Bls12381Fr -> [Bls12381Fr]
$cenumFromThen :: Bls12381Fr -> Bls12381Fr -> [Bls12381Fr]
enumFrom :: Bls12381Fr -> [Bls12381Fr]
$cenumFrom :: Bls12381Fr -> [Bls12381Fr]
fromEnum :: Bls12381Fr -> Int
$cfromEnum :: Bls12381Fr -> Int
toEnum :: Int -> Bls12381Fr
$ctoEnum :: Int -> Bls12381Fr
pred :: Bls12381Fr -> Bls12381Fr
$cpred :: Bls12381Fr -> Bls12381Fr
succ :: Bls12381Fr -> Bls12381Fr
$csucc :: Bls12381Fr -> Bls12381Fr
Enum, Bls12381Fr
Bls12381Fr -> Bls12381Fr -> Bounded Bls12381Fr
forall a. a -> a -> Bounded a
maxBound :: Bls12381Fr
$cmaxBound :: Bls12381Fr
minBound :: Bls12381Fr
$cminBound :: Bls12381Fr
Bounded, Num Bls12381Fr
Ord Bls12381Fr
Num Bls12381Fr
-> Ord Bls12381Fr -> (Bls12381Fr -> Rational) -> Real Bls12381Fr
Bls12381Fr -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Bls12381Fr -> Rational
$ctoRational :: Bls12381Fr -> Rational
$cp2Real :: Ord Bls12381Fr
$cp1Real :: Num Bls12381Fr
Real, Enum Bls12381Fr
Real Bls12381Fr
Real Bls12381Fr
-> Enum Bls12381Fr
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr -> (Bls12381Fr, Bls12381Fr))
-> (Bls12381Fr -> Bls12381Fr -> (Bls12381Fr, Bls12381Fr))
-> (Bls12381Fr -> Integer)
-> Integral Bls12381Fr
Bls12381Fr -> Integer
Bls12381Fr -> Bls12381Fr -> (Bls12381Fr, Bls12381Fr)
Bls12381Fr -> Bls12381Fr -> Bls12381Fr
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: Bls12381Fr -> Integer
$ctoInteger :: Bls12381Fr -> Integer
divMod :: Bls12381Fr -> Bls12381Fr -> (Bls12381Fr, Bls12381Fr)
$cdivMod :: Bls12381Fr -> Bls12381Fr -> (Bls12381Fr, Bls12381Fr)
quotRem :: Bls12381Fr -> Bls12381Fr -> (Bls12381Fr, Bls12381Fr)
$cquotRem :: Bls12381Fr -> Bls12381Fr -> (Bls12381Fr, Bls12381Fr)
mod :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$cmod :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
div :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$cdiv :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
rem :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$crem :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
quot :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$cquot :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$cp2Integral :: Enum Bls12381Fr
$cp1Integral :: Real Bls12381Fr
Integral, Num Bls12381Fr
Num Bls12381Fr
-> (Bls12381Fr -> Bls12381Fr -> Bls12381Fr)
-> (Bls12381Fr -> Bls12381Fr)
-> (Rational -> Bls12381Fr)
-> Fractional Bls12381Fr
Rational -> Bls12381Fr
Bls12381Fr -> Bls12381Fr
Bls12381Fr -> Bls12381Fr -> Bls12381Fr
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> Bls12381Fr
$cfromRational :: Rational -> Bls12381Fr
recip :: Bls12381Fr -> Bls12381Fr
$crecip :: Bls12381Fr -> Bls12381Fr
/ :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$c/ :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
$cp1Fractional :: Num Bls12381Fr
Fractional, Bls12381Fr -> ()
(Bls12381Fr -> ()) -> NFData Bls12381Fr
forall a. (a -> ()) -> NFData a
rnf :: Bls12381Fr -> ()
$crnf :: Bls12381Fr -> ()
NFData)

instance CurveObject Bls12381Fr where
  zero :: Bls12381Fr
zero = Fr -> Bls12381Fr
Bls12381Fr Fr
0
  negate :: Bls12381Fr -> Bls12381Fr
negate = Bls12381Fr -> Bls12381Fr
forall a. Num a => a -> a
Prelude.negate
  add :: Bls12381Fr -> Bls12381Fr -> Bls12381Fr
add = Bls12381Fr -> Bls12381Fr -> Bls12381Fr
forall a. Num a => a -> a -> a
(+)
  generate :: m Bls12381Fr
generate = Fr -> Bls12381Fr
Bls12381Fr (Fr -> Bls12381Fr) -> m Fr -> m Bls12381Fr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Fr
forall (m :: * -> *) a. (MonadRandom m, Random a) => m a
getRandom
  fromMichelsonBytes :: ByteString -> Either DeserializationError Bls12381Fr
fromMichelsonBytes ByteString
bs =
    if ByteString -> Int
forall t. Container t => t -> Int
length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
frLen
    then DeserializationError -> Either DeserializationError Bls12381Fr
forall a b. a -> Either a b
Left (DeserializationError -> Either DeserializationError Bls12381Fr)
-> DeserializationError -> Either DeserializationError Bls12381Fr
forall a b. (a -> b) -> a -> b
$ ("limit" :! Int) -> ("given" :! Int) -> DeserializationError
TooLargeLength (("limit" :! Int) -> ("given" :! Int) -> DeserializationError)
-> Param ("limit" :! Int)
-> ("given" :! Int)
-> DeserializationError
forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! IsLabel "limit" (Int -> Param ("limit" :! Int))
Int -> Param ("limit" :! Int)
#limit Int
frLen (("given" :! Int) -> DeserializationError)
-> Param ("given" :! Int) -> DeserializationError
forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! IsLabel "given" (Int -> Param ("given" :! Int))
Int -> Param ("given" :! Int)
#given (ByteString -> Int
forall t. Container t => t -> Int
length ByteString
bs)
    else
      let num :: Natural
num = ByteString -> Natural
fromLittleEndian ByteString
bs
      in Natural -> Either Text Bls12381Fr
forall a b. (Integral a, Integral b) => a -> Either Text b
fromIntegralChecked Natural
num
           Either Text Bls12381Fr
-> (Either Text Bls12381Fr
    -> Either DeserializationError Bls12381Fr)
-> Either DeserializationError Bls12381Fr
forall a b. a -> (a -> b) -> b
& (Text -> DeserializationError)
-> Either Text Bls12381Fr -> Either DeserializationError Bls12381Fr
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\Text
_ -> Integer -> DeserializationError
ValueOutsideOfField (Integer -> DeserializationError)
-> Integer -> DeserializationError
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
num)
  toMichelsonBytes :: Bls12381Fr -> ByteString
toMichelsonBytes = Int -> Natural -> ByteString
toLittleEndian Int
frLen (Natural -> ByteString)
-> (Bls12381Fr -> Natural) -> Bls12381Fr -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fr -> Natural
forall (p :: Nat). KnownNat p => Prime p -> Natural
fromPrime (Fr -> Natural) -> (Bls12381Fr -> Fr) -> Bls12381Fr -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bls12381Fr -> Fr
unBls12381Fr

instance MultiplyPoint Bls12381Fr Bls12381G1 where
  multiply :: Bls12381Fr -> Bls12381G1 -> Bls12381G1
multiply (Bls12381Fr Fr
s) (Bls12381G1 G1'
p) = G1' -> Bls12381G1
Bls12381G1 (G1' -> Fr -> G1'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r -> r -> Point f c e q r
C.mul G1'
p Fr
s)

instance MultiplyPoint Bls12381Fr Bls12381G2 where
  multiply :: Bls12381Fr -> Bls12381G2 -> Bls12381G2
multiply (Bls12381Fr Fr
s) (Bls12381G2 G2'
p) = G2' -> Bls12381G2
Bls12381G2 (G2' -> Fr -> G2'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r -> r -> Point f c e q r
C.mul G2'
p Fr
s)

-- | Checks that product of pairings of points in the list is equal to 1 in
-- Fq12 field.
checkPairing :: [(Bls12381G1, Bls12381G2)] -> Bool
checkPairing :: [(Bls12381G1, Bls12381G2)] -> Bool
checkPairing [(Bls12381G1, Bls12381G2)]
pairs =
  -- Some hints for implementation of this function:
  -- https://gitlab.com/metastatedev/tezos/-/commit/bb2cda17d48a52ce854e027f0222a0463e0e66f0#af97cb649204420968454a94e7bfaa6a6e27195a_1285_1330
  -- https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf#80b4b1585c1e6fa82f2cfaf75001c490613f22c3_0_172

  -- Monoid instance on GT' has the desired multiplicative semantics
  (Element [(Bls12381G1, Bls12381G2)] -> GT')
-> [(Bls12381G1, Bls12381G2)] -> GT'
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap (Bls12381G1, Bls12381G2) -> GT'
Element [(Bls12381G1, Bls12381G2)] -> GT'
pairing [(Bls12381G1, Bls12381G2)]
pairs GT' -> GT' -> Bool
forall a. Eq a => a -> a -> Bool
== GT'
forall a. Monoid a => a
mempty
  where
    pairing :: (Bls12381G1, Bls12381G2) -> BLS.GT'
    pairing :: (Bls12381G1, Bls12381G2) -> GT'
pairing (Bls12381G1 G1'
g1, Bls12381G2 G2'
g2) =
      Integer -> GT BLS12381 -> GT BLS12381
forall e (q :: Nat) (r :: Nat) u v w.
ECPairing e q r u v w =>
Integer -> GT e -> GT e
BLS.finalExponentiationBLS12 Integer
BLS.parameterHex
        ([Int8] -> G1 BLS12381 -> G2 BLS12381 -> GT BLS12381
forall e (q :: Nat) (r :: Nat) u v w.
ECPairing e q r u v w =>
[Int8] -> G1 e -> G2 e -> GT e
BLS.millerAlgorithmBLS12 [Int8]
BLS.parameterBin G1'
G1 BLS12381
g1 G2'
G2 BLS12381
g2)

----------------------------------------------------------------------------
-- Serialization helpers
----------------------------------------------------------------------------

-- | All kinds of errors that can occur when reading a Michelson value.
data DeserializationError
  = CompressedFormIsNotSupported
  | UnexpectedLength ("expected" :! Int) ("given" :! Int)
  | TooLargeLength ("limit" :! Int) ("given" :! Int)
  | ValueOutsideOfField Integer
  | PointNotOnCurve ByteString
  deriving stock (Int -> DeserializationError -> ShowS
[DeserializationError] -> ShowS
DeserializationError -> String
(Int -> DeserializationError -> ShowS)
-> (DeserializationError -> String)
-> ([DeserializationError] -> ShowS)
-> Show DeserializationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeserializationError] -> ShowS
$cshowList :: [DeserializationError] -> ShowS
show :: DeserializationError -> String
$cshow :: DeserializationError -> String
showsPrec :: Int -> DeserializationError -> ShowS
$cshowsPrec :: Int -> DeserializationError -> ShowS
Show, DeserializationError -> DeserializationError -> Bool
(DeserializationError -> DeserializationError -> Bool)
-> (DeserializationError -> DeserializationError -> Bool)
-> Eq DeserializationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeserializationError -> DeserializationError -> Bool
$c/= :: DeserializationError -> DeserializationError -> Bool
== :: DeserializationError -> DeserializationError -> Bool
$c== :: DeserializationError -> DeserializationError -> Bool
Eq, (forall x. DeserializationError -> Rep DeserializationError x)
-> (forall x. Rep DeserializationError x -> DeserializationError)
-> Generic DeserializationError
forall x. Rep DeserializationError x -> DeserializationError
forall x. DeserializationError -> Rep DeserializationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DeserializationError x -> DeserializationError
$cfrom :: forall x. DeserializationError -> Rep DeserializationError x
Generic)
  deriving anyclass (DeserializationError -> ()
(DeserializationError -> ()) -> NFData DeserializationError
forall a. (a -> ()) -> NFData a
rnf :: DeserializationError -> ()
$crnf :: DeserializationError -> ()
NFData)

instance Buildable DeserializationError where
  build :: DeserializationError -> Builder
build = DeserializationError -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDoc

instance RenderDoc DeserializationError where
  renderDoc :: RenderContext -> DeserializationError -> Doc
renderDoc RenderContext
_ = \case
    DeserializationError
CompressedFormIsNotSupported ->
      Doc
"Compressed form of BLS12-381 point is not supported by Tezos"
    UnexpectedLength (Name "expected" -> ("expected" :! Int) -> Int
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "expected" (Name "expected")
Name "expected"
#expected -> Int
expected) (Name "given" -> ("given" :! Int) -> Int
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "given" (Name "given")
Name "given"
#given -> Int
given) ->
      Doc
"Unexpected length of BLS12-381 primitive: \
      \expected" Doc -> Doc -> Doc
<+> (Int -> Doc
int Int
expected) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
", but given" Doc -> Doc -> Doc
<+> (Int -> Doc
int Int
given)
    TooLargeLength (Name "limit" -> ("limit" :! Int) -> Int
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "limit" (Name "limit")
Name "limit"
#limit -> Int
limit) (Name "given" -> ("given" :! Int) -> Int
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "given" (Name "given")
Name "given"
#given -> Int
given) ->
      Doc
"Too large length of BLS12-381 primitive: \
      \limit is" Doc -> Doc -> Doc
<+> (Int -> Doc
int Int
limit) Doc -> Doc -> Doc
<+> Doc
", but given" Doc -> Doc -> Doc
<+> (Int -> Doc
int Int
given)
    ValueOutsideOfField Integer
v ->
      Doc
"Value is too large for the given field of values:" Doc -> Doc -> Doc
<+> (Integer -> Doc
integer Integer
v)
    PointNotOnCurve ByteString
bs ->
      Doc
"Point is not on curve: 0x" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> (Text -> Doc
forall a. Buildable a => a -> Doc
renderAnyBuildable (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeHex ByteString
bs)

{- Note on serialization:

In BLS12-381, "381" stands for the number of bits necessary to represent a
coordinate of a point on a curve, i.e. we have to use 48 bytes, getting 3 extra
bits. In the BLS12-381 library used by Tezos, those bits are exploited to carry
some meta information.

More info can be found here:
<https://github.com/zkcrypto/pairing/blob/307aa1f29dccaed09abe774d2027cad57fc5d0b4/src/bls12_381/README.md#serialization>.

So Fr is just a scalar (but a pretty big one), represented in little-endian
as said in the Michelson docs.

G1 and G2 represent a point on curve and have the following form:

      X coordinate         Y coordinate
 |!___________________|____________________|
   \  (big-endian)         (big-endian)
    \
     `- bits with meta info

Generally, various coordinate systems may be used to represent a point on curve,
and the library picked by Tezos uses Jacobian coordinates, probably assuming
that the third @Z@ coordinate is always @1@.
Note that we use 'Data.Pairing.BLS12381' which by default picks Weierstrass
coordinates (it has two, not three coordinates, and an "infinity point" which
is kept as a special case), but it also provides methods for converting between
different coordinate systems.

Coordinates take a different amount of space in G1 and G2:
* In G1 both X and Y are from a so-called "Fr" field, where numbers take
  48 bytes (without the leading 3 bits).
* In G2 both coordinates are from "Fr2" field which is a two-dimensional field
  over "Fr", i.e. X and Y themselves contain two 48-byte coordinates each.

Note that this is correct for the "uncompressed" form, and there is a different
"compressed" form that, fortunately, seems to be not supported by Michelson.
They initially planned to have @COMPRESS@ and @UNCOMPRESS@ instructions, perhaps
for manual conversions, but those instructions didn't appear in Edonet
eventually.

-}

-- | A helper datatype for representing points in raw bytes form.
data RawPoint
  = Infinity
    -- ^ Point at infinity.
  | RawPoint ByteString
    -- ^ Bytes representing the payload.

-- | Given the Michelson representation of a point, interpret flags
-- and return the bare payload.
--
-- This assumes that a proper number of bytes is provided.
parsePointFlags
  :: HasCallStack
  => ByteString -> Either DeserializationError RawPoint
parsePointFlags :: ByteString -> Either DeserializationError RawPoint
parsePointFlags ByteString
bsFull =
  case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bsFull of
    Maybe (Word8, ByteString)
Nothing -> Text -> Either DeserializationError RawPoint
forall a. HasCallStack => Text -> a
error Text
"Empty byte sequence"
    Just (Word8
b, ByteString
bs)
      | Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
compressionBit ->
          DeserializationError -> Either DeserializationError RawPoint
forall a b. a -> Either a b
Left DeserializationError
CompressedFormIsNotSupported
      | Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
infinityBit ->
          RawPoint -> Either DeserializationError RawPoint
forall (m :: * -> *) a. Monad m => a -> m a
return RawPoint
Infinity
      | Bool
otherwise -> do
          let
            b' :: Word8
b' = Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8 -> Word8
forall a. Bits a => a -> a
complement
              ([Word8] -> Element [Word8]
forall t. (Container t, Num (Element t)) => t -> Element t
sum ([Word8] -> Element [Word8]) -> [Word8] -> Element [Word8]
forall a b. (a -> b) -> a -> b
$ (Int -> Word8) -> [Int] -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Int -> Word8
forall a. Bits a => Int -> a
bit [Int
compressionBit, Int
infinityBit, Int
flag3Bit])
          RawPoint -> Either DeserializationError RawPoint
forall (m :: * -> *) a. Monad m => a -> m a
return (RawPoint -> Either DeserializationError RawPoint)
-> RawPoint -> Either DeserializationError RawPoint
forall a b. (a -> b) -> a -> b
$ ByteString -> RawPoint
RawPoint (Word8 -> ByteString -> ByteString
BS.cons Word8
b' ByteString
bs)

-- | Fill a point in raw bytes form with the necessary flags.
fillPointFlags :: HasCallStack => Int -> RawPoint -> ByteString
fillPointFlags :: Int -> RawPoint -> ByteString
fillPointFlags Int
0 = Text -> RawPoint -> ByteString
forall a. HasCallStack => Text -> a
error Text
"Coordinates are unexpectedly empty"
fillPointFlags Int
len = \case
  RawPoint
Infinity -> Word8 -> ByteString -> ByteString
BS.cons (Word8
0 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
infinityBit) (Int -> Word8 -> ByteString
BS.replicate (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Word8
0)
  RawPoint ByteString
bs -> ByteString
bs

-- | Get a bytestring containing coordinates of a point and split it,
-- checking that each coordinate occupies the given number of bytes.
splitUncompressedPoint
  :: Int -> ByteString -> Either DeserializationError (ByteString, ByteString)
splitUncompressedPoint :: Int
-> ByteString
-> Either DeserializationError (ByteString, ByteString)
splitUncompressedPoint Int
coordLen ByteString
bs
  | ByteString -> Int
forall t. Container t => t -> Int
length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
coordLen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 =
      DeserializationError
-> Either DeserializationError (ByteString, ByteString)
forall a b. a -> Either a b
Left (DeserializationError
 -> Either DeserializationError (ByteString, ByteString))
-> DeserializationError
-> Either DeserializationError (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ("expected" :! Int) -> ("given" :! Int) -> DeserializationError
UnexpectedLength (("expected" :! Int) -> ("given" :! Int) -> DeserializationError)
-> Param ("expected" :! Int)
-> ("given" :! Int)
-> DeserializationError
forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! IsLabel "expected" (Int -> Param ("expected" :! Int))
Int -> Param ("expected" :! Int)
#expected (Int
coordLen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) (("given" :! Int) -> DeserializationError)
-> Param ("given" :! Int) -> DeserializationError
forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! IsLabel "given" (Int -> Param ("given" :! Int))
Int -> Param ("given" :! Int)
#given (ByteString -> Int
forall t. Container t => t -> Int
length ByteString
bs)
  | Bool
otherwise =
      (ByteString, ByteString)
-> Either DeserializationError (ByteString, ByteString)
forall a b. b -> Either a b
Right ((ByteString, ByteString)
 -> Either DeserializationError (ByteString, ByteString))
-> (ByteString, ByteString)
-> Either DeserializationError (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
coordLen ByteString
bs

-- | Parse a point in Weierstrass form and Affine coordinates,
-- assuming that in the provided bytestring the point is given in Jacobian
-- coordinates (the library used by Tezos operates in Jacobian coordinates).
parseJA2WAPoint
  :: ( CW.BLS.WJCurve CW.BLS.BLS12381 fq BLS.Fr
     , CW.BLS.WACurve CW.BLS.BLS12381 fq BLS.Fr
     )
  => Int
  -> (ByteString -> fq)
  -> ByteString
  -> Either DeserializationError (CW.BLS.WAPoint CW.BLS.BLS12381 fq BLS.Fr)
parseJA2WAPoint :: Int
-> (ByteString -> fq)
-> ByteString
-> Either DeserializationError (WAPoint BLS12381 fq Fr)
parseJA2WAPoint Int
coordLen ByteString -> fq
toCoord ByteString
full = do
  (ByteString
xRawWithFlags, ByteString
yRaw) <- Int
-> ByteString
-> Either DeserializationError (ByteString, ByteString)
splitUncompressedPoint Int
coordLen ByteString
full
  RawPoint
xRawPoint <- HasCallStack => ByteString -> Either DeserializationError RawPoint
ByteString -> Either DeserializationError RawPoint
parsePointFlags ByteString
xRawWithFlags
  case RawPoint
xRawPoint of
    RawPoint
Infinity -> WAPoint BLS12381 fq Fr
-> Either DeserializationError (WAPoint BLS12381 fq Fr)
forall (m :: * -> *) a. Monad m => a -> m a
return WAPoint BLS12381 fq Fr
forall k (e :: k) q r. Point 'Weierstrass 'Affine e q r
CW.O
    RawPoint ByteString
xRaw ->
      let point :: WAPoint BLS12381 fq Fr
point = Point 'Weierstrass 'Jacobian BLS12381 fq Fr
-> WAPoint BLS12381 fq Fr
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
(Curve f c e q r, Curve f 'Affine e q r) =>
Point f c e q r -> Point f 'Affine e q r
C.toA (Point 'Weierstrass 'Jacobian BLS12381 fq Fr
 -> WAPoint BLS12381 fq Fr)
-> Point 'Weierstrass 'Jacobian BLS12381 fq Fr
-> WAPoint BLS12381 fq Fr
forall a b. (a -> b) -> a -> b
$ fq -> fq -> fq -> Point 'Weierstrass 'Jacobian BLS12381 fq Fr
forall k (e :: k) q r.
q -> q -> q -> Point 'Weierstrass 'Jacobian e q r
CW.J (ByteString -> fq
toCoord ByteString
xRaw) (ByteString -> fq
toCoord ByteString
yRaw) fq
1
      in if WAPoint BLS12381 fq Fr -> Bool
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
Curve f c e q r =>
Point f c e q r -> Bool
C.def WAPoint BLS12381 fq Fr
point
         then WAPoint BLS12381 fq Fr
-> Either DeserializationError (WAPoint BLS12381 fq Fr)
forall (m :: * -> *) a. Monad m => a -> m a
return WAPoint BLS12381 fq Fr
point
         else DeserializationError
-> Either DeserializationError (WAPoint BLS12381 fq Fr)
forall a b. a -> Either a b
Left (DeserializationError
 -> Either DeserializationError (WAPoint BLS12381 fq Fr))
-> DeserializationError
-> Either DeserializationError (WAPoint BLS12381 fq Fr)
forall a b. (a -> b) -> a -> b
$ ByteString -> DeserializationError
PointNotOnCurve ByteString
full

-- | Turn a Weierstrass Affine point into Jacobian coordinates and represent
-- those as bytes.
convertWA2JAPoint
  :: ( CW.BLS.WJCurve CW.BLS.BLS12381 fq BLS.Fr
     , CW.BLS.WACurve CW.BLS.BLS12381 fq BLS.Fr
     )
  => Int
  -> (fq -> ByteString)
  -> CW.BLS.WAPoint CW.BLS.BLS12381 fq BLS.Fr
  -> ByteString
convertWA2JAPoint :: Int -> (fq -> ByteString) -> WAPoint BLS12381 fq Fr -> ByteString
convertWA2JAPoint Int
coordLen fq -> ByteString
toRawCoord WAPoint BLS12381 fq Fr
point =
  let
    rawPoint :: RawPoint
rawPoint = case WAPoint BLS12381 fq Fr
point of
      WAPoint BLS12381 fq Fr
CW.O -> RawPoint
Infinity
      p :: WAPoint BLS12381 fq Fr
p@CW.A{} -> ByteString -> RawPoint
RawPoint (ByteString -> RawPoint) -> ByteString -> RawPoint
forall a b. (a -> b) -> a -> b
$
        let CW.J x y z = WAPoint BLS12381 fq Fr
-> Point 'Weierstrass 'Jacobian BLS12381 fq Fr
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
(Curve f c e q r, Curve f 'Affine e q r) =>
Point f 'Affine e q r -> Point f c e q r
C.fromA WAPoint BLS12381 fq Fr
p
           -- Conversion from Affine coordinates used to produce an already
           -- normalized value.
           -- In case this turns out to be incorrect, probably @x / z@ and @y / z@
           -- are just what we want.
        in Bool -> ByteString -> ByteString
forall a. HasCallStack => Bool -> a -> a
assert (fq
z fq -> fq -> Bool
forall a. Eq a => a -> a -> Bool
== fq
1) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
            fq -> ByteString
toRawCoord fq
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> fq -> ByteString
toRawCoord fq
y
  in HasCallStack => Int -> RawPoint -> ByteString
Int -> RawPoint -> ByteString
fillPointFlags (Int
coordLen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) RawPoint
rawPoint

-- | Interpret a byte sequence as a number in big-endian.
fromBigEndian :: ByteString -> Natural
fromBigEndian :: ByteString -> Natural
fromBigEndian ByteString
bs =
  (Natural -> Element [Word8] -> Natural)
-> Natural -> [Word8] -> Natural
forall t b. Container t => (b -> Element t -> b) -> b -> t -> b
foldl' (\Natural
acc Element [Word8]
byte -> Natural
acc Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
0x100 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Word8 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Natural Word8
Element [Word8]
byte) Natural
0 ([Word8] -> Natural) -> [Word8] -> Natural
forall a b. (a -> b) -> a -> b
$
  ByteString -> [Word8]
BS.unpack ByteString
bs

-- | Interpret a byte sequence as a number in little-endian.
fromLittleEndian :: ByteString -> Natural
fromLittleEndian :: ByteString -> Natural
fromLittleEndian ByteString
bs =
  [Natural] -> Natural
forall t. (Container t, Num (Element t)) => t -> Element t
sum ([Natural] -> Natural)
-> ([Word8] -> [Natural]) -> [Word8] -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Natural -> Natural)
-> [Natural] -> [Natural] -> [Natural]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(*) ((Natural -> Natural) -> Natural -> [Natural]
forall a. (a -> a) -> a -> [a]
iterate (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
0x100) Natural
1) ([Natural] -> [Natural])
-> ([Word8] -> [Natural]) -> [Word8] -> [Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Natural) -> [Word8] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Integral Word8, Num Natural) => Word8 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Natural) ([Word8] -> Natural) -> [Word8] -> Natural
forall a b. (a -> b) -> a -> b
$
  ByteString -> [Word8]
BS.unpack ByteString
bs

-- | Represent a number in a big-endian byte sequence, padding the output
-- to the expected length.
--
-- We assert that the length is sufficient for representing the given number.
toBigEndian :: Int -> Natural -> ByteString
toBigEndian :: Int -> Natural -> ByteString
toBigEndian Int
len Natural
num =
  [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$
  let
    (Natural
remainder, [Word8]
bytes) = (Natural -> Int -> (Natural, Word8))
-> Natural -> [Int] -> (Natural, [Word8])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumR
      (\Natural
x Int
_ -> (Natural -> Word8) -> (Natural, Natural) -> (Natural, Word8)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Integral Natural, Num Word8) => Natural -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Word8) ((Natural, Natural) -> (Natural, Word8))
-> (Natural, Natural) -> (Natural, Word8)
forall a b. (a -> b) -> a -> b
$ Natural
x Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
`divMod` Natural
0x100)
      Natural
num [Int
1 .. Int
len]
  in Bool -> [Word8] -> [Word8]
forall a. HasCallStack => Bool -> a -> a
assert (Natural
remainder Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0) [Word8]
bytes

-- | Represent a number in a little-endian byte sequence, padding the output
-- to the expected length.
--
-- We assert that the length is sufficient for representing the given number.
toLittleEndian :: Int -> Natural -> ByteString
toLittleEndian :: Int -> Natural -> ByteString
toLittleEndian Int
len Natural
num =
  [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$
  let
    (Natural
remainder, [Word8]
bytes) = (Natural -> Int -> (Natural, Word8))
-> Natural -> [Int] -> (Natural, [Word8])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL
      (\Natural
x Int
_ -> (Natural -> Word8) -> (Natural, Natural) -> (Natural, Word8)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Integral Natural, Num Word8) => Natural -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Word8) ((Natural, Natural) -> (Natural, Word8))
-> (Natural, Natural) -> (Natural, Word8)
forall a b. (a -> b) -> a -> b
$ Natural
x Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
`divMod` Natural
0x100)
      Natural
num [Int
1 .. Int
len]
  in Bool -> [Word8] -> [Word8]
forall a. HasCallStack => Bool -> a -> a
assert (Natural
remainder Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0) [Word8]
bytes

-- | Turn a prime field element into a natural.
fromPrime :: KnownNat p => GF.Prime p -> Natural
fromPrime :: Prime p -> Natural
fromPrime Prime p
p =
  -- This should be safe, since 'Prime's exist in modular arithmetics,
  -- so its conversion to an integer should produce non-negative elements.
  -- In fact, 'GF.Prime' is a newtype wrapper over 'Natural', but
  -- its constructor is not exported :/
  Bool -> Natural -> Natural
forall a. HasCallStack => Bool -> a -> a
assert (Prime p
p Prime p -> Prime p -> Bool
forall a. Ord a => a -> a -> Bool
>= Prime p
0) (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$
    Prime p -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Prime p
p

-- | The inverse to 'fromPrime'.
toPrime :: KnownNat p => Natural -> GF.Prime p
toPrime :: Natural -> Prime p
toPrime = Natural -> Prime p
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- Primitives' lengths
----------------------------------------------------------------------------

-- | Length of a single coordinate of a point in raw bytes form.
g1CoordLen, g2CoordLen :: Int
g1CoordLen :: Int
g1CoordLen = Int
48
g2CoordLen :: Int
g2CoordLen = Int
96  -- each coordinate is an element of two-dimensional field Fr2

-- | Length of 'Fr' in raw bytes form.
frLen :: Int
frLen :: Int
frLen = Int
32

-- Meta bits
----------------------------------------------------------------------------

-- | This bit designates whether the point is represented in compressed form
-- (only X coordinate), or uncompressed form (both X and Y coordinates).
compressionBit :: Int
compressionBit :: Int
compressionBit = Int
7

-- | This bit designates whether the given point is at infinity.
--
-- If so, all other bytes should be zeros.
infinityBit :: Int
infinityBit :: Int
infinityBit = Int
6

-- | This bit is set iff "this point is in compressed form /and/ it is not the
-- point at infinity /and/ its y-coordinate is the lexicographically largest of
-- the two associated with the encoded x-coordinate".
--
-- Fortunatelly, this flag seems to be not relevant for us at the moment.
flag3Bit :: Int
flag3Bit :: Int
flag3Bit = Int
5

----------------------------------------------------------------------------
-- Other constants
----------------------------------------------------------------------------

-- | @1@ represented in G1 - as the libraries used by Tezos see it.
--
-- Taken from here: <https://github.com/ethereum/py_ecc/blob/3f644b4c07c8270b8fbe989eb799766aca66face/py_ecc/optimized_bls12_381/optimized_curve.py#L34>.
g1One :: Bls12381G1
g1One :: Bls12381G1
g1One = G1' -> Bls12381G1
Bls12381G1 (G1' -> Bls12381G1) -> G1' -> Bls12381G1
forall a b. (a -> b) -> a -> b
$ Point 'Weierstrass 'Jacobian BLS12381 (Prime Q) Fr -> G1'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
(Curve f c e q r, Curve f 'Affine e q r) =>
Point f c e q r -> Point f 'Affine e q r
CW.toA (Point 'Weierstrass 'Jacobian BLS12381 (Prime Q) Fr -> G1')
-> Point 'Weierstrass 'Jacobian BLS12381 (Prime Q) Fr -> G1'
forall a b. (a -> b) -> a -> b
$ Prime Q
-> Prime Q
-> Prime Q
-> Point 'Weierstrass 'Jacobian BLS12381 (Prime Q) Fr
forall k (e :: k) q r.
q -> q -> q -> Point 'Weierstrass 'Jacobian e q r
CW.J
  Prime Q
3685416753713387016781088315183077757961620795782546409894578378688607592378376318836054947676345821548104185464507
  Prime Q
1339506544944476473020471379941921221584933875938349620426543736416511423956333506472724655353366534992391756441569
  Prime Q
1

-- | @1@ represented in G2.
g2One :: Bls12381G2
g2One :: Bls12381G2
g2One = G2' -> Bls12381G2
Bls12381G2 (G2' -> Bls12381G2) -> G2' -> Bls12381G2
forall a b. (a -> b) -> a -> b
$ Point 'Weierstrass 'Jacobian BLS12381 (Extension U (Prime Q)) Fr
-> G2'
forall k (f :: Form) (c :: Coordinates) (e :: k) q r.
(Curve f c e q r, Curve f 'Affine e q r) =>
Point f c e q r -> Point f 'Affine e q r
CW.toA (Point 'Weierstrass 'Jacobian BLS12381 (Extension U (Prime Q)) Fr
 -> G2')
-> Point 'Weierstrass 'Jacobian BLS12381 (Extension U (Prime Q)) Fr
-> G2'
forall a b. (a -> b) -> a -> b
$ Extension U (Prime Q)
-> Extension U (Prime Q)
-> Extension U (Prime Q)
-> Point 'Weierstrass 'Jacobian BLS12381 (Extension U (Prime Q)) Fr
forall k (e :: k) q r.
q -> q -> q -> Point 'Weierstrass 'Jacobian e q r
CW.J
  ([Prime Q] -> Extension U (Prime Q)
forall k p. IrreducibleMonic p k => [k] -> Extension p k
GF.toE
    [ Prime Q
352701069587466618187139116011060144890029952792775240219908644239793785735715026873347600343865175952761926303160
    , Prime Q
3059144344244213709971259814753781636986470325476647558659373206291635324768958432433509563104347017837885763365758
    ])
  ([Prime Q] -> Extension U (Prime Q)
forall k p. IrreducibleMonic p k => [k] -> Extension p k
GF.toE
    [ Prime Q
1985150602287291935568054521177171638300868978215655730859378665066344726373823718423869104263333984641494340347905
    , Prime Q
927553665492332455747201965776037880757740193453592970025027978793976877002675564980949289727957565575433344219582
    ])
  ([Prime Q] -> Extension U (Prime Q)
forall k p. IrreducibleMonic p k => [k] -> Extension p k
GF.toE [Prime Q
1, Prime Q
0])