diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, IOHK + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrzej Rybczak nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -Wall #-} +import Data.Maybe +import Distribution.PackageDescription +import Distribution.Simple +import Distribution.Simple.PreProcess + +main :: IO () +main = defaultMainWithHooks hooks + { hookedPreProcessors = hscDropCpp11 $ hookedPreProcessors hooks + } + where + hooks = simpleUserHooks + + -- gcc shows a warning if -std=c++11 is used when compiling a C file, but + -- clang is more strict and considers that an error, so we need to filter it + -- out. + hscDropCpp11 pps = ("hsc", newHsc) : deleteKey "hsc" pps + where + newHsc binfo = fromMaybe ppHsc2hs (lookup "hsc" pps) binfo + { ccOptions = filter (not . f) (ccOptions binfo) + } + where + f flag = flag == "-std=c++11" + +---------------------------------------- + +deleteKey :: Eq k => k -> [(k, v)] -> [(k, v)] +deleteKey _ [] = [] +deleteKey k (x@(a, _):xs) = if k == a + then deleteKey k xs + else x : deleteKey k xs diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Control.DeepSeq +import Criterion.Main +import Data.Binary +import Data.ByteString.Lazy (ByteString) +import Data.Group +import Data.Maybe + +import MCL.Curves.Fp254BNb + +main :: IO () +main = defaultMain + [ bgroup "Fp" + [ benchFpArith fp_a fp_b + , bench "hash_to" $ nf hashToFp "54o6vyua2984v357b35n63" + , bgroup "from_integer" + [ bench "small" $ nf mkFp small_integer + , bench "large" $ nf mkFp large_integer + ] + , bench "eq" $ nf (uncurry (==)) (fp_a, fp_b) + , bench "to_integer" $ nf fromFp fp_a + , bench "is_zero" $ nf fp_isZero fp_a + , bench "sqrt" $ nf fp_squareRoot fp_a + , bench "show" $ nf show fp_a + , benchBinary fp_a + ] + , bgroup "Fp2" + [ benchFpArith fp2_a fp2_b + , bench "from_base" $ nf (uncurry mkFp2) (fp_a, fp_b) + , bench "eq" $ nf (uncurry (==)) (fp2_a, fp2_b) + , bench "is_zero" $ nf fp_isZero fp_a + , bench "sqrt" $ nf fp2_squareRoot fp2_a + , bench "show" $ nf show fp2_a + , benchBinary fp2_a + ] + , bgroup "Fp12" + [ benchFpArith fp12_a fp12_b + , bench "eq" $ nf (uncurry (==)) (fp12_a, fp12_b) + , bench "is_zero" $ nf fp12_isZero fp12_a + , bench "show" $ nf show fp12_a + , benchBinary fp12_a + ] + , bgroup "Fr" + [ benchFpArith fr_a fr_b + , bench "hash_to" $ nf hashToFr "6mn8o8rmn634wcxq354x31" + , bgroup "from_integer" + [ bench "small" $ nf mkFr small_integer + , bench "large" $ nf mkFr large_integer + ] + , bench "eq" $ nf (uncurry (==)) (fr_a, fr_b) + , bench "to_integer" $ nf fromFr fr_a + , bench "is_zero" $ nf fr_isZero fr_a + , bench "show" $ nf show fr_a + , benchBinary fr_a + ] + , bgroup "G1" + [ benchGroupArith g1_powFr g1_p g1_q + , bench "construct" $ nf (uncurry mkG1) (g1_p_x, g1_p_y) + , bench "map_to" $ nf mapToG1 fp_a + , bench "eq" $ nf (uncurry (==)) (g1_p, g1_q) + , bench "is_zero" $ nf g1_isZero g1_p + , bench "affine" $ nf g1_affineCoords g1_p + , bench "show" $ nf show g1_p + , benchBinary g1_p + ] + , bgroup "G2" + [ benchGroupArith g2_powFr g2_p g2_q + , bench "construct" $ nf (uncurry mkG2) (g2_p_x, g2_p_y) + , bench "map_to" $ nf mapToG2 fp2_a + , bench "eq" $ nf (uncurry (==)) (g2_p, g2_q) + , bench "is_zero" $ nf g2_isZero g2_p + , bench "affine" $ nf g2_affineCoords g2_p + , bench "show" $ nf show g2_p + , benchBinary g2_p + ] + , bgroup "GT" + [ bench "pow" $ nf (uncurry pow) (gt_a, large_integer) + , bench "pow_native" $ nf (uncurry gt_powFr) (gt_a, large_integer_fr) + ] + , bgroup "pairing" + [ bench "compute1" $ nf (uncurry pairing) (g1_p, g2_q) + , bench "compute2" $ nf (uncurry pairing) (g1_q, g2_p) + ] + ] + +---------------------------------------- + +benchFpArith :: (Fractional a, NFData a) => a -> a -> Benchmark +benchFpArith a b = bgroup "arith" + [ bench "add" $ nf (uncurry (+)) (a, b) + , bench "subtract" $ nf (uncurry (-)) (a, b) + , bench "multiply" $ nf (uncurry (*)) (a, b) + , bench "negate" $ nf negate a + , bench "invert" $ nf recip a + ] + +benchGroupArith :: (Group g, NFData g) => (g -> Fr -> g) -> g -> g -> Benchmark +benchGroupArith fpow p q = bgroup "arith" + [ bench "add" $ nf (uncurry mappend) (p, q) + , bench "invert" $ nf invert p + , bgroup "mul" + [ bench "small" $ nf (uncurry pow) (p, small_integer) + , bench "large" $ nf (uncurry pow) (p, large_integer) + , bench "native" $ nf (uncurry fpow) (p, large_integer_fr) + ] + ] + +benchBinary :: forall a. (Binary a, NFData a) => a -> Benchmark +benchBinary a = bgroup "binary" + [ bench "put" $ nf encode a + , bench "get" $ nf (decode :: ByteString -> a) (encode a) + ] + +---------------------------------------- + +fr_a, fr_b :: Fr +fr_a = hashToFr "a" +fr_b = hashToFr "b" + +fp_a, fp_b :: Fp +fp_a = hashToFp "a" +fp_b = hashToFp "b" + +fp2_a, fp2_b :: Fp2 +fp2_a = mkFp2 (hashToFp "a") (hashToFp "b") +fp2_b = mkFp2 (hashToFp "c") (hashToFp "d") + +fp12_a, fp12_b :: Fp12 +fp12_a = mkFp12 (mkFp2 (hashToFp "a") (hashToFp "b")) + (mkFp2 (hashToFp "c") (hashToFp "d")) + (mkFp2 (hashToFp "e") (hashToFp "f")) + (mkFp2 (hashToFp "g") (hashToFp "h")) + (mkFp2 (hashToFp "i") (hashToFp "j")) + (mkFp2 (hashToFp "k") (hashToFp "l")) + +fp12_b = mkFp12 (mkFp2 (hashToFp "m") (hashToFp "n")) + (mkFp2 (hashToFp "o") (hashToFp "p")) + (mkFp2 (hashToFp "q") (hashToFp "r")) + (mkFp2 (hashToFp "s") (hashToFp "t")) + (mkFp2 (hashToFp "u") (hashToFp "v")) + (mkFp2 (hashToFp "w") (hashToFp "x")) + +---------------------------------------- + +g1_p, g1_q :: G1 +g1_p = mapToG1 fp_a +g1_q = mapToG1 fp_b + +g1_p_x, g1_p_y :: Fp +(g1_p_x, g1_p_y) = fromJust $ g1_affineCoords g1_p + +---------------------------------------- + +g2_p, g2_q :: G2 +g2_p = mapToG2 fp2_a +g2_q = mapToG2 fp2_b + +g2_p_x, g2_p_y :: Fp2 +(g2_p_x, g2_p_y) = fromJust $ g2_affineCoords g2_p + +gt_a :: GT +gt_a = pairing g1_p g2_q + +---------------------------------------- + +small_integer, large_integer :: Integer +small_integer = 42 +large_integer = fr_modulus `quot` 2 + +large_integer_fr :: Fr +large_integer_fr = mkFr large_integer diff --git a/cbits/mcl_fp254bnb.cpp b/cbits/mcl_fp254bnb.cpp new file mode 100644 --- /dev/null +++ b/cbits/mcl_fp254bnb.cpp @@ -0,0 +1,533 @@ +#include +#include "impl.hpp" + +using namespace hs_mcl; +using namespace mcl::bn256; + +namespace { + +void initialize_parameters() +{ + // C++11 guarantees static variable initializers to be run at most once and in + // a thread-safe manner. + static void *initializer = [] { + bn256init(mcl::bn::CurveFp254BNb); + return nullptr; + }(); + static_cast(initializer); +} + +} + +extern "C" { + +//////////////////////////////////////////////////////////// +// Fr + +int hs_mcl_fp254bnb_fr_size() +{ + return sizeof(Fr); +} + +int hs_mcl_fp254bnb_fr_limbs() +{ + initialize_parameters(); + + return Fr::getByteSize() / sizeof(mp_limb_t); +} + +void hs_mcl_fp254bnb_fr_modulus(mp_limb_t *result, + const size_t result_length_bytes) +{ + initialize_parameters(); + + mpz_class_to_gmp_integer(BN::param.r, result, result_length_bytes); +} + +void hs_mcl_fp254bnb_fr_hash_to(const char *s, const size_t s_length, Fr *result) +{ + initialize_parameters(); + + return field_impl::hash_to(s, s_length, result); +} + +void hs_mcl_fp254bnb_fr_add(const Fr *a, const Fr *b, Fr *result) +{ + return field_impl::add(a, b, result); +} + +void hs_mcl_fp254bnb_fr_subtract(const Fr *a, const Fr *b, Fr *result) +{ + return field_impl::subtract(a, b, result); +} + +void hs_mcl_fp254bnb_fr_multiply(const Fr *a, const Fr *b, Fr *result) +{ + return field_impl::multiply(a, b, result); +} + +void hs_mcl_fp254bnb_fr_negate(const Fr *a, Fr *result) +{ + return field_impl::negate(a, result); +} + +void hs_mcl_fp254bnb_fr_from_integer(const mp_limb_t *scalar, + const mp_size_t scalar_limbs, + Fr *result) +{ + initialize_parameters(); + + return field_impl::from_gmp_integer(scalar, scalar_limbs, result); +} + +void hs_mcl_fp254bnb_fr_from_hsint(const HsInt scalar, Fr *result) +{ + initialize_parameters(); + + return field_impl::from_hsint(scalar, result); +} + +void hs_mcl_fp254bnb_fr_invert(const Fr *a, Fr *result) +{ + return field_impl::invert(a, result); +} + +int hs_mcl_fp254bnb_fr_eq(const Fr *a, const Fr *b) +{ + return field_impl::eq(a, b); +} + +void hs_mcl_fp254bnb_fr_to_gmp_integer(const Fr *a, mp_limb_t *result, + const int result_length_bytes) +{ + return field_impl::to_gmp_integer(a, result, result_length_bytes); +} + +int hs_mcl_fp254bnb_fr_is_zero(const Fr *a) +{ + return field_impl::is_zero(a); +} + +int hs_mcl_fp254bnb_fr_sqrt(const Fr *a, Fr *result) +{ + return field_impl::sqrt(a, result); +} + +//////////////////////////////////////////////////////////// +// Fp + +int hs_mcl_fp254bnb_fp_size() +{ + return sizeof(Fp); +} + +int hs_mcl_fp254bnb_fp_limbs() +{ + initialize_parameters(); + + return Fp::getByteSize() / sizeof(mp_limb_t); +} + +void hs_mcl_fp254bnb_fp_modulus(mp_limb_t *result, + const size_t result_length_bytes) +{ + initialize_parameters(); + + mpz_class_to_gmp_integer(BN::param.p, result, result_length_bytes); +} + +void hs_mcl_fp254bnb_fp_hash_to(const char *s, const size_t s_length, Fp *result) +{ + initialize_parameters(); + + return field_impl::hash_to(s, s_length, result); +} + +void hs_mcl_fp254bnb_fp_add(const Fp *a, const Fp *b, Fp *result) +{ + return field_impl::add(a, b, result); +} + +void hs_mcl_fp254bnb_fp_subtract(const Fp *a, const Fp *b, Fp *result) +{ + return field_impl::subtract(a, b, result); +} + +void hs_mcl_fp254bnb_fp_multiply(const Fp *a, const Fp *b, Fp *result) +{ + return field_impl::multiply(a, b, result); +} + +void hs_mcl_fp254bnb_fp_negate(const Fp *a, Fp *result) +{ + return field_impl::negate(a, result); +} + +void hs_mcl_fp254bnb_fp_from_integer(const mp_limb_t *scalar, + const mp_size_t scalar_limbs, + Fp *result) +{ + initialize_parameters(); + + return field_impl::from_gmp_integer(scalar, scalar_limbs, result); +} + +void hs_mcl_fp254bnb_fp_from_hsint(const HsInt scalar, Fp *result) +{ + initialize_parameters(); + + return field_impl::from_hsint(scalar, result); +} + +void hs_mcl_fp254bnb_fp_invert(const Fp *a, Fp *result) +{ + return field_impl::invert(a, result); +} + +int hs_mcl_fp254bnb_fp_eq(const Fp *a, const Fp *b) +{ + return field_impl::eq(a, b); +} + +void hs_mcl_fp254bnb_fp_to_gmp_integer(const Fp *a, mp_limb_t *result, + const int result_length_bytes) +{ + return field_impl::to_gmp_integer(a, result, result_length_bytes); +} + +int hs_mcl_fp254bnb_fp_is_zero(const Fp *a) +{ + return field_impl::is_zero(a); +} + +int hs_mcl_fp254bnb_fp_sqrt(const Fp *a, Fp *result) +{ + return field_impl::sqrt(a, result); +} + +//////////////////////////////////////////////////////////// +// Fp2 + +int hs_mcl_fp254bnb_fp2_size() +{ + return sizeof(Fp2); +} + +void hs_mcl_fp254bnb_fp2_add(const Fp2 *a, const Fp2 *b, Fp2 *result) +{ + return field_impl::add(a, b, result); +} + +void hs_mcl_fp254bnb_fp2_subtract(const Fp2 *a, const Fp2 *b, Fp2 *result) +{ + return field_impl::subtract(a, b, result); +} + +void hs_mcl_fp254bnb_fp2_multiply(const Fp2 *a, const Fp2 *b, Fp2 *result) +{ + return field_impl::multiply(a, b, result); +} + +void hs_mcl_fp254bnb_fp2_negate(const Fp2 *a, Fp2 *result) +{ + return field_impl::negate(a, result); +} + +void hs_mcl_fp254bnb_fp2_from_base(const Fp *c0, const Fp *c1, Fp2 *result) +{ + return field_impl::from_base(result, *c0, *c1); +} + +void hs_mcl_fp254bnb_fp2_invert(const Fp2 *a, Fp2 *result) +{ + return field_impl::invert(a, result); +} + +int hs_mcl_fp254bnb_fp2_eq(const Fp2 *a, const Fp2 *b) +{ + return field_impl::eq(a, b); +} + +void hs_mcl_fp254bnb_fp2_c0(const Fp2 *a, Fp *result) +{ + mem_util::copy(result, a->a); +} + +void hs_mcl_fp254bnb_fp2_c1(const Fp2 *a, Fp *result) +{ + mem_util::copy(result, a->b); +} + +int hs_mcl_fp254bnb_fp2_is_zero(const Fp2 *a) +{ + return field_impl::is_zero(a); +} + +int hs_mcl_fp254bnb_fp2_sqrt(const Fp2 *a, Fp2 *result) +{ + return field_impl::sqrt(a, result); +} + +//////////////////////////////////////////////////////////// +// Fp12 + +int hs_mcl_fp254bnb_fp12_size() +{ + return sizeof(Fp12); +} + +void hs_mcl_fp254bnb_fp12_add(const Fp12 *a, const Fp12 *b, Fp12 *result) +{ + return field_impl::add(a, b, result); +} + +void hs_mcl_fp254bnb_fp12_subtract(const Fp12 *a, const Fp12 *b, Fp12 *result) +{ + return field_impl::subtract(a, b, result); +} + +void hs_mcl_fp254bnb_fp12_multiply(const Fp12 *a, const Fp12 *b, Fp12 *result) +{ + return field_impl::multiply(a, b, result); +} + +void hs_mcl_fp254bnb_fp12_negate(const Fp12 *a, Fp12 *result) +{ + return field_impl::negate(a, result); +} + +void hs_mcl_fp254bnb_fp12_from_base(const Fp2 *c0, const Fp2 *c1, const Fp2 *c2, + const Fp2 *c3, const Fp2 *c4, const Fp2 *c5, + Fp12 *result) +{ + return field_impl::from_base(result, *c0, *c1, *c2, *c3, *c4, *c5); +} + +void hs_mcl_fp254bnb_fp12_invert(const Fp12 *a, Fp12 *result) +{ + return field_impl::invert(a, result); +} + +int hs_mcl_fp254bnb_fp12_eq(const Fp12 *a, const Fp12 *b) +{ + return field_impl::eq(a, b); +} + +void hs_mcl_fp254bnb_fp12_c0(const Fp12 *a, Fp2 *result) +{ + mem_util::copy(result, a->a.a); +} + +void hs_mcl_fp254bnb_fp12_c1(const Fp12 *a, Fp2 *result) +{ + mem_util::copy(result, a->a.b); +} + +void hs_mcl_fp254bnb_fp12_c2(const Fp12 *a, Fp2 *result) +{ + mem_util::copy(result, a->a.c); +} + +void hs_mcl_fp254bnb_fp12_c3(const Fp12 *a, Fp2 *result) +{ + mem_util::copy(result, a->b.a); +} + +void hs_mcl_fp254bnb_fp12_c4(const Fp12 *a, Fp2 *result) +{ + mem_util::copy(result, a->b.b); +} + +void hs_mcl_fp254bnb_fp12_c5(const Fp12 *a, Fp2 *result) +{ + mem_util::copy(result, a->b.c); +} + +int hs_mcl_fp254bnb_fp12_is_zero(const Fp12 *a) +{ + return field_impl::is_zero(a); +} + +//////////////////////////////////////////////////////////// +// G1 + +int hs_mcl_fp254bnb_g1_size() +{ + return sizeof(G1); +} + +void hs_mcl_fp254bnb_g1_zero(G1 *result) +{ + initialize_parameters(); + + return group_impl::zero(result); +} + +int hs_mcl_fp254bnb_g1_construct(const Fp *x, const Fp *y, G1 *result) +{ + return group_impl::construct(x, y, result); +} + +void hs_mcl_fp254bnb_g1_map_to(const Fp *a, G1 *result) +{ + return group_impl::map_to(BN::mapToG1, a, result); +} + +void hs_mcl_fp254bnb_g1_add(const G1 *p, const G1 *q, G1 *result) +{ + return group_impl::add(p, q, result); +} + +void hs_mcl_fp254bnb_g1_invert(const G1 *p, G1 *result) +{ + return group_impl::invert(p, result); +} + +void hs_mcl_fp254bnb_g1_scalar_mul_native(const int const_time, + const Fr *scalar, + const G1 *p, + G1 *result) +{ + return group_impl::scalar_mul_native(const_time, scalar, p, result); +} + +void hs_mcl_fp254bnb_g1_scalar_mul(const int const_time, + const mp_limb_t *scalar, + const mp_size_t scalar_limbs, + const int is_negative, + const G1 *p, + G1 *result) +{ + return group_impl::scalar_mul(const_time, scalar, scalar_limbs, + is_negative, p, result); +} + +void hs_mcl_fp254bnb_g1_scalar_mul_small(const int const_time, + const HsInt scalar, + const G1 *p, + G1 *result) +{ + return group_impl::scalar_mul_small(const_time, scalar, p, result); +} + +int hs_mcl_fp254bnb_g1_eq(const G1 *p, const G1 *q) +{ + return group_impl::eq(p, q); +} + +int hs_mcl_fp254bnb_g1_is_zero(const G1 *p) +{ + return group_impl::is_zero(p); +} + +void hs_mcl_fp254bnb_g1_affine_coords(const G1 *p, Fp *result_x, Fp *result_y) +{ + return group_impl::affine_coords(p, result_x, result_y); +} + +int hs_mcl_fp254bnb_g1_y_from_x(const int y_lsb, const Fp *x, Fp *result) +{ + return group_impl::y_from_x(y_lsb, x, result); +} + +//////////////////////////////////////////////////////////// +// G2 + +int hs_mcl_fp254bnb_g2_size() +{ + return sizeof(G2); +} + +void hs_mcl_fp254bnb_g2_zero(G2 *result) +{ + initialize_parameters(); + + return group_impl::zero(result); +} + +int hs_mcl_fp254bnb_g2_construct(const Fp2 *x, const Fp2 *y, G2 *result) +{ + return group_impl::construct(x, y, result); +} + +void hs_mcl_fp254bnb_g2_map_to(const Fp2 *a, G2 *result) +{ + return group_impl::map_to(BN::mapToG2, a, result); +} + +void hs_mcl_fp254bnb_g2_add(const G2 *p, const G2 *q, G2 *result) +{ + return group_impl::add(p, q, result); +} + +void hs_mcl_fp254bnb_g2_invert(const G2 *p, G2 *result) +{ + return group_impl::invert(p, result); +} + +void hs_mcl_fp254bnb_g2_scalar_mul_native(const int const_time, + const Fr *scalar, + const G2 *p, + G2 *result) +{ + return group_impl::scalar_mul_native(const_time, scalar, p, result); +} + +void hs_mcl_fp254bnb_g2_scalar_mul(const int const_time, + const mp_limb_t *scalar, + const mp_size_t scalar_limbs, + const int is_negative, + const G2 *p, + G2 *result) +{ + return group_impl::scalar_mul(const_time, scalar, scalar_limbs, + is_negative, p, result); +} + +void hs_mcl_fp254bnb_g2_scalar_mul_small(const int const_time, + const HsInt scalar, + const G2 *p, + G2 *result) +{ + return group_impl::scalar_mul_small(const_time, scalar, p, result); +} + +int hs_mcl_fp254bnb_g2_eq(const G2 *p, const G2 *q) +{ + return group_impl::eq(p, q); +} + +int hs_mcl_fp254bnb_g2_is_zero(const G2 *p) +{ + return group_impl::is_zero(p); +} + +void hs_mcl_fp254bnb_g2_affine_coords(const G2 *p, Fp2 *result_x, Fp2 *result_y) +{ + return group_impl::affine_coords(p, result_x, result_y); +} + +int hs_mcl_fp254bnb_g2_y_from_x(const int y_lsb, const Fp2 *x, Fp2 *result) +{ + return group_impl::y_from_x(y_lsb, x, result); +} + +//////////////////////////////////////////////////////////// +// GT + +void hs_mcl_fp254bnb_gt_pow_native(const int const_time, const Fp12 *a, + const Fr *b, Fp12 *result) +{ + return field_impl::pow_native(const_time, a, b, result); +} + +//////////////////////////////////////////////////////////// +// Pairing + +void hs_mcl_fp254bnb_pairing(const G1 *p, const G2 *q, Fp12 *result) +{ + mem_util::init(result); + BN::pairing(*result, *p, *q); +} + +} diff --git a/mcl.cabal b/mcl.cabal new file mode 100644 --- /dev/null +++ b/mcl.cabal @@ -0,0 +1,100 @@ +name: mcl +version: 1.0.0 +synopsis: Bindings to mcl, a generic and fast pairing-based cryptography library +description: Base library: https://github.com/herumi/mcl +license: BSD3 +license-file: LICENSE +author: Andrzej Rybczak +maintainer: andrzej@well-typed.com +copyright: 2017 IOHK +category: Crypto, Math + +build-type: Custom +cabal-version: >=1.10 +custom-setup + setup-depends: base < 5, + Cabal + +source-repository head + type: git + location: https://github.com/arybczak/haskell-mcl + +library + exposed-modules: MCL.Curves.Fp254BNb + MCL.Curves.Fp254BNb.Fp + MCL.Curves.Fp254BNb.Fp2 + MCL.Curves.Fp254BNb.Fp12 + MCL.Curves.Fp254BNb.Fr + MCL.Curves.Fp254BNb.G1 + MCL.Curves.Fp254BNb.G2 + MCL.Curves.Fp254BNb.GT + MCL.Curves.Fp254BNb.Pairing + MCL.Internal.Field + MCL.Internal.Group + MCL.Internal.Prim + MCL.Internal.Prim.Class + MCL.Internal.Prim.Pinned + MCL.Internal.Prim.Unpinned + MCL.Internal.Utils + + build-depends: base < 5, + binary, + bytestring, + deepseq, + ghc-prim, + groups, + integer-gmp, + primitive + + hs-source-dirs: src + + ghc-options: -Wall + if impl(ghc >= 8) + ghc-options: -Wredundant-constraints + + default-language: Haskell2010 + + cc-options: -std=c++11 -Wall -Wextra + + c-sources: cbits/mcl_fp254bnb.cpp + + extra-libraries: crypto gmpxx mcl stdc++ + +Benchmark bench + build-depends: mcl, + base < 5, + binary, + bytestring, + criterion, + deepseq, + groups + + ghc-options: -Wall -threaded -rtsopts + if impl(ghc >= 8) + ghc-options: -Wredundant-constraints + + type: exitcode-stdio-1.0 + main-is: Main.hs + + hs-source-dirs: benchmark + default-language: Haskell2010 + +test-suite tests + build-depends: mcl, + QuickCheck, + base < 5, + binary, + groups, + test-framework, + test-framework-quickcheck2 + + ghc-options: -Wall -threaded -rtsopts + if impl(ghc >= 8) + ghc-options: -Wredundant-constraints + + + type: exitcode-stdio-1.0 + main-is: Main.hs + + hs-source-dirs: test + default-language: Haskell2010 diff --git a/src/MCL/Curves/Fp254BNb.hs b/src/MCL/Curves/Fp254BNb.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb.hs @@ -0,0 +1,27 @@ +-- | Elliptic curve offering 128 bits of security from Barreto-Naehrig +-- family. It uses the following parameters: +-- +-- - @p = 16798108731015832284940804142231733909889187121439069848933715426072753864723@ +-- - @r = 16798108731015832284940804142231733909759579603404752749028378864165570215949@ +-- - @E : Y² = X³ + 2, defined over 'Fp'.@ +-- - @E' : Y² = X³ + 2/(1 + α), defined over 'Fp2'.@ +-- +module MCL.Curves.Fp254BNb + ( module MCL.Curves.Fp254BNb.Fp + , module MCL.Curves.Fp254BNb.Fp2 + , module MCL.Curves.Fp254BNb.Fp12 + , module MCL.Curves.Fp254BNb.Fr + , module MCL.Curves.Fp254BNb.G1 + , module MCL.Curves.Fp254BNb.G2 + , module MCL.Curves.Fp254BNb.GT + , module MCL.Curves.Fp254BNb.Pairing + ) where + +import MCL.Curves.Fp254BNb.Fp +import MCL.Curves.Fp254BNb.Fp12 +import MCL.Curves.Fp254BNb.Fp2 +import MCL.Curves.Fp254BNb.Fr +import MCL.Curves.Fp254BNb.G1 +import MCL.Curves.Fp254BNb.G2 +import MCL.Curves.Fp254BNb.GT +import MCL.Curves.Fp254BNb.Pairing diff --git a/src/MCL/Curves/Fp254BNb/Fp.hs b/src/MCL/Curves/Fp254BNb/Fp.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb/Fp.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Curves.Fp254BNb.Fp + ( Fp + , mkFp + , hashToFp + , fromFp + , fp_modulus + , fp_isZero + , fp_squareRoot + ) where + +import Control.DeepSeq +import Data.Binary +import Foreign.C.Types +import GHC.Exts +import GHC.Integer.GMP.Internals +import qualified Data.ByteString as BS + +import MCL.Internal.Utils +import qualified MCL.Internal.Field as I +import qualified MCL.Internal.Prim as I + +-- | Prime finite field of characteristic @p@. +data Fp = Fp { unFp :: I.CC Fp } + +instance Binary Fp where + put = putBytesFx 32 . fromFp + get = mkFp <$> getBytesFx 32 + +instance NFData Fp where + rnf = (`seq` ()) + +instance Num Fp where + (+) = I.addFp + (-) = I.subtractFp + (*) = I.multiplyFp + negate = I.negateFp + abs = I.absFp + signum = I.signumFp + fromInteger = I.mkFp + +instance Fractional Fp where + recip = I.recipFp + fromRational = I.fromRationalFp + +instance Eq Fp where + (==) = I.eqFp + +instance Show Fp where + showsPrec = I.showsPrecFp + +-- | Construct an element of Fp from Integer. +{-# INLINE mkFp #-} +mkFp :: Integer -> Fp +mkFp = I.mkFp + +-- | Hash arbitrary message to Fp by computing its SHA256 hash and treating its +-- first 253 bits as the value of Fp. +{-# INLINE hashToFp #-} +hashToFp :: BS.ByteString -> Fp +hashToFp = I.hashToFp + +-- | Convert the element of Fp back to non-negative Integer. +{-# INLINE fromFp #-} +fromFp :: Fp -> Integer +fromFp = I.fromFp + +-- | Modulus of Fp. +{-# NOINLINE fp_modulus #-} +fp_modulus :: Integer +fp_modulus = I.modulus (proxy# :: Proxy# Fp) + +-- | Check if the element of Fp is zero. +{-# INLINE fp_isZero #-} +fp_isZero :: Fp -> Bool +fp_isZero = I.isZero + +-- | Compute square root of the element @a ∈ Fp@. If polynomial @x² - a@ has no +-- roots in Fp, no result is returned. +{-# INLINE fp_squareRoot #-} +fp_squareRoot :: Fp -> Maybe Fp +fp_squareRoot = I.squareRoot + +---------------------------------------- + +-- | Internal +instance I.Prim Fp where + prim_size _ = fromIntegral c_mcl_fp254bnb_fp_size + prim_wrap = Fp + prim_unwrap = unFp + +-- | Internal +instance I.BaseField Fp where + c_limbs _ = fromIntegral c_mcl_fp254bnb_fp_limbs + c_modulus _ = c_mcl_fp254bnb_fp_modulus + c_hash_to _ = c_mcl_fp254bnb_fp_hash_to + c_from_integer _ = c_mcl_fp254bnb_fp_from_integer + c_from_hsint _ = c_mcl_fp254bnb_fp_from_hsint + c_to_integer _ = c_mcl_fp254bnb_fp_to_gmp_integer + +-- | Internal +instance I.HasArith Fp where + c_add _ = c_mcl_fp254bnb_fp_add + c_subtract _ = c_mcl_fp254bnb_fp_subtract + c_multiply _ = c_mcl_fp254bnb_fp_multiply + c_negate _ = c_mcl_fp254bnb_fp_negate + c_invert _ = c_mcl_fp254bnb_fp_invert + c_eq _ = c_mcl_fp254bnb_fp_eq + c_is_zero _ = c_mcl_fp254bnb_fp_is_zero + +-- | Internal +instance I.HasSqrt Fp where + c_sqrt _ = c_mcl_fp254bnb_fp_sqrt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_size" + c_mcl_fp254bnb_fp_size :: CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_limbs" + c_mcl_fp254bnb_fp_limbs :: CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_modulus" + c_mcl_fp254bnb_fp_modulus :: I.MC Integer -> CSize -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_hash_to" + c_mcl_fp254bnb_fp_hash_to :: Ptr CChar -> CSize -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_add" + c_mcl_fp254bnb_fp_add :: I.CC Fp -> I.CC Fp -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_subtract" + c_mcl_fp254bnb_fp_subtract :: I.CC Fp -> I.CC Fp -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_multiply" + c_mcl_fp254bnb_fp_multiply :: I.CC Fp -> I.CC Fp -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_negate" + c_mcl_fp254bnb_fp_negate :: I.CC Fp -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_from_integer" + c_mcl_fp254bnb_fp_from_integer :: I.CC Integer -> GmpSize# -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_from_hsint" + c_mcl_fp254bnb_fp_from_hsint :: Int# -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_invert" + c_mcl_fp254bnb_fp_invert :: I.CC Fp -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_eq" + c_mcl_fp254bnb_fp_eq :: I.CC Fp -> I.CC Fp -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_to_gmp_integer" + c_mcl_fp254bnb_fp_to_gmp_integer :: I.CC Fp -> I.MC Integer -> CSize -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_is_zero" + c_mcl_fp254bnb_fp_is_zero :: I.CC Fp -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp_sqrt" + c_mcl_fp254bnb_fp_sqrt :: I.CC Fp -> I.MC Fp -> IO CInt diff --git a/src/MCL/Curves/Fp254BNb/Fp12.hs b/src/MCL/Curves/Fp254BNb/Fp12.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb/Fp12.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Curves.Fp254BNb.Fp12 + ( Fp12 + , beta + , mkFp12 + , fp12_c0 + , fp12_c1 + , fp12_c2 + , fp12_c3 + , fp12_c4 + , fp12_c5 + , fp12_isZero + ) where + +import Control.DeepSeq +import Data.Binary +import Foreign.C.Types + +import MCL.Curves.Fp254BNb.Fp2 +import qualified MCL.Internal.Field as I +import qualified MCL.Internal.Prim as I + +-- | Sixth degree field extension of 'Fp2' defined as @Fp2(β)@, where @β⁶ = 1 + α@. +data Fp12 = Fp12 { unFp12 :: I.CC Fp12 } + +instance Binary Fp12 where + put n = put (fp12_c0 n) *> put (fp12_c1 n) *> put (fp12_c2 n) + *> put (fp12_c3 n) *> put (fp12_c4 n) *> put (fp12_c5 n) + get = mkFp12 <$> get <*> get <*> get <*> get <*> get <*> get + +instance NFData Fp12 where + rnf = (`seq` ()) + +instance Num Fp12 where + (+) = I.addFp + (-) = I.subtractFp + (*) = I.multiplyFp + negate = I.negateFp + abs = I.absFp + signum = I.signumFp + fromInteger n = mkFp12 (fromInteger n) 0 0 0 0 0 + +instance Fractional Fp12 where + recip = I.recipFp + fromRational = I.fromRationalFp + +instance Eq Fp12 where + (==) = I.eqFp + +instance Show Fp12 where + showsPrec p a = showsPrec p (fp12_c0 a, fp12_c1 a, fp12_c2 a, + fp12_c3 a, fp12_c4 a, fp12_c5 a) + +-- | Root of the polynomial @x⁶ - 1 - α@. +{-# NOINLINE beta #-} +beta :: Fp12 +beta = mkFp12 0 0 0 1 0 0 + +-- Construct an element of Fp12 from six coordinates in Fp2. +{-# INLINE mkFp12 #-} +mkFp12 :: Fp2 -> Fp2 -> Fp2 -> Fp2 -> Fp2 -> Fp2 -> Fp12 +mkFp12 = I.unsafeOp6_ c_mcl_fp254bnb_fp12_from_base + +-- | Return first Fp2 coordinate of the element in Fp12. +{-# INLINE fp12_c0 #-} +fp12_c0 :: Fp12 -> Fp2 +fp12_c0 = I.unsafeOp1_ c_mcl_fp254bnb_fp12_c0 + +-- | Return second Fp2 coordinate of the element in Fp12. +{-# INLINE fp12_c1 #-} +fp12_c1 :: Fp12 -> Fp2 +fp12_c1 = I.unsafeOp1_ c_mcl_fp254bnb_fp12_c1 + +-- | Return third Fp2 coordinate of the element in Fp12. +{-# INLINE fp12_c2 #-} +fp12_c2 :: Fp12 -> Fp2 +fp12_c2 = I.unsafeOp1_ c_mcl_fp254bnb_fp12_c2 + +-- | Return fourth Fp2 coordinate of the element in Fp12. +{-# INLINE fp12_c3 #-} +fp12_c3 :: Fp12 -> Fp2 +fp12_c3 = I.unsafeOp1_ c_mcl_fp254bnb_fp12_c3 + +-- | Return fifth Fp2 coordinate of the element in Fp12. +{-# INLINE fp12_c4 #-} +fp12_c4 :: Fp12 -> Fp2 +fp12_c4 = I.unsafeOp1_ c_mcl_fp254bnb_fp12_c4 + +-- | Return sixth Fp2 coordinate of the element in Fp12. +{-# INLINE fp12_c5 #-} +fp12_c5 :: Fp12 -> Fp2 +fp12_c5 = I.unsafeOp1_ c_mcl_fp254bnb_fp12_c5 + +-- | Check whether the element of Fp12 is zero. +{-# INLINE fp12_isZero #-} +fp12_isZero :: Fp12 -> Bool +fp12_isZero = I.isZero + +---------------------------------------- + +-- | Internal +instance I.Prim Fp12 where + prim_size _ = fromIntegral c_mcl_fp254bnb_fp12_size + prim_wrap = Fp12 + prim_unwrap = unFp12 + +-- | Internal +instance I.HasArith Fp12 where + c_add _ = c_mcl_fp254bnb_fp12_add + c_subtract _ = c_mcl_fp254bnb_fp12_subtract + c_multiply _ = c_mcl_fp254bnb_fp12_multiply + c_negate _ = c_mcl_fp254bnb_fp12_negate + c_invert _ = c_mcl_fp254bnb_fp12_invert + c_eq _ = c_mcl_fp254bnb_fp12_eq + c_is_zero _ = c_mcl_fp254bnb_fp12_is_zero + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_size" + c_mcl_fp254bnb_fp12_size :: CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_add" + c_mcl_fp254bnb_fp12_add :: I.CC Fp12 -> I.CC Fp12 -> I.MC Fp12 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_subtract" + c_mcl_fp254bnb_fp12_subtract :: I.CC Fp12 -> I.CC Fp12 -> I.MC Fp12 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_multiply" + c_mcl_fp254bnb_fp12_multiply :: I.CC Fp12 -> I.CC Fp12 -> I.MC Fp12 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_negate" + c_mcl_fp254bnb_fp12_negate :: I.CC Fp12 -> I.MC Fp12 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_from_base" + c_mcl_fp254bnb_fp12_from_base :: I.CC Fp2 -> I.CC Fp2 -> I.CC Fp2 + -> I.CC Fp2 -> I.CC Fp2 -> I.CC Fp2 + -> I.MC Fp12 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_invert" + c_mcl_fp254bnb_fp12_invert :: I.CC Fp12 -> I.MC Fp12 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_eq" + c_mcl_fp254bnb_fp12_eq :: I.CC Fp12 -> I.CC Fp12 -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_c0" + c_mcl_fp254bnb_fp12_c0 :: I.CC Fp12 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_c1" + c_mcl_fp254bnb_fp12_c1 :: I.CC Fp12 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_c2" + c_mcl_fp254bnb_fp12_c2 :: I.CC Fp12 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_c3" + c_mcl_fp254bnb_fp12_c3 :: I.CC Fp12 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_c4" + c_mcl_fp254bnb_fp12_c4 :: I.CC Fp12 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_c5" + c_mcl_fp254bnb_fp12_c5 :: I.CC Fp12 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp12_is_zero" + c_mcl_fp254bnb_fp12_is_zero :: I.CC Fp12 -> IO CInt diff --git a/src/MCL/Curves/Fp254BNb/Fp2.hs b/src/MCL/Curves/Fp254BNb/Fp2.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb/Fp2.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Curves.Fp254BNb.Fp2 + ( Fp2 + , alpha + , mkFp2 + , fp2_c0 + , fp2_c1 + , fp2_isZero + , fp2_squareRoot + ) where + +import Control.DeepSeq +import Data.Binary +import Foreign.C.Types + +import MCL.Curves.Fp254BNb.Fp +import qualified MCL.Internal.Field as I +import qualified MCL.Internal.Prim as I + +-- | Quadratic field extension of 'Fp' defined as @Fp(α)@, where @α² = -1@. +data Fp2 = Fp2 { unFp2 :: I.CC Fp2 } + +instance Binary Fp2 where + put n = put (fp2_c0 n) >> put (fp2_c1 n) + get = mkFp2 <$> get <*> get + +instance NFData Fp2 where + rnf = (`seq` ()) + +instance Num Fp2 where + (+) = I.addFp + (-) = I.subtractFp + (*) = I.multiplyFp + negate = I.negateFp + abs = I.absFp + signum = I.signumFp + fromInteger n = mkFp2 (fromInteger n) 0 + +instance Fractional Fp2 where + recip = I.recipFp + fromRational = I.fromRationalFp + +instance Eq Fp2 where + (==) = I.eqFp + +instance Show Fp2 where + showsPrec p a = case c0 of + 0 -> ext False + n -> showsPrec p n . ext True + where + c0 = fp2_c0 a + c1 = fp2_c1 a + + plus True = (" + " ++) + plus False = id + + ext out = case c1 of + 0 -> if out then id else ("0" ++) + 1 -> plus out . ("a" ++) + _ -> plus out . showsPrec p c1 . ("a" ++) + +-- | Root of the polynomial @x² + 1@. +{-# NOINLINE alpha #-} +alpha :: Fp2 +alpha = mkFp2 0 1 + +-- | Construct an element of Fp from two coordinates in Fp. +{-# INLINE mkFp2 #-} +mkFp2 :: Fp -> Fp -> Fp2 +mkFp2 = I.unsafeOp2_ c_mcl_fp254bnb_fp2_from_base + +-- | Return first Fp coordinate of the element in Fp2. +{-# INLINE fp2_c0 #-} +fp2_c0 :: Fp2 -> Fp +fp2_c0 = I.unsafeOp1_ c_mcl_fp254bnb_fp2_c0 + +-- | Return second Fp coordinate of the element in Fp2. +{-# INLINE fp2_c1 #-} +fp2_c1 :: Fp2 -> Fp +fp2_c1 = I.unsafeOp1_ c_mcl_fp254bnb_fp2_c1 + +-- | Check whether the element of Fp2 is zero. +{-# INLINE fp2_isZero #-} +fp2_isZero :: Fp2 -> Bool +fp2_isZero = I.isZero + +-- | Compute square root of the element @a ∈ Fp2@. If polynomial @x² - a@ has no +-- roots in Fp2, no result is returned. +{-# INLINE fp2_squareRoot #-} +fp2_squareRoot :: Fp2 -> Maybe Fp2 +fp2_squareRoot = I.squareRoot + +---------------------------------------- + +-- | Internal +instance I.Prim Fp2 where + prim_size _ = fromIntegral c_mcl_fp254bnb_fp2_size + prim_wrap = Fp2 + prim_unwrap = unFp2 + +-- | Internal +instance I.HasArith Fp2 where + c_add _ = c_mcl_fp254bnb_fp2_add + c_subtract _ = c_mcl_fp254bnb_fp2_subtract + c_multiply _ = c_mcl_fp254bnb_fp2_multiply + c_negate _ = c_mcl_fp254bnb_fp2_negate + c_invert _ = c_mcl_fp254bnb_fp2_invert + c_eq _ = c_mcl_fp254bnb_fp2_eq + c_is_zero _ = c_mcl_fp254bnb_fp2_is_zero + +-- | Internal +instance I.HasSqrt Fp2 where + c_sqrt _ = c_mcl_fp254bnb_fp2_sqrt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_size" + c_mcl_fp254bnb_fp2_size :: CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_add" + c_mcl_fp254bnb_fp2_add :: I.CC Fp2 -> I.CC Fp2 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_subtract" + c_mcl_fp254bnb_fp2_subtract :: I.CC Fp2 -> I.CC Fp2 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_multiply" + c_mcl_fp254bnb_fp2_multiply :: I.CC Fp2 -> I.CC Fp2 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_negate" + c_mcl_fp254bnb_fp2_negate :: I.CC Fp2 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_from_base" + c_mcl_fp254bnb_fp2_from_base :: I.CC Fp -> I.CC Fp -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_invert" + c_mcl_fp254bnb_fp2_invert :: I.CC Fp2 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_eq" + c_mcl_fp254bnb_fp2_eq :: I.CC Fp2 -> I.CC Fp2 -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_c0" + c_mcl_fp254bnb_fp2_c0 :: I.CC Fp2 -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_c1" + c_mcl_fp254bnb_fp2_c1 :: I.CC Fp2 -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_is_zero" + c_mcl_fp254bnb_fp2_is_zero :: I.CC Fp2 -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fp2_sqrt" + c_mcl_fp254bnb_fp2_sqrt :: I.CC Fp2 -> I.MC Fp2 -> IO CInt diff --git a/src/MCL/Curves/Fp254BNb/Fr.hs b/src/MCL/Curves/Fp254BNb/Fr.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb/Fr.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Curves.Fp254BNb.Fr + ( Fr + , mkFr + , hashToFr + , fromFr + , fr_modulus + , fr_isZero + , fr_squareRoot + ) where + +import Control.DeepSeq +import Data.Binary +import Foreign.C.Types +import GHC.Exts +import GHC.Integer.GMP.Internals +import qualified Data.ByteString as BS + +import MCL.Internal.Utils +import qualified MCL.Internal.Field as I +import qualified MCL.Internal.Prim as I + +-- | Prime finite field of characteristic @r@. +data Fr = Fr { unFr :: I.CC Fr } + +instance Binary Fr where + put = putBytesFx 32 . fromFr + get = mkFr <$> getBytesFx 32 + +instance NFData Fr where + rnf = (`seq` ()) + +instance Num Fr where + (+) = I.addFp + (-) = I.subtractFp + (*) = I.multiplyFp + negate = I.negateFp + abs = I.absFp + signum = I.signumFp + fromInteger = mkFr + +instance Fractional Fr where + recip = I.recipFp + fromRational = I.fromRationalFp + +instance Eq Fr where + (==) = I.eqFp + +instance Show Fr where + showsPrec = I.showsPrecFp + +-- | Construct an element of Fr from Integer. +{-# INLINE mkFr #-} +mkFr :: Integer -> Fr +mkFr = I.mkFp + +-- | Hash arbitrary message to Fr by computing its SHA256 hash and treating its +-- first 253 bits as the value of Fr. +{-# INLINE hashToFr #-} +hashToFr :: BS.ByteString -> Fr +hashToFr = I.hashToFp + +-- | Convert the element of Fr back to non-negative Integer. +{-# INLINE fromFr #-} +fromFr :: Fr -> Integer +fromFr = I.fromFp + +-- | Modulus of Fr. +{-# NOINLINE fr_modulus #-} +fr_modulus :: Integer +fr_modulus = I.modulus (proxy# :: Proxy# Fr) + +-- | Check if the element of Fr is zero. +{-# INLINE fr_isZero #-} +fr_isZero :: Fr -> Bool +fr_isZero = I.isZero + +-- | Compute square root of the element @a ∈ Fr@. If polynomial @x² - a@ has no +-- roots in Fr, no result is returned. +{-# INLINE fr_squareRoot #-} +fr_squareRoot :: Fr -> Maybe Fr +fr_squareRoot = I.squareRoot + +---------------------------------------- + +-- | Internal +instance I.Prim Fr where + prim_size _ = fromIntegral c_mcl_fp254bnb_fr_size + prim_wrap = Fr + prim_unwrap = unFr + +-- | Internal +instance I.BaseField Fr where + c_limbs _ = fromIntegral c_mcl_fp254bnb_fr_limbs + c_modulus _ = c_mcl_fp254bnb_fr_modulus + c_hash_to _ = c_mcl_fp254bnb_fr_hash_to + c_from_integer _ = c_mcl_fp254bnb_fr_from_integer + c_from_hsint _ = c_mcl_fp254bnb_fr_from_hsint + c_to_integer _ = c_mcl_fp254bnb_fr_to_gmp_integer + +-- | Internal +instance I.HasArith Fr where + c_add _ = c_mcl_fp254bnb_fr_add + c_subtract _ = c_mcl_fp254bnb_fr_subtract + c_multiply _ = c_mcl_fp254bnb_fr_multiply + c_negate _ = c_mcl_fp254bnb_fr_negate + c_invert _ = c_mcl_fp254bnb_fr_invert + c_eq _ = c_mcl_fp254bnb_fr_eq + c_is_zero _ = c_mcl_fp254bnb_fr_is_zero + +-- | Internal +instance I.HasSqrt Fr where + c_sqrt _ = c_mcl_fp254bnb_fr_sqrt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_size" + c_mcl_fp254bnb_fr_size :: CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_limbs" + c_mcl_fp254bnb_fr_limbs :: CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_modulus" + c_mcl_fp254bnb_fr_modulus :: I.MC Integer -> CSize -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_hash_to" + c_mcl_fp254bnb_fr_hash_to :: Ptr CChar -> CSize -> I.MC Fr -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_add" + c_mcl_fp254bnb_fr_add :: I.CC Fr -> I.CC Fr -> I.MC Fr -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_subtract" + c_mcl_fp254bnb_fr_subtract :: I.CC Fr -> I.CC Fr -> I.MC Fr -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_multiply" + c_mcl_fp254bnb_fr_multiply :: I.CC Fr -> I.CC Fr -> I.MC Fr -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_negate" + c_mcl_fp254bnb_fr_negate :: I.CC Fr -> I.MC Fr -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_from_integer" + c_mcl_fp254bnb_fr_from_integer :: I.CC Integer -> GmpSize# -> I.MC Fr -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_from_hsint" + c_mcl_fp254bnb_fr_from_hsint :: Int# -> I.MC Fr -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_invert" + c_mcl_fp254bnb_fr_invert :: I.CC Fr -> I.MC Fr -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_eq" + c_mcl_fp254bnb_fr_eq :: I.CC Fr -> I.CC Fr -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_to_gmp_integer" + c_mcl_fp254bnb_fr_to_gmp_integer :: I.CC Fr -> I.MC Integer -> CSize -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_is_zero" + c_mcl_fp254bnb_fr_is_zero :: I.CC Fr -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_fr_sqrt" + c_mcl_fp254bnb_fr_sqrt :: I.CC Fr -> I.MC Fr -> IO CInt diff --git a/src/MCL/Curves/Fp254BNb/G1.hs b/src/MCL/Curves/Fp254BNb/G1.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb/G1.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Curves.Fp254BNb.G1 + ( G1 + , mkG1 + , mapToG1 + , g1_zero + , g1_isZero + , g1_affineCoords + , g1_getYfromX + , g1_powFr + ) where + +import Control.DeepSeq +import Data.Binary +import Data.Bits +import Data.Group +import Foreign.C.Types +import GHC.Exts +import GHC.Integer.GMP.Internals + +import MCL.Curves.Fp254BNb.Fp +import MCL.Curves.Fp254BNb.Fr +import MCL.Internal.Utils +import qualified MCL.Internal.Group as I +import qualified MCL.Internal.Prim as I + +-- | Subgroup of @E(Fp)@ (i.e. curve points with coordinates in Fp) of order +-- @r@. +data G1 = G1 { unG1 :: I.CC G1 } + +instance Binary G1 where + put = putCurvePoint g1_affineCoords putY + where + putY y = put . cintToBool . fromIntegral $ fromFp y .&. 1 + + get = getCurvePoint g1_zero $ \x y_lsb -> + mkG1 x =<< g1_getYfromX y_lsb x + +instance NFData G1 where + rnf = (`seq` ()) + +instance Eq G1 where + (==) = I.eqG + +instance Show G1 where + showsPrec = I.showsPrecG + +-- | Point addition. +instance Monoid G1 where + mempty = I.zero + mappend = I.plusG + +-- | Note: 'pow' uses const-time method, just as 'g1_powFr'. +instance Group G1 where + invert = I.invertG + pow = flip I.scalarMul + +instance Abelian G1 + +-- | Construct non-zero element of G1 from two coordinates in Fp. If @(X,Y)@ +-- does not lie on G1, no result is returned. +{-# INLINE mkG1 #-} +mkG1 + :: Fp -- ^ X coordinate + -> Fp -- ^ Y coordinate + -> Maybe G1 +mkG1 = I.mkG + +-- | Map an element of Fp to a curve point. Note: @mapToG1 . hashToFp@ does NOT +-- yield generically secure hash function. For more details see page 3 of +-- "Indifferentiable Hashing to Barreto-Naehrig Curves" +-- (). +{-# INLINE mapToG1 #-} +mapToG1 :: Fp -> G1 +mapToG1 = I.mapToG + +-- | Neutral element of G1 (point at infinity). +{-# NOINLINE g1_zero #-} +g1_zero :: G1 +g1_zero = I.zero + +-- | Check if the element of G1 is point at infinity. +{-# INLINE g1_isZero #-} +g1_isZero :: G1 -> Bool +g1_isZero = I.isZero + +-- | Return affine coordinates of the element @a ∈ G1@. No result is returned if +-- @a@ is the point at inifinity. +{-# INLINE g1_affineCoords #-} +g1_affineCoords :: G1 -> Maybe (Fp, Fp) +g1_affineCoords = I.affineCoords + +-- | Attempt to recover Y coordinate from its least significant bit and X +-- coordinate. +{-# INLINE g1_getYfromX #-} +g1_getYfromX + :: Bool -- ^ Least significant bit of Y coordinate + -> Fp -- ^ X coordinate + -> Maybe Fp +g1_getYfromX = I.getYfromX (proxy# :: Proxy# G1) + +-- | Multiply the element of G1 by a scalar @x ∈ Fr@. Note: it uses const-time +-- method, i.e. the time it takes to calculate the result depends only on the +-- bitlength of @x@. +{-# INLINE g1_powFr #-} +g1_powFr :: G1 -> Fr -> G1 +g1_powFr = I.powFr + +---------------------------------------- + +-- | Internal +instance I.Prim G1 where + prim_size _ = fromIntegral c_mcl_fp254bnb_g1_size + prim_wrap = G1 + prim_unwrap = unG1 + +-- | Internal +instance I.CurveGroup Fp G1 where + c_zero _ = c_mcl_fp254bnb_g1_zero + c_construct _ = c_mcl_fp254bnb_g1_construct + c_map_to _ = c_mcl_fp254bnb_g1_map_to + c_add _ = c_mcl_fp254bnb_g1_add + c_invert _ = c_mcl_fp254bnb_g1_invert + c_scalar_mul_native _ = c_mcl_fp254bnb_g1_scalar_mul_native + c_scalar_mul_bignat _ = c_mcl_fp254bnb_g1_scalar_mul + c_scalar_mul_hsint _ = c_mcl_fp254bnb_g1_scalar_mul_small + c_eq _ = c_mcl_fp254bnb_g1_eq + c_is_zero _ = c_mcl_fp254bnb_g1_is_zero + c_affine_coords _ = c_mcl_fp254bnb_g1_affine_coords + c_y_from_x _ = c_mcl_fp254bnb_g1_y_from_x + +foreign import ccall unsafe "hs_mcl_fp254bnb_g1_size" + c_mcl_fp254bnb_g1_size :: CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_g1_zero" + c_mcl_fp254bnb_g1_zero :: I.MC G1 -> IO () + +foreign import ccall safe "hs_mcl_fp254bnb_g1_construct" + c_mcl_fp254bnb_g1_construct :: I.CC Fp -> I.CC Fp -> I.MC G1 -> IO CInt + +foreign import ccall safe "hs_mcl_fp254bnb_g1_map_to" + c_mcl_fp254bnb_g1_map_to :: I.CC Fp -> I.MC G1 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_g1_add" + c_mcl_fp254bnb_g1_add :: I.CC G1 -> I.CC G1 -> I.MC G1 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_g1_invert" + c_mcl_fp254bnb_g1_invert :: I.CC G1 -> I.MC G1 -> IO () + +foreign import ccall safe "hs_mcl_fp254bnb_g1_scalar_mul_native" + c_mcl_fp254bnb_g1_scalar_mul_native :: CInt -> I.CC Fr -> I.CC G1 -> I.MC G1 -> IO () + +foreign import ccall safe "hs_mcl_fp254bnb_g1_scalar_mul" + c_mcl_fp254bnb_g1_scalar_mul :: CInt -> I.CC Integer -> GmpSize# -> CInt + -> I.CC G1 -> I.MC G1 -> IO () + +foreign import ccall safe "hs_mcl_fp254bnb_g1_scalar_mul_small" + c_mcl_fp254bnb_g1_scalar_mul_small :: CInt -> Int# -> I.CC G1 -> I.MC G1 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_g1_eq" + c_mcl_fp254bnb_g1_eq :: I.CC G1 -> I.CC G1 -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_g1_is_zero" + c_mcl_fp254bnb_g1_is_zero :: I.CC G1 -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_g1_affine_coords" + c_mcl_fp254bnb_g1_affine_coords :: I.CC G1 -> I.MC Fp -> I.MC Fp -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_g1_y_from_x" + c_mcl_fp254bnb_g1_y_from_x :: CInt -> I.CC Fp -> I.MC Fp -> IO CInt diff --git a/src/MCL/Curves/Fp254BNb/G2.hs b/src/MCL/Curves/Fp254BNb/G2.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb/G2.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Curves.Fp254BNb.G2 + ( G2 + , mkG2 + , mapToG2 + , g2_zero + , g2_isZero + , g2_affineCoords + , g2_getYfromX + , g2_powFr + ) where + +import Control.DeepSeq +import Data.Binary +import Data.Bits +import Data.Group +import Data.Primitive.ByteArray +import Foreign.C.Types +import GHC.Exts +import GHC.Integer.GMP.Internals + +import MCL.Curves.Fp254BNb.Fp +import MCL.Curves.Fp254BNb.Fp2 +import MCL.Curves.Fp254BNb.Fr +import MCL.Internal.Utils +import qualified MCL.Internal.Group as I +import qualified MCL.Internal.Prim as I + +-- | Subgroup of @E'(Fp2)@ (i.e. curve points with coordinates in Fp2) of order +-- @r@. +data G2 = G2 { unG2 :: I.CC G2 } + +instance Binary G2 where + put = putCurvePoint g2_affineCoords putY + where + putY y = put . cintToBool . fromIntegral $ fromFp (fp2_c0 y) .&. 1 + + get = getCurvePoint g2_zero $ \x y_lsb -> + mkG2 x =<< g2_getYfromX y_lsb x + +instance NFData G2 where + rnf = (`seq` ()) + +instance Eq G2 where + (==) = I.eqG + +instance Show G2 where + showsPrec = I.showsPrecG + +-- | Point addition. +instance Monoid G2 where + mempty = I.zero + mappend = I.plusG + +-- | Note: 'pow' uses const-time method, just as 'g2_powFr'. +instance Group G2 where + invert = I.invertG + pow = flip I.scalarMul + +instance Abelian G2 + +-- | Construct non-zero element of G2 from two coordinates in Fp2. If @(X,Y)@ +-- does not lie on G2, no result is returned. +{-# INLINABLE mkG2 #-} +mkG2 + :: Fp2 -- ^ X coordinate + -> Fp2 -- ^ Y coordinate + -> Maybe G2 +mkG2 = I.mkG + +-- | Map an element of Fp2 to a curve point. +{-# INLINABLE mapToG2 #-} +mapToG2 :: Fp2 -> G2 +mapToG2 = I.mapToG + +-- | Neutral element of G2 (point at infinity). +{-# NOINLINE g2_zero #-} +g2_zero :: G2 +g2_zero = I.zero + +-- | Check if the element of G2 is point at infinity. +{-# INLINABLE g2_isZero #-} +g2_isZero :: G2 -> Bool +g2_isZero = I.isZero + +-- | Return affine coordinates of the element @a ∈ G2@. No result is returned if +-- @a@ is the point at inifinity. +{-# INLINABLE g2_affineCoords #-} +g2_affineCoords :: G2 -> Maybe (Fp2, Fp2) +g2_affineCoords = I.affineCoords + +-- | Attempt to recover Y coordinate from its least significant bit and X +-- coordinate. +{-# INLINABLE g2_getYfromX #-} +g2_getYfromX + :: Bool -- ^ Least significant bit of Y coordinate + -> Fp2 -- ^ X coordinate + -> Maybe Fp2 +g2_getYfromX = I.getYfromX (proxy# :: Proxy# G2) + +-- | Multiply the element of G2 by a scalar @x ∈ Fr@. Note: it uses const-time +-- method, i.e. the time it takes to calculate the result depends only on the +-- bitlength of @x@. +{-# INLINABLE g2_powFr #-} +g2_powFr :: G2 -> Fr -> G2 +g2_powFr = I.powFr + +---------------------------------------- + +-- | Internal +instance I.Prim G2 where + prim_size _ = fromIntegral c_mcl_fp254bnb_g2_size + prim_wrap = G2 + prim_unwrap = unG2 + +-- | Internal +instance I.CurveGroup Fp2 G2 where + c_zero _ = c_mcl_fp254bnb_g2_zero + c_construct _ = c_mcl_fp254bnb_g2_construct + c_map_to _ = c_mcl_fp254bnb_g2_map_to + c_add _ = c_mcl_fp254bnb_g2_add + c_invert _ = c_mcl_fp254bnb_g2_invert + c_scalar_mul_native _ = c_mcl_fp254bnb_g2_scalar_mul_native + c_scalar_mul_bignat _ = c_mcl_fp254bnb_g2_scalar_mul + c_scalar_mul_hsint _ = c_mcl_fp254bnb_g2_scalar_mul_small + c_eq _ = c_mcl_fp254bnb_g2_eq + c_is_zero _ = c_mcl_fp254bnb_g2_is_zero + c_affine_coords _ = c_mcl_fp254bnb_g2_affine_coords + c_y_from_x _ = c_mcl_fp254bnb_g2_y_from_x + +foreign import ccall unsafe "hs_mcl_fp254bnb_g2_size" + c_mcl_fp254bnb_g2_size :: CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_g2_zero" + c_mcl_fp254bnb_g2_zero :: I.MC G2 -> IO () + +foreign import ccall safe "hs_mcl_fp254bnb_g2_construct" + c_mcl_fp254bnb_g2_construct :: I.CC Fp2 -> I.CC Fp2 -> I.MC G2 -> IO CInt + +foreign import ccall safe "hs_mcl_fp254bnb_g2_map_to" + c_mcl_fp254bnb_g2_map_to :: I.CC Fp2 -> I.MC G2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_g2_add" + c_mcl_fp254bnb_g2_add :: I.CC G2 -> I.CC G2 -> I.MC G2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_g2_invert" + c_mcl_fp254bnb_g2_invert :: I.CC G2 -> I.MC G2 -> IO () + +foreign import ccall safe "hs_mcl_fp254bnb_g2_scalar_mul_native" + c_mcl_fp254bnb_g2_scalar_mul_native :: CInt -> I.CC Fr -> I.CC G2 -> I.MC G2 -> IO () + +foreign import ccall safe "hs_mcl_fp254bnb_g2_scalar_mul" + c_mcl_fp254bnb_g2_scalar_mul :: CInt -> ByteArray# -> GmpSize# -> CInt + -> I.CC G2 -> I.MC G2 -> IO () + +foreign import ccall safe "hs_mcl_fp254bnb_g2_scalar_mul_small" + c_mcl_fp254bnb_g2_scalar_mul_small :: CInt -> Int# -> I.CC G2 -> I.MC G2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_g2_eq" + c_mcl_fp254bnb_g2_eq :: I.CC G2 -> I.CC G2 -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_g2_is_zero" + c_mcl_fp254bnb_g2_is_zero :: I.CC G2 -> IO CInt + +foreign import ccall unsafe "hs_mcl_fp254bnb_g2_affine_coords" + c_mcl_fp254bnb_g2_affine_coords :: I.CC G2 -> I.MC Fp2 -> I.MC Fp2 -> IO () + +foreign import ccall unsafe "hs_mcl_fp254bnb_g2_y_from_x" + c_mcl_fp254bnb_g2_y_from_x :: CInt -> I.CC Fp2 -> I.MC Fp2 -> IO CInt diff --git a/src/MCL/Curves/Fp254BNb/GT.hs b/src/MCL/Curves/Fp254BNb/GT.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb/GT.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Curves.Fp254BNb.GT + ( GT + , mkGT + , gt_powFr + ) where + +import Control.DeepSeq +import Data.Binary +import Data.Group +import Foreign.C.Types +import GHC.Exts + +import MCL.Curves.Fp254BNb.Fp12 +import MCL.Curves.Fp254BNb.Fr +import qualified MCL.Internal.Prim as I + +-- | Subgroup of Fp12* of @r@-th roots of unity. +newtype GT = GT_ { unGT :: Fp12 } + deriving (Binary, Eq, NFData) + +instance Show GT where + showsPrec p (GT_ a) = showsPrec p a + +instance Monoid GT where + mempty = GT_ 1 + mappend (GT_ a) (GT_ b) = GT_ (a * b) + +instance Group GT where + invert (GT_ a) = GT_ (recip a) + pow a p = a `gt_powFr` mkFr (toInteger p) + +instance Abelian GT + +-- | Construct an element of GT from @a ∈ Fp12@. If @a@ is not an @r@-th root of +-- unity, no result is returned. +{-# INLINABLE mkGT #-} +mkGT :: Fp12 -> Maybe GT +mkGT a = case a ^ fr_modulus of + 1 -> Just (GT_ a) + _ -> Nothing + +-- | Raise the element of GT to the power @x ∈ Fr@. Note: it uses const-time +-- method, i.e. the time it takes to calculate the result depends only on the +-- bitlength of @x@. +{-# INLINABLE gt_powFr #-} +gt_powFr :: GT -> Fr -> GT +gt_powFr (GT_ a) = GT_ . I.safeOp2_ (c_mcl_fp254bnb_gt_pow_native 1) a + +---------------------------------------- + +-- | Internal +instance I.Prim GT where + prim_size _ = I.prim_size (proxy# :: Proxy# Fp12) + prim_wrap = \ba -> GT_ (I.prim_wrap ba) + prim_unwrap = \gt -> I.prim_unwrap (unGT gt) + +foreign import ccall safe "hs_mcl_fp254bnb_gt_pow_native" + c_mcl_fp254bnb_gt_pow_native :: CInt -> I.CC Fp12 -> I.CC Fr -> I.MC Fp12 -> IO () diff --git a/src/MCL/Curves/Fp254BNb/Pairing.hs b/src/MCL/Curves/Fp254BNb/Pairing.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Curves/Fp254BNb/Pairing.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Curves.Fp254BNb.Pairing (pairing) where + +import MCL.Curves.Fp254BNb.Fp12 +import MCL.Curves.Fp254BNb.G1 +import MCL.Curves.Fp254BNb.G2 +import MCL.Curves.Fp254BNb.GT +import qualified MCL.Internal.Prim as I + +-- | Compute optimal ate pairing. +pairing :: G1 -> G2 -> GT +pairing = I.safeOp2_ c_mcl_fp254bnb_pairing + +foreign import ccall safe "hs_mcl_fp254bnb_pairing" + c_mcl_fp254bnb_pairing :: I.CC G1 -> I.CC G2 -> I.MC Fp12 -> IO () diff --git a/src/MCL/Internal/Field.hs b/src/MCL/Internal/Field.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Internal/Field.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +module MCL.Internal.Field where + +import Data.Ratio +import Data.Typeable +import Foreign.C.Types +import GHC.Exts +import GHC.Integer.GMP.Internals +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +import MCL.Internal.Prim +import MCL.Internal.Utils + +class Prim fp => BaseField fp where + c_limbs :: Proxy# fp -> Int + c_modulus :: Proxy# fp -> MC Integer -> CSize -> IO () + c_hash_to :: Proxy# fp -> Ptr CChar -> CSize -> MC fp -> IO () + c_from_integer :: Proxy# fp -> CC Integer -> GmpSize# -> MC fp -> IO () + c_from_hsint :: Proxy# fp -> Int# -> MC fp -> IO () + c_to_integer :: Proxy# fp -> CC fp -> MC Integer -> CSize -> IO () + +{-# INLINABLE mkFp #-} +mkFp :: forall fp. (BaseField fp, Typeable fp) => Integer -> fp +mkFp n = unsafeOp0_ $ case n `mod` (modulus fp) of + Jp# x@(BN# ba) -> c_from_integer fp ba (sizeofBigNat# x) + Jn# _ -> error $ "mkFp (" ++ fpRep ++ "): n mod p is negative" + S# k -> c_from_hsint fp k + where + fp = proxy# :: Proxy# fp + fpRep = show $ typeRep (Proxy :: Proxy fp) + +{-# INLINABLE hashToFp #-} +hashToFp :: forall fp. BaseField fp => BS.ByteString -> fp +hashToFp bs = unsafeOp0 . BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + newPrim_ $ c_hash_to (proxy# :: Proxy# fp) ptr (fromIntegral len) + +{-# INLINABLE fromFp #-} +fromFp :: forall fp. BaseField fp => fp -> Integer +fromFp = unsafeOp1 (importInteger (c_limbs fp)) (c_to_integer fp) + where + fp = proxy# :: Proxy# fp + +{-# INLINABLE modulus #-} +modulus :: BaseField fp => Proxy# fp -> Integer +modulus fp = unsafeOp0 $ importInteger (c_limbs fp) (c_modulus fp) + +{-# INLINABLE showsPrecFp #-} +showsPrecFp :: BaseField fp => Int -> fp -> ShowS +showsPrecFp p = showsPrec p . fromFp + +---------------------------------------- + +class Prim fp => HasArith fp where + c_add :: Proxy# fp -> CC fp -> CC fp -> MC fp -> IO () + c_subtract :: Proxy# fp -> CC fp -> CC fp -> MC fp -> IO () + c_multiply :: Proxy# fp -> CC fp -> CC fp -> MC fp -> IO () + c_negate :: Proxy# fp -> CC fp -> MC fp -> IO () + c_invert :: Proxy# fp -> CC fp -> MC fp -> IO () + c_eq :: Proxy# fp -> CC fp -> CC fp -> IO CInt + c_is_zero :: Proxy# fp -> CC fp -> IO CInt + +{-# INLINABLE isZero #-} +isZero :: forall fp. HasArith fp => fp -> Bool +isZero = unsafeOp1 (fmap cintToBool) $ c_is_zero (proxy# :: Proxy# fp) + +{-# INLINABLE addFp #-} +addFp :: forall fp. HasArith fp => fp -> fp -> fp +addFp = unsafeOp2_ $ c_add (proxy# :: Proxy# fp) + +{-# INLINABLE subtractFp #-} +subtractFp :: forall fp. HasArith fp => fp -> fp -> fp +subtractFp = unsafeOp2_ $ c_subtract (proxy# :: Proxy# fp) + +{-# INLINABLE multiplyFp #-} +multiplyFp :: forall fp. HasArith fp => fp -> fp -> fp +multiplyFp = unsafeOp2_ $ c_multiply (proxy# :: Proxy# fp) + +{-# INLINABLE negateFp #-} +negateFp :: forall fp. HasArith fp => fp -> fp +negateFp = unsafeOp1_ $ c_negate (proxy# :: Proxy# fp) + +{-# INLINABLE absFp #-} +absFp :: fp -> fp +absFp = id + +{-# INLINABLE signumFp #-} +signumFp :: forall fp. (HasArith fp, Num fp) => fp -> fp +signumFp fp = if isZero fp then fp else 1 + +{-# INLINABLE recipFp #-} +recipFp :: forall fp. HasArith fp => fp -> fp +recipFp = unsafeOp1_ $ c_invert (proxy# :: Proxy# fp) + +{-# INLINABLE fromRationalFp #-} +fromRationalFp :: Fractional fp => Rational -> fp +fromRationalFp r = fromIntegral (numerator r) / fromIntegral (denominator r) + +{-# INLINABLE eqFp #-} +eqFp :: forall fp. HasArith fp => fp -> fp -> Bool +eqFp = unsafeOp2 (fmap cintToBool) $ c_eq (proxy# :: Proxy# fp) + +---------------------------------------- + +class HasArith fp => HasSqrt fp where + c_sqrt :: Proxy# fp -> CC fp -> MC fp -> IO CInt + +{-# INLINABLE squareRoot #-} +squareRoot :: forall fp. HasSqrt fp => fp -> Maybe fp +squareRoot = unsafeOp1 maybeNewPrim $ c_sqrt (proxy# :: Proxy# fp) diff --git a/src/MCL/Internal/Group.hs b/src/MCL/Internal/Group.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Internal/Group.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +module MCL.Internal.Group where + +import Foreign.C.Types +import GHC.Exts +import GHC.Integer.GMP.Internals + +import MCL.Internal.Prim +import MCL.Internal.Utils + +class (Prim fp, Prim g) => CurveGroup fp g | g -> fp where + c_zero :: Proxy# g -> MC g -> IO () + c_construct :: Proxy# g -> CC fp -> CC fp -> MC g -> IO CInt + c_map_to :: Proxy# g -> CC fp -> MC g -> IO () + c_add :: Proxy# g -> CC g -> CC g -> MC g -> IO () + c_invert :: Proxy# g -> CC g -> MC g -> IO () + c_scalar_mul_native :: Proxy# g -> CInt -> CC fr -> CC g -> MC g -> IO () + c_scalar_mul_bignat :: Proxy# g -> CInt -> CC Integer -> GmpSize# + -> CInt -> CC g -> MC g -> IO () + c_scalar_mul_hsint :: Proxy# g -> CInt -> Int# -> CC g -> MC g -> IO () + c_eq :: Proxy# g -> CC g -> CC g -> IO CInt + c_is_zero :: Proxy# g -> CC g -> IO CInt + c_affine_coords :: Proxy# g -> CC g -> MC fp -> MC fp -> IO () + c_y_from_x :: Proxy# g -> CInt -> CC fp -> MC fp -> IO CInt + +{-# INLINABLE mkG #-} +mkG :: forall fp g. CurveGroup fp g => fp -> fp -> Maybe g +mkG = safeOp2 maybeNewPrimPinned $ c_construct (proxy# :: Proxy# g) + +{-# INLINABLE mapToG #-} +mapToG :: forall fp g. CurveGroup fp g => fp -> g +mapToG = safeOp1_ $ c_map_to (proxy# :: Proxy# g) + +{-# INLINABLE zero #-} +zero :: forall fp g. CurveGroup fp g => g +zero = unsafeOp0_ $ c_zero (proxy# :: Proxy# g) + +{-# INLINABLE isZero #-} +isZero :: forall fp g. CurveGroup fp g => g -> Bool +isZero = unsafeOp1 (fmap cintToBool) $ c_is_zero (proxy# :: Proxy# g) + +{-# INLINABLE affineCoords #-} +affineCoords :: forall fp g. CurveGroup fp g => g -> Maybe (fp, fp) +affineCoords fp + | isZero fp = Nothing + | otherwise = Just $ unsafeOp1 new2Prim (c_affine_coords (proxy# :: Proxy# g)) fp + +{-# INLINABLE getYfromX #-} +getYfromX :: CurveGroup fp g => Proxy# g -> Bool -> fp -> Maybe fp +getYfromX g = unsafeOp1 maybeNewPrim . c_y_from_x g . boolToCInt + +{-# INLINABLE powFr #-} +powFr :: forall fp fr g. (CurveGroup fp g, Prim fr) => g -> fr -> g +powFr = safeOp2_ $ \p x -> c_scalar_mul_native (proxy# :: Proxy# g) 1 x p + +{-# INLINABLE eqG #-} +eqG :: forall fp g. CurveGroup fp g => g -> g -> Bool +eqG = unsafeOp2 (fmap cintToBool) $ c_eq (proxy# :: Proxy# g) + +{-# INLINABLE plusG #-} +plusG :: forall fp g. CurveGroup fp g => g -> g -> g +plusG = unsafeOp2_ $ c_add (proxy# :: Proxy# g) + +{-# INLINABLE invertG #-} +invertG :: forall fp g. CurveGroup fp g => g -> g +invertG = unsafeOp1_ $ c_invert (proxy# :: Proxy# g) + +{-# INLINABLE scalarMul #-} +scalarMul :: forall a fp g. (CurveGroup fp g, Integral a) => a -> g -> g +scalarMul n = safeOp1_ $ \p -> case toInteger n of + Jp# x@(BN# ba) -> c_scalar_mul_bignat g 1 ba (sizeofBigNat# x) 0 p + Jn# x@(BN# ba) -> c_scalar_mul_bignat g 1 ba (sizeofBigNat# x) 1 p + S# k -> c_scalar_mul_hsint g 1 k p + where + g = proxy# :: Proxy# g + +{-# INLINABLE showsPrecG #-} +showsPrecG :: forall fp g. (CurveGroup fp g, Show fp) => Int -> g -> ShowS +showsPrecG = \p -> maybe ("0" ++) (showsPrec p) . affineCoords diff --git a/src/MCL/Internal/Prim.hs b/src/MCL/Internal/Prim.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Internal/Prim.hs @@ -0,0 +1,9 @@ +module MCL.Internal.Prim + ( module MCL.Internal.Prim.Class + , module MCL.Internal.Prim.Pinned + , module MCL.Internal.Prim.Unpinned + ) where + +import MCL.Internal.Prim.Class +import MCL.Internal.Prim.Pinned +import MCL.Internal.Prim.Unpinned diff --git a/src/MCL/Internal/Prim/Class.hs b/src/MCL/Internal/Prim/Class.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Internal/Prim/Class.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MagicHash #-} +module MCL.Internal.Prim.Class where + +import Data.Primitive.ByteArray +import GHC.Exts + +-- | C representation of a const MCL object or Integer. +type CC t = ByteArray# + +-- | C representation of a mutable MCL object or Integer. +type MC t = MutableByteArray# RealWorld + +class Prim t where + prim_size :: Proxy# t -> Int + prim_wrap :: CC t -> t + prim_unwrap :: t -> CC t diff --git a/src/MCL/Internal/Prim/Pinned.hs b/src/MCL/Internal/Prim/Pinned.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Internal/Prim/Pinned.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +module MCL.Internal.Prim.Pinned where + +import Data.Functor.Identity +import Data.Primitive.ByteArray +import Foreign.C.Types +import GHC.Exts +import System.IO.Unsafe + +import MCL.Internal.Prim.Class +import MCL.Internal.Utils + +-- | Pass pinned copy of the object to a safe C function. +{-# INLINABLE withPrimPinned #-} +withPrimPinned :: Prim t => t -> (CC t -> IO r) -> IO r +withPrimPinned fp k = do + ByteArray ba <- pinnedByteArrayCopy $ ByteArray (prim_unwrap fp) + k ba + where + pinnedByteArrayCopy :: ByteArray -> IO ByteArray + pinnedByteArrayCopy src = do + mdest <- newPinnedByteArray srcSize + copyByteArray mdest 0 src 0 srcSize + unsafeFreezeByteArray mdest + where + srcSize = sizeofByteArray src + +-- | Use pinned memory to get a result from a safe C function. +{-# INLINABLE newPrimPinned #-} +newPrimPinned + :: forall m t r. Prim t + => (r -> CC t -> m t) + -> (MC t -> IO r) + -> IO (m t) +newPrimPinned = withPinnedByteArray1 (prim_size (proxy# :: Proxy# t)) + +{-# INLINABLE newPrimPinned_ #-} +newPrimPinned_ :: forall t. Prim t => (MC t -> IO ()) -> IO t +newPrimPinned_ = unwrap . newPrimPinned (\_ ba -> Identity (prim_wrap ba)) + where + unwrap :: IO (Identity t) -> IO t + unwrap = coerce + +{-# INLINABLE maybeNewPrimPinned #-} +maybeNewPrimPinned :: Prim t => (MC t -> IO CInt) -> IO (Maybe t) +maybeNewPrimPinned = newPrimPinned $ \success ba -> + if cintToBool success + then Just (prim_wrap ba) + else Nothing + +---------------------------------------- + +{-# INLINABLE safeOp0 #-} +safeOp0 :: IO r -> r +safeOp0 = unsafeDupablePerformIO + +{-# INLINABLE safeOp1 #-} +safeOp1 + :: Prim t + => (s -> IO r) + -> (CC t -> s) + -> (t -> r) +safeOp1 k c_fun fa = + safeOp0 . withPrimPinned fa $ \a -> k (c_fun a) + +{-# INLINABLE safeOp1_ #-} +safeOp1_ + :: (Prim t, Prim r) + => (CC t -> MC r -> IO ()) + -> (t -> r) +safeOp1_ = safeOp1 newPrimPinned_ + +{-# INLINABLE safeOp2 #-} +safeOp2 + :: (Prim t1, Prim t2) + => (s -> IO r) + -> (CC t1 -> CC t2 -> s) + -> (t1 -> t2 -> r) +safeOp2 k c_fun fa fb = + safeOp0 . withPrimPinned fa $ \a -> withPrimPinned fb $ \b -> k (c_fun a b) + +{-# INLINABLE safeOp2_ #-} +safeOp2_ + :: (Prim t1, Prim t2, Prim r) + => (CC t1 -> CC t2 -> MC r -> IO ()) + -> (t1 -> t2 -> r) +safeOp2_ = safeOp2 newPrimPinned_ + +---------------------------------------- +-- Utils + +{-# INLINABLE withPinnedByteArray1 #-} +withPinnedByteArray1 + :: Int + -> (s -> ByteArray# -> r) + -> (MutableByteArray# RealWorld -> IO s) + -> IO r +withPinnedByteArray1 size k c_fun = do + mba@(MutableByteArray umba) <- newPinnedByteArray size + r <- c_fun umba + ByteArray uba <- unpinnedFreezeByteArray mba + return (k r uba) + where + unpinnedFreezeByteArray :: MutableByteArray RealWorld -> IO ByteArray + unpinnedFreezeByteArray src = do + mdest <- newByteArray srcSize + copyMutableByteArray mdest 0 src 0 srcSize + unsafeFreezeByteArray mdest + where + srcSize = sizeofMutableByteArray src diff --git a/src/MCL/Internal/Prim/Unpinned.hs b/src/MCL/Internal/Prim/Unpinned.hs new file mode 100644 --- /dev/null +++ b/src/MCL/Internal/Prim/Unpinned.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +module MCL.Internal.Prim.Unpinned where + +import Data.Functor.Identity +import Data.Primitive.ByteArray +import Foreign.C.Types +import GHC.Exts +import System.IO.Unsafe + +import MCL.Internal.Prim.Class +import MCL.Internal.Utils + +{-# INLINABLE withPrim #-} +withPrim :: Prim t => t -> (CC t -> IO r) -> IO r +withPrim fp k = k (prim_unwrap fp) + +{-# INLINABLE newPrim #-} +newPrim + :: forall m t r. Prim t + => (r -> CC t -> m t) + -> (MC t -> IO r) + -> IO (m t) +newPrim = withByteArray1 (prim_size (proxy# :: Proxy# t)) + +{-# INLINABLE newPrim_ #-} +newPrim_ :: forall t. Prim t => (MC t -> IO ()) -> IO t +newPrim_ = unwrap . newPrim (\_ ba -> Identity (prim_wrap ba)) + where + unwrap :: IO (Identity t) -> IO t + unwrap = coerce + +{-# INLINABLE maybeNewPrim #-} +maybeNewPrim :: Prim t => (MC t -> IO CInt) -> IO (Maybe t) +maybeNewPrim = newPrim $ \success ba -> + if cintToBool success + then Just (prim_wrap ba) + else Nothing + +{-# INLINABLE new2Prim #-} +new2Prim :: forall t. Prim t => (MC t -> MC t -> IO ()) -> IO (t, t) +new2Prim = withByteArray2 (prim_size (proxy# :: Proxy# t)) prim_wrap + +---------------------------------------- + +{-# INLINABLE unsafeOp0 #-} +unsafeOp0 :: IO r -> r +unsafeOp0 = unsafeDupablePerformIO + +{-# INLINABLE unsafeOp0_ #-} +unsafeOp0_ :: Prim r => (MC r -> IO ()) -> r +unsafeOp0_ = unsafeOp0 . newPrim_ + +{-# INLINABLE unsafeOp1 #-} +unsafeOp1 + :: Prim t + => (s -> IO r) + -> (CC t -> s) + -> (t -> r) +unsafeOp1 k c_fun fa = + unsafeOp0 . withPrim fa $ \a -> k (c_fun a) + +{-# INLINABLE unsafeOp1_ #-} +unsafeOp1_ + :: (Prim t, Prim r) + => (CC t -> MC r -> IO ()) + -> (t -> r) +unsafeOp1_ = unsafeOp1 newPrim_ + +{-# INLINABLE unsafeOp2 #-} +unsafeOp2 + :: (Prim t1, Prim t2) + => (s -> IO r) + -> (CC t1 -> CC t2 -> s) + -> (t1 -> t2 -> r) +unsafeOp2 k c_fun fa fb = + unsafeOp0 . withPrim fa $ \a -> withPrim fb $ \b -> k (c_fun a b) + +{-# INLINABLE unsafeOp2_ #-} +unsafeOp2_ + :: (Prim t1, Prim t2, Prim r) + => (CC t1 -> CC t2 -> MC r -> IO ()) + -> (t1 -> t2 -> r) +unsafeOp2_ = unsafeOp2 newPrim_ + +{-# INLINABLE unsafeOp6 #-} +unsafeOp6 + :: (Prim t1, Prim t2, Prim t3, Prim t4, Prim t5, Prim t6) + => (s -> IO r) + -> (CC t1 -> CC t2 -> CC t3 -> CC t4 -> CC t5 -> CC t6 -> s) + -> (t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> r) +unsafeOp6 k c_fun fa fb fc fd fe ff = + unsafeOp0 . withPrim fa $ \a -> withPrim fb $ \b -> withPrim fc $ \c -> + withPrim fd $ \d -> withPrim fe $ \e -> withPrim ff $ \f -> + k (c_fun a b c d e f) + +{-# INLINABLE unsafeOp6_ #-} +unsafeOp6_ + :: (Prim t1, Prim t2, Prim t3, Prim t4, Prim t5, Prim t6, Prim r) + => (CC t1 -> CC t2 -> CC t3 -> CC t4 -> CC t5 -> CC t6 -> MC r -> IO ()) + -> (t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> r) +unsafeOp6_ = unsafeOp6 newPrim_ + +---------------------------------------- +-- Utils + +{-# INLINABLE withByteArray1 #-} +withByteArray1 + :: Int + -> (s -> ByteArray# -> r) + -> (MutableByteArray# RealWorld -> IO s) + -> IO r +withByteArray1 size k c_fun = do + mba@(MutableByteArray umba) <- newByteArray size + r <- c_fun umba + ByteArray uba <- unsafeFreezeByteArray mba + return (k r uba) + +{-# INLINABLE withByteArray2 #-} +withByteArray2 + :: Int + -> (ByteArray# -> r) + -> (MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> IO ()) + -> IO (r, r) +withByteArray2 size k c_fun = do + mba@(MutableByteArray umba) <- newByteArray size + mbb@(MutableByteArray umbb) <- newByteArray size + c_fun umba umbb + ByteArray uba <- unsafeFreezeByteArray mba + ByteArray ubb <- unsafeFreezeByteArray mbb + return (k uba, k ubb) diff --git a/src/MCL/Internal/Utils.hsc b/src/MCL/Internal/Utils.hsc new file mode 100644 --- /dev/null +++ b/src/MCL/Internal/Utils.hsc @@ -0,0 +1,100 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +module MCL.Internal.Utils + ( cintToBool + , boolToCInt + , putBytesFx + , getBytesFx + , putCurvePoint + , getCurvePoint + , importInteger + ) where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Bits +import Data.List +import Data.Primitive.ByteArray +import Data.Typeable +import Foreign.C.Types +import GHC.Exts +import GHC.Integer.GMP.Internals + +#include + +{-# INLINE cintToBool #-} +cintToBool :: CInt -> Bool +cintToBool 0 = False +cintToBool _ = True + +{-# INLINE boolToCInt #-} +boolToCInt :: Bool -> CInt +boolToCInt False = 0 +boolToCInt True = 1 + +{-# INLINABLE putBytesFx #-} +putBytesFx :: Int -> Integer -> Put +putBytesFx 0 _ = return () +putBytesFx n k = do + putWord64le (fromIntegral k) + putBytesFx (n - 8) (k `shiftR` 64) + +{-# INLINABLE getBytesFx #-} +getBytesFx :: Int -> Get Integer +getBytesFx n = foldl' assemble 0 <$> collect [] (n `div` 8) + where + collect acc 0 = return acc + collect acc k = do + w <- getWord64le + collect (w : acc) (k - 1) + + assemble :: Integer -> Word64 -> Integer + assemble acc w = acc `shiftL` 64 .|. fromIntegral w + +{-# INLINABLE putCurvePoint #-} +putCurvePoint + :: Binary x + => (g -> Maybe (x, y)) + -> (y -> Put) + -> g + -> Put +putCurvePoint affineCoords putY p = case affineCoords p of + Nothing -> putWord8 0 + Just (x, y) -> putWord8 1 >> put x >> putY y + +{-# INLINABLE getCurvePoint #-} +getCurvePoint + :: (Typeable g, Binary x, Binary y) + => g + -> (x -> y -> Maybe g) + -> Get g +getCurvePoint zero mkG = getWord8 >>= \case + 0 -> return zero + 1 -> do + x <- get + y <- get + case mkG x y of + Nothing -> fail $ errPrefix ++ "invalid point" + Just p -> return p + n -> fail $ errPrefix ++ "expected 0 or 1, got " ++ show n + where + errPrefix = "getCurvePoint (" ++ show (typeOf zero) ++ "): " + +---------------------------------------- + +{-# INLINABLE importInteger #-} +importInteger + :: Int + -> (MutableByteArray## RealWorld -> CSize -> IO ()) + -> IO Integer +importInteger limbs c_fun = do + mba@(MutableByteArray umba) <- newByteArray size + let csize = fromIntegral size + c_fun umba csize + ByteArray uba <- unsafeFreezeByteArray mba + return $ Jp## (BN## uba) + where + size = limbs * #{size mp_limb_t} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,159 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import Data.Binary +import Data.Bits +import Data.Group +import Data.List +import Data.Monoid +import Data.Proxy +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck hiding ((.&.)) + +import MCL.Curves.Fp254BNb + +main :: IO () +main = defaultMain + [ testGroup "Fr" $ let fr = Proxy :: Proxy Fr in + [ testProperty "arithmetic" $ testFieldOps fr + , testProperty "construction" $ fr_testFromTo + , testProperty "square root" $ fr_testSquareRoot + , testProperty "serialization" $ testBinary fr + ] + , testGroup "Fp" $ let fp = Proxy :: Proxy Fp in + [ testProperty "arithmetic" $ testFieldOps fp + , testProperty "construction" $ fp_testFromTo + , testProperty "square root" $ fp_testSquareRoot + , testProperty "serialization" $ testBinary fp + ] + , testGroup "Fp2" $ let fp2 = Proxy :: Proxy Fp2 in + [ testProperty "arithmetic" $ testFieldOps fp2 + , testProperty "construction" $ fp2_testFromTo + , testProperty "square root" $ fp2_testSquareRoot + , testProperty "serialization" $ testBinary fp2 + ] + , testGroup "Fp12" $ let fp12 = Proxy :: Proxy Fp12 in + [ testProperty "arithmetic" $ testFieldOps fp12 + , testProperty "construction" $ fp12_testFromTo + , testProperty "serialization" $ testBinary fp12 + ] + , testGroup "G1" $ let g1 = Proxy :: Proxy G1 in + [ testProperty "arithmetic" $ testGroupOps g1 + , testProperty "serialization" $ testBinary g1 + ] + , testGroup "G2" $ let g2 = Proxy :: Proxy G2 in + [ testProperty "arithmetic" $ testGroupOps g2 + , testProperty "serialization" $ testBinary g2 + ] + , testGroup "pairing" + [ testProperty "bilinearity" $ testPairing + ] + ] + +---------------------------------------- + +arbitraryF :: (Integer -> fp) -> Gen fp +arbitraryF mkF = do + w1 <- (0x1fffffff .&.) <$> arbitrary + w2 <- arbitrary + w3 <- arbitrary + w4 <- arbitrary + return . mkF $ foldl' assemble 0 [w1, w2, w3, w4] + where + assemble :: Integer -> Word64 -> Integer + assemble acc w = acc `shiftL` 64 .|. fromIntegral w + +instance Arbitrary Fr where + arbitrary = arbitraryF mkFr + +instance Arbitrary Fp where + arbitrary = arbitraryF mkFp + +instance Arbitrary Fp2 where + arbitrary = mkFp2 <$> arbitrary <*> arbitrary + +instance Arbitrary Fp12 where + arbitrary = mkFp12 <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary G1 where + arbitrary = mapToG1 <$> arbitrary + +instance Arbitrary G2 where + arbitrary = mapToG2 <$> arbitrary + +---------------------------------------- + +testFieldOps + :: forall proxy fp. (Arbitrary fp, Eq fp, Fractional fp, Show fp) + => proxy fp + -> Property +testFieldOps _ = conjoin + [ property $ \(a::fp) b c -> (a + b) + c == a + (b + c) + , property $ \(a::fp) b -> a + b == b + a + , property $ \(a::fp) b -> a - b == -(b - a) + , property $ \(a::fp) b c -> a * (b + c) == a * b + a * c + , property $ \(a::fp) b c -> (a + b) * c == a * c + b * c + , property $ \(a::fp) -> a == -(-a) + , property $ \(a::fp) -> recip (recip a) == a + ] + +testGroupOps + :: forall proxy g. (Arbitrary g, Eq g, Abelian g, Show g) + => proxy g + -> Property +testGroupOps _ = conjoin + [ property $ \(a::g) -> (a <> mempty) == a + , property $ \(a::g) -> (mempty <> a) == a + , property $ \(a::g) b c -> (a <> b) <> c == a <> (b <> c) + , property $ \(a::g) b -> a <> b == b <> a + , property $ \(a::g) b -> a <> invert b == invert (b <> invert a) + , property $ \(a::g) b (c::Int) -> (a <> b) `pow` c == a `pow` c <> b `pow` c + , property $ \(a::g) -> a == invert (invert a) + ] + +testBinary + :: forall proxy a. (Arbitrary a, Binary a, Eq a, Show a) + => proxy a + -> Property +testBinary _ = property $ \(a::a) -> decode (encode a) == a + +testPairing :: Property +testPairing = conjoin + [ property $ \p q r s -> pairing (p <> q) (r <> s) == pairing p r <> pairing p s + <> pairing q r <> pairing q s + ] + +---------------------------------------- + +fr_testFromTo :: Fr -> Bool +fr_testFromTo a = a == mkFr (fromFr a) + +fp_testFromTo :: Fp -> Bool +fp_testFromTo a = a == mkFp (fromFp a) + +fp2_testFromTo :: Fp2 -> Bool +fp2_testFromTo a = a == mkFp2 (fp2_c0 a) (fp2_c1 a) + +fp12_testFromTo :: Fp12 -> Bool +fp12_testFromTo a = a == mkFp12 (fp12_c0 a) (fp12_c1 a) (fp12_c2 a) + (fp12_c3 a) (fp12_c4 a) (fp12_c5 a) + +---------------------------------------- + +fr_testSquareRoot :: Fr -> Bool +fr_testSquareRoot a = t == Just a || t == Just (-a) + where + t = fr_squareRoot (a * a) + +fp_testSquareRoot :: Fp -> Bool +fp_testSquareRoot a = t == Just a || t == Just (-a) + where + t = fp_squareRoot (a * a) + +fp2_testSquareRoot :: Fp2 -> Bool +fp2_testSquareRoot a = t == Just a || t == Just (-a) + where + t = fp2_squareRoot (a * a)