-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | 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 Morley.Tezos.Crypto.BLS12381
  ( Bls12381Fr
  , Bls12381G1
  , Bls12381G2
  , CurveObject (..)
  , MultiplyPoint (..)
  , DeserializationError (..)
  , checkPairing

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

import Prelude hiding (negate, one)
import Prelude qualified
import Unsafe qualified (fromIntegral)

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 Data.ByteString qualified as BS
import Data.Curve qualified as C
import Data.Curve.Weierstrass qualified as CW
import Data.Curve.Weierstrass.BLS12381 qualified as CW.BLS
import Data.Field.Galois qualified as GF
import Data.Pairing.BLS12381 qualified as BLS
import Fmt (Buildable(..))
import Morley.Util.Instances ()
import Morley.Util.Named
import Text.Hex (decodeHex, encodeHex)
import Text.PrettyPrint.Leijen.Text (int, integer, (<+>))

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

-- | 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 :: forall a. CurveObject a => 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

-- | Reads an object from hex string.
--
-- To be used only in playground and tests.
unsafeReadFromHex :: (CurveObject a, HasCallStack) => String -> a
unsafeReadFromHex :: forall a. (CurveObject a, HasCallStack) => 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 Either DeserializationError a -> a
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either DeserializationError a -> a)
-> Either DeserializationError a -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either DeserializationError a
forall a.
CurveObject a =>
ByteString -> Either DeserializationError a
fromMichelsonBytes 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 :: forall (m :: * -> *). MonadRandom m => 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 -> Fq
bsToCoord = Natural -> Fq
forall (p :: Nat). KnownNat p => Natural -> Prime p
toPrime (Natural -> Fq) -> (ByteString -> Natural) -> ByteString -> Fq
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 -> Fq)
-> 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 -> Fq
bsToCoord
  toMichelsonBytes :: Bls12381G1 -> ByteString
toMichelsonBytes =
    let coordToBs :: Fq -> ByteString
coordToBs = Int -> Natural -> ByteString
toBigEndian Int
g1CoordLen (Natural -> ByteString) -> (Fq -> Natural) -> Fq -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fq -> Natural
forall (p :: Nat). KnownNat p => Prime p -> Natural
fromPrime
    in Int -> (Fq -> ByteString) -> G1' -> ByteString
forall fq.
(WJCurve BLS12381 fq Fr, WACurve BLS12381 fq Fr) =>
Int -> (fq -> ByteString) -> WAPoint BLS12381 fq Fr -> ByteString
convertWA2JAPoint Int
g1CoordLen Fq -> 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 :: forall (m :: * -> *). MonadRandom m => 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 Fq
bsToCoord = [Fq] -> Extension U Fq
forall k p. IrreducibleMonic p k => [k] -> Extension p k
GF.toE ([Fq] -> Extension U Fq)
-> (ByteString -> [Fq]) -> ByteString -> Extension U Fq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Fq] -> [Fq]
forall a. [a] -> [a]
reverse ([Fq] -> [Fq]) -> (ByteString -> [Fq]) -> ByteString -> [Fq]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Fq) -> [Natural] -> [Fq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Natural -> Fq
forall (p :: Nat). KnownNat p => Natural -> Prime p
toPrime ([Natural] -> [Fq])
-> (ByteString -> [Natural]) -> ByteString -> [Fq]
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 Fq)
-> 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 Fq
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 Fq -> ByteString
coordToBs = [Natural] -> ByteString
toBsPair ([Natural] -> ByteString)
-> (Extension U Fq -> [Natural]) -> Extension U Fq -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fq -> Natural) -> [Fq] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Fq -> Natural
forall (p :: Nat). KnownNat p => Prime p -> Natural
fromPrime ([Fq] -> [Natural])
-> (Extension U Fq -> [Fq]) -> Extension U Fq -> [Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Fq] -> [Fq]
forall a. [a] -> [a]
reverse ([Fq] -> [Fq])
-> (Extension U Fq -> [Fq]) -> Extension U Fq -> [Fq]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension U Fq -> [Fq]
forall k l p.
(ExtensionField k, GaloisField l, IrreducibleMonic p l,
 k ~ Extension p l) =>
k -> [l]
GF.fromE
    in Int -> (Extension U Fq -> 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 Fq -> 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
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
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
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
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 :: forall (m :: * -> *). MonadRandom m => 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 ArithException Bls12381Fr
forall a b.
(Integral a, Integral b) =>
a -> Either ArithException b
fromIntegralNoOverflow Natural
num
           Either ArithException Bls12381Fr
-> (Either ArithException Bls12381Fr
    -> Either DeserializationError Bls12381Fr)
-> Either DeserializationError Bls12381Fr
forall a b. a -> (a -> b) -> b
& (ArithException -> DeserializationError)
-> Either ArithException Bls12381Fr
-> Either DeserializationError Bls12381Fr
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\ArithException
_ -> 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 :: HasCallStack => 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 :: HasCallStack => 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 :: forall fq.
(WJCurve BLS12381 fq Fr, WACurve BLS12381 fq Fr) =>
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 :: forall fq.
(WJCurve BLS12381 fq Fr, WACurve BLS12381 fq Fr) =>
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
R:PointkWeierstrassAffineeqr (*) 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 fq
x fq
y fq
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
+ forall a b. (Integral a, Integral b, CheckIntSubType a 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 (forall a b. (Integral a, Integral b, CheckIntSubType a 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 :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
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 (forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.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 :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
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 (forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.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 :: forall p. KnownNat p => GF.Prime p -> Natural
fromPrime :: forall (p :: Nat). KnownNat p => 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
$
    forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.fromIntegral @(GF.Prime p) @Natural Prime p
p

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

-- 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 'Bls12381Fr' 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 Fq 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 Fq Fr -> G1')
-> Point 'Weierstrass 'Jacobian BLS12381 Fq Fr -> G1'
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
  Fq
3685416753713387016781088315183077757961620795782546409894578378688607592378376318836054947676345821548104185464507
  Fq
1339506544944476473020471379941921221584933875938349620426543736416511423956333506472724655353366534992391756441569
  Fq
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 Fq) 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 Fq) Fr -> G2')
-> Point 'Weierstrass 'Jacobian BLS12381 (Extension U Fq) Fr -> G2'
forall a b. (a -> b) -> a -> b
$ Extension U Fq
-> Extension U Fq
-> Extension U Fq
-> Point 'Weierstrass 'Jacobian BLS12381 (Extension U Fq) Fr
forall k (e :: k) q r.
q -> q -> q -> Point 'Weierstrass 'Jacobian e q r
CW.J
  ([Fq] -> Extension U Fq
forall k p. IrreducibleMonic p k => [k] -> Extension p k
GF.toE
    [ Fq
352701069587466618187139116011060144890029952792775240219908644239793785735715026873347600343865175952761926303160
    , Fq
3059144344244213709971259814753781636986470325476647558659373206291635324768958432433509563104347017837885763365758
    ])
  ([Fq] -> Extension U Fq
forall k p. IrreducibleMonic p k => [k] -> Extension p k
GF.toE
    [ Fq
1985150602287291935568054521177171638300868978215655730859378665066344726373823718423869104263333984641494340347905
    , Fq
927553665492332455747201965776037880757740193453592970025027978793976877002675564980949289727957565575433344219582
    ])
  ([Fq] -> Extension U Fq
forall k p. IrreducibleMonic p k => [k] -> Extension p k
GF.toE [Fq
1, Fq
0])