{-# LANGUAGE TemplateHaskell #-}
module Hydra.Contract.KZGTrustedSetup (
KZGSetupError (..),
warmup,
g1Points,
g2Points,
g1BuiltinPoints,
g2BuiltinPoints,
maxAccumulatorSize,
maxFanoutBatchSize,
defaultItems,
canonicalG2Points,
) where
import Hydra.Prelude hiding (filter, foldMap, isJust, map, (<$>), (==))
import Cardano.Crypto.EllipticCurve.BLS12_381.Internal (Point1, Point2, blsCompress, blsUncompress)
import Cardano.Crypto.Hash (SHA256)
import Cardano.Crypto.Hash.Class (HashAlgorithm (digest))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (Parser, parseEither, withObject, (.:))
import Data.ByteString.Base16 qualified as Base16
import Data.FileEmbed (embedFile, makeRelativeToProject)
import Data.Text qualified as T
import PlutusTx.Builtins (BuiltinBLS12_381_G1_Element, BuiltinBLS12_381_G2_Element, bls12_381_G1_uncompress, bls12_381_G2_uncompress, toBuiltin)
data KZGSetupError
=
IntegrityCheckFailed
{ KZGSetupError -> Text
expectedHash :: Text
, KZGSetupError -> Text
actualHash :: Text
}
|
JsonDecodeFailed
|
JsonParseFailed {KZGSetupError -> Text
parseError :: Text}
|
InvalidG1Point {KZGSetupError -> Text
hexPoint :: Text}
|
InvalidG2Point {hexPoint :: Text}
deriving stock (Int -> KZGSetupError -> ShowS
[KZGSetupError] -> ShowS
KZGSetupError -> String
(Int -> KZGSetupError -> ShowS)
-> (KZGSetupError -> String)
-> ([KZGSetupError] -> ShowS)
-> Show KZGSetupError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KZGSetupError -> ShowS
showsPrec :: Int -> KZGSetupError -> ShowS
$cshow :: KZGSetupError -> String
show :: KZGSetupError -> String
$cshowList :: [KZGSetupError] -> ShowS
showList :: [KZGSetupError] -> ShowS
Show, KZGSetupError -> KZGSetupError -> Bool
(KZGSetupError -> KZGSetupError -> Bool)
-> (KZGSetupError -> KZGSetupError -> Bool) -> Eq KZGSetupError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KZGSetupError -> KZGSetupError -> Bool
== :: KZGSetupError -> KZGSetupError -> Bool
$c/= :: KZGSetupError -> KZGSetupError -> Bool
/= :: KZGSetupError -> KZGSetupError -> Bool
Eq, (forall x. KZGSetupError -> Rep KZGSetupError x)
-> (forall x. Rep KZGSetupError x -> KZGSetupError)
-> Generic KZGSetupError
forall x. Rep KZGSetupError x -> KZGSetupError
forall x. KZGSetupError -> Rep KZGSetupError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. KZGSetupError -> Rep KZGSetupError x
from :: forall x. KZGSetupError -> Rep KZGSetupError x
$cto :: forall x. Rep KZGSetupError x -> KZGSetupError
to :: forall x. Rep KZGSetupError x -> KZGSetupError
Generic)
maxAccumulatorSize :: Int
maxAccumulatorSize :: Int
maxAccumulatorSize = Int
4095
maxFanoutBatchSize :: Int
maxFanoutBatchSize :: Int
maxFanoutBatchSize = Int
64
trustedSetupExpectedSHA256 :: Text
trustedSetupExpectedSHA256 :: Text
trustedSetupExpectedSHA256 = Text
"9a8dcad9eaba191842f57d23d14674cbdea4b3cf7912fcc477821264dfe0c042"
embeddedSetup :: Either KZGSetupError ([Text], [Text])
embeddedSetup :: Either KZGSetupError ([Text], [Text])
embeddedSetup = do
let rawBytes :: ByteString
rawBytes = $(makeRelativeToProject "trusted_setup.json" >>= embedFile)
actualHex :: Text
actualHex = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy SHA256 -> ByteString -> ByteString
forall h (proxy :: * -> *).
HashAlgorithm h =>
proxy h -> ByteString -> ByteString
forall (proxy :: * -> *). proxy SHA256 -> ByteString -> ByteString
digest (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SHA256) ByteString
rawBytes
Bool -> Either KZGSetupError () -> Either KZGSetupError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
actualHex Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
trustedSetupExpectedSHA256) (Either KZGSetupError () -> Either KZGSetupError ())
-> Either KZGSetupError () -> Either KZGSetupError ()
forall a b. (a -> b) -> a -> b
$
KZGSetupError -> Either KZGSetupError ()
forall a b. a -> Either a b
Left IntegrityCheckFailed{expectedHash :: Text
expectedHash = Text
trustedSetupExpectedSHA256, actualHash :: Text
actualHash = Text
actualHex}
Value
v <- Either KZGSetupError Value
-> (Value -> Either KZGSetupError Value)
-> Maybe Value
-> Either KZGSetupError Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (KZGSetupError -> Either KZGSetupError Value
forall a b. a -> Either a b
Left KZGSetupError
JsonDecodeFailed) Value -> Either KZGSetupError Value
forall a b. b -> Either a b
Right (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict ByteString
rawBytes)
(String -> KZGSetupError)
-> Either String ([Text], [Text])
-> Either KZGSetupError ([Text], [Text])
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> KZGSetupError
JsonParseFailed (Text -> KZGSetupError)
-> (String -> Text) -> String -> KZGSetupError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText) (Either String ([Text], [Text])
-> Either KZGSetupError ([Text], [Text]))
-> Either String ([Text], [Text])
-> Either KZGSetupError ([Text], [Text])
forall a b. (a -> b) -> a -> b
$
(Value -> Parser ([Text], [Text]))
-> Value -> Either String ([Text], [Text])
forall a b. (a -> Parser b) -> a -> Either String b
parseEither (String
-> (Object -> Parser ([Text], [Text]))
-> Value
-> Parser ([Text], [Text])
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TrustedSetup" Object -> Parser ([Text], [Text])
parse) Value
v
where
parse :: Aeson.Object -> Parser ([Text], [Text])
parse :: Object -> Parser ([Text], [Text])
parse Object
obj = ([Text] -> [Text] -> ([Text], [Text]))
-> Parser [Text] -> Parser ([Text] -> ([Text], [Text]))
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,) (Object
obj Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"g1_monomial") Parser ([Text] -> ([Text], [Text]))
-> Parser [Text] -> Parser ([Text], [Text])
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"g2_monomial"
decodeHexPoint :: Text -> Either String ByteString
decodeHexPoint :: Text -> Either String ByteString
decodeHexPoint Text
t = ByteString -> Either String ByteString
Base16.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Text -> Text -> Maybe Text
T.stripPrefix Text
"0x" Text
t)
warmup :: Either KZGSetupError Int
warmup :: Either KZGSetupError Int
warmup = do
[Point1]
g1 <- Either KZGSetupError [Point1]
g1Points
[Point2]
g2 <- Either KZGSetupError [Point2]
g2Points
let !numG1 :: Int
numG1 = [Point1] -> Int
forall a. [a] -> Int
countForced [Point1]
g1
!numG2 :: Int
numG2 = [Point2] -> Int
forall a. [a] -> Int
countForced [Point2]
g2
Int
numG2 Int -> Either KZGSetupError Int -> Either KZGSetupError Int
forall a b. a -> b -> b
`seq` Int -> Either KZGSetupError Int
forall a b. b -> Either a b
Right Int
numG1
where
countForced :: [a] -> Int
countForced :: forall a. [a] -> Int
countForced = (Int -> a -> Int) -> Int -> [a] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
n a
x -> a
x a -> Int -> Int
forall a b. a -> b -> b
`seq` Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0
g1Points :: Either KZGSetupError [Point1]
g1Points :: Either KZGSetupError [Point1]
g1Points = (Text -> Either KZGSetupError Point1)
-> [Text] -> Either KZGSetupError [Point1]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Either KZGSetupError Point1
parseG1 ([Text] -> Either KZGSetupError [Point1])
-> (([Text], [Text]) -> [Text])
-> ([Text], [Text])
-> Either KZGSetupError [Point1]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text], [Text]) -> [Text]
forall a b. (a, b) -> a
fst (([Text], [Text]) -> Either KZGSetupError [Point1])
-> Either KZGSetupError ([Text], [Text])
-> Either KZGSetupError [Point1]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either KZGSetupError ([Text], [Text])
embeddedSetup
where
parseG1 :: Text -> Either KZGSetupError Point1
parseG1 :: Text -> Either KZGSetupError Point1
parseG1 Text
hex = do
ByteString
bs <- (String -> KZGSetupError)
-> Either String ByteString -> Either KZGSetupError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (KZGSetupError -> String -> KZGSetupError
forall a b. a -> b -> a
const (Text -> KZGSetupError
InvalidG1Point Text
hex)) (Text -> Either String ByteString
decodeHexPoint Text
hex)
(BLSTError -> KZGSetupError)
-> Either BLSTError Point1 -> Either KZGSetupError Point1
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (KZGSetupError -> BLSTError -> KZGSetupError
forall a b. a -> b -> a
const (Text -> KZGSetupError
InvalidG1Point Text
hex)) (ByteString -> Either BLSTError Point1
forall curve.
BLS curve =>
ByteString -> Either BLSTError (Point curve)
blsUncompress ByteString
bs)
g2Points :: Either KZGSetupError [Point2]
g2Points :: Either KZGSetupError [Point2]
g2Points = (Text -> Either KZGSetupError Point2)
-> [Text] -> Either KZGSetupError [Point2]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Either KZGSetupError Point2
parseG2 ([Text] -> Either KZGSetupError [Point2])
-> (([Text], [Text]) -> [Text])
-> ([Text], [Text])
-> Either KZGSetupError [Point2]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text], [Text]) -> [Text]
forall a b. (a, b) -> b
snd (([Text], [Text]) -> Either KZGSetupError [Point2])
-> Either KZGSetupError ([Text], [Text])
-> Either KZGSetupError [Point2]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either KZGSetupError ([Text], [Text])
embeddedSetup
where
parseG2 :: Text -> Either KZGSetupError Point2
parseG2 :: Text -> Either KZGSetupError Point2
parseG2 Text
hex = do
ByteString
bs <- (String -> KZGSetupError)
-> Either String ByteString -> Either KZGSetupError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (KZGSetupError -> String -> KZGSetupError
forall a b. a -> b -> a
const (Text -> KZGSetupError
InvalidG2Point Text
hex)) (Text -> Either String ByteString
decodeHexPoint Text
hex)
(BLSTError -> KZGSetupError)
-> Either BLSTError Point2 -> Either KZGSetupError Point2
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (KZGSetupError -> BLSTError -> KZGSetupError
forall a b. a -> b -> a
const (Text -> KZGSetupError
InvalidG2Point Text
hex)) (ByteString -> Either BLSTError Point2
forall curve.
BLS curve =>
ByteString -> Either BLSTError (Point curve)
blsUncompress ByteString
bs)
g1BuiltinPoints :: Either KZGSetupError [BuiltinBLS12_381_G1_Element]
g1BuiltinPoints :: Either KZGSetupError [BuiltinBLS12_381_G1_Element]
g1BuiltinPoints = ([Point1] -> [BuiltinBLS12_381_G1_Element])
-> Either KZGSetupError [Point1]
-> Either KZGSetupError [BuiltinBLS12_381_G1_Element]
forall a b.
(a -> b) -> Either KZGSetupError a -> Either KZGSetupError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Point1 -> BuiltinBLS12_381_G1_Element)
-> [Point1] -> [BuiltinBLS12_381_G1_Element]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BuiltinByteString -> BuiltinBLS12_381_G1_Element
bls12_381_G1_uncompress (BuiltinByteString -> BuiltinBLS12_381_G1_Element)
-> (Point1 -> BuiltinByteString)
-> Point1
-> BuiltinBLS12_381_G1_Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> BuiltinByteString)
-> (Point1 -> ByteString) -> Point1 -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point1 -> ByteString
forall curve. BLS curve => Point curve -> ByteString
blsCompress)) Either KZGSetupError [Point1]
g1Points
g2BuiltinPoints :: Either KZGSetupError [BuiltinBLS12_381_G2_Element]
g2BuiltinPoints :: Either KZGSetupError [BuiltinBLS12_381_G2_Element]
g2BuiltinPoints = ([Point2] -> [BuiltinBLS12_381_G2_Element])
-> Either KZGSetupError [Point2]
-> Either KZGSetupError [BuiltinBLS12_381_G2_Element]
forall a b.
(a -> b) -> Either KZGSetupError a -> Either KZGSetupError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Point2 -> BuiltinBLS12_381_G2_Element)
-> [Point2] -> [BuiltinBLS12_381_G2_Element]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BuiltinByteString -> BuiltinBLS12_381_G2_Element
bls12_381_G2_uncompress (BuiltinByteString -> BuiltinBLS12_381_G2_Element)
-> (Point2 -> BuiltinByteString)
-> Point2
-> BuiltinBLS12_381_G2_Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> BuiltinByteString)
-> (Point2 -> ByteString) -> Point2 -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point2 -> ByteString
forall curve. BLS curve => Point curve -> ByteString
blsCompress)) Either KZGSetupError [Point2]
g2Points
defaultItems :: Int
defaultItems :: Int
defaultItems = Int
30
canonicalG2Points :: [BuiltinBLS12_381_G2_Element]
canonicalG2Points :: [BuiltinBLS12_381_G2_Element]
canonicalG2Points =
Int
-> [BuiltinBLS12_381_G2_Element] -> [BuiltinBLS12_381_G2_Element]
forall a. Int -> [a] -> [a]
take Int
defaultItems ([BuiltinBLS12_381_G2_Element] -> [BuiltinBLS12_381_G2_Element])
-> [BuiltinBLS12_381_G2_Element] -> [BuiltinBLS12_381_G2_Element]
forall a b. (a -> b) -> a -> b
$
(KZGSetupError -> [BuiltinBLS12_381_G2_Element])
-> ([BuiltinBLS12_381_G2_Element] -> [BuiltinBLS12_381_G2_Element])
-> Either KZGSetupError [BuiltinBLS12_381_G2_Element]
-> [BuiltinBLS12_381_G2_Element]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\KZGSetupError
e -> Text -> [BuiltinBLS12_381_G2_Element]
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> [BuiltinBLS12_381_G2_Element])
-> Text -> [BuiltinBLS12_381_G2_Element]
forall a b. (a -> b) -> a -> b
$ Text
"KZG trusted setup invariant violated: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KZGSetupError -> Text
forall b a. (Show a, IsString b) => a -> b
show KZGSetupError
e) [BuiltinBLS12_381_G2_Element] -> [BuiltinBLS12_381_G2_Element]
forall a. a -> a
id Either KZGSetupError [BuiltinBLS12_381_G2_Element]
g2BuiltinPoints