From e0e7349b611f409571fe037eeda236e409f9bf85 Mon Sep 17 00:00:00 2001 From: Stephen Diehl Date: Wed, 11 Jul 2018 11:05:24 +0100 Subject: [PATCH] Initial release. --- .gitignore | 3 + Bulletproofs/Curve.hs | 79 +++++++++ Bulletproofs/Fq.hs | 110 ++++++++++++ Bulletproofs/InnerProductProof.hs | 13 ++ Bulletproofs/InnerProductProof/Internal.hs | 42 +++++ Bulletproofs/InnerProductProof/Prover.hs | 162 +++++++++++++++++ Bulletproofs/InnerProductProof/Verifier.hs | 75 ++++++++ Bulletproofs/RangeProof.hs | 14 ++ Bulletproofs/RangeProof/Internal.hs | 196 +++++++++++++++++++++ Bulletproofs/RangeProof/Prover.hs | 159 +++++++++++++++++ Bulletproofs/RangeProof/Verifier.hs | 83 +++++++++ Bulletproofs/Utils.hs | 94 ++++++++++ ChangeLog.md | 5 + LICENSE | 30 ++++ README.md | 144 +++++++++++++++ Setup.hs | 2 + circle.yml | 16 ++ package.yaml | 66 +++++++ stack.yaml | 65 +++++++ tests/TestCommon.hs | 53 ++++++ tests/TestDriver.hs | 1 + tests/TestField.hs | 67 +++++++ tests/TestProtocol.hs | 186 +++++++++++++++++++ 23 files changed, 1665 insertions(+) create mode 100644 .gitignore create mode 100644 Bulletproofs/Curve.hs create mode 100644 Bulletproofs/Fq.hs create mode 100644 Bulletproofs/InnerProductProof.hs create mode 100644 Bulletproofs/InnerProductProof/Internal.hs create mode 100644 Bulletproofs/InnerProductProof/Prover.hs create mode 100644 Bulletproofs/InnerProductProof/Verifier.hs create mode 100644 Bulletproofs/RangeProof.hs create mode 100644 Bulletproofs/RangeProof/Internal.hs create mode 100644 Bulletproofs/RangeProof/Prover.hs create mode 100644 Bulletproofs/RangeProof/Verifier.hs create mode 100644 Bulletproofs/Utils.hs create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 circle.yml create mode 100644 package.yaml create mode 100644 stack.yaml create mode 100644 tests/TestCommon.hs create mode 100644 tests/TestDriver.hs create mode 100644 tests/TestField.hs create mode 100644 tests/TestProtocol.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..eb8527f --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +bulletproofs.cabal +*~ \ No newline at end of file diff --git a/Bulletproofs/Curve.hs b/Bulletproofs/Curve.hs new file mode 100644 index 0000000..20e7749 --- /dev/null +++ b/Bulletproofs/Curve.hs @@ -0,0 +1,79 @@ +module Bulletproofs.Curve where + +import Protolude hiding (hash) + +import Crypto.Hash +import qualified Crypto.PubKey.ECC.Generate as Crypto +import qualified Crypto.PubKey.ECC.Prim as Crypto +import qualified Crypto.PubKey.ECC.Types as Crypto + +import qualified Data.ByteArray as BA +import Crypto.Number.Serialize (os2ip) +import Math.NumberTheory.Moduli.Sqrt (sqrtModP) + +-- TEST +import Numeric +import qualified Data.List as L + +curveName :: Crypto.CurveName +curveName = Crypto.SEC_p256k1 + +curve :: Crypto.Curve +curve = Crypto.getCurveByName curveName + +-- | Order of the curve +q :: Integer +q = Crypto.ecc_n . Crypto.common_curve $ curve + +-- | Generator of the curve +g :: Crypto.Point +g = Crypto.ecc_g $ Crypto.common_curve curve + +-- | H = aG where a is not known +h :: Crypto.Point +h = generateH g "" + +-- | Generate vector of generators in a deterministic way from the curve generator g +-- by applying H(encode(g) || i) where H is a secure hash function +gs :: [Crypto.Point] +gs = Crypto.pointBaseMul curve . oracle . (<> pointToBS g) . show <$> [1..] + +-- | Generate vector of generators in a deterministic way from the curve generator h +-- by applying H(encode(h) || i) where H is a secure hash function +hs :: [Crypto.Point] +hs = Crypto.pointBaseMul curve . oracle . (<> pointToBS h) . show <$> [1..] + +-- | A random oracle. In the Fiat-Shamir heuristic, its input +-- is specifically the transcript of the interaction up to that point. +oracle :: ByteString -> Integer +oracle x = os2ip (sha256 x) + +sha256 :: ByteString -> ByteString +sha256 bs = BA.convert (hash bs :: Digest SHA3_256) + +pointToBS :: Crypto.Point -> ByteString +pointToBS Crypto.PointO = "" +pointToBS (Crypto.Point x y) = show x <> show y + +-- | Characteristic of the underlying finite field of the elliptic curve +p :: Integer +p = Crypto.ecc_p cp + where + cp = case curve of + Crypto.CurveFP c -> c + Crypto.CurveF2m _ -> panic "Not a FP curve" + +-- | Iterative algorithm to generate H. +-- The important thing about the H value is that nobody gets +-- to know its discrete logarithm "k" such that H = kG +generateH :: Crypto.Point -> [Char] -> Crypto.Point +generateH basePoint extra = + case yM of + Nothing -> generateH basePoint (toS $ '1':extra) + Just y -> if Crypto.isPointValid curve (Crypto.Point x y) + then Crypto.Point x y + else generateH basePoint (toS $ '1':extra) + where + x = oracle (pointToBS basePoint <> toS extra) `mod` p + yM = sqrtModP (x ^ 3 + 7) p + diff --git a/Bulletproofs/Fq.hs b/Bulletproofs/Fq.hs new file mode 100644 index 0000000..db6c6e5 --- /dev/null +++ b/Bulletproofs/Fq.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Bulletproofs.Fq where + +import Protolude + +import Crypto.Random (MonadRandom) +import Crypto.Number.Generate (generateMax) + +import Bulletproofs.Curve + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | Prime field with characteristic @_q@ +newtype Fq = Fq Integer -- ^ Use @new@ instead of this constructor + deriving (Show, Eq, Bits, Ord) + +instance Num Fq where + (+) = fqAdd + (*) = fqMul + abs = panic "There is no absolute value in a finite field" + signum = panic "This function doesn't make sense in a finite field" + negate = fqNeg + fromInteger = new + +instance Fractional Fq where + (/) = fqDiv + fromRational (a :% b) = Fq a / Fq b + +-- | Turn an integer into an @Fq@ number, should be used instead of +-- the @Fq@ constructor. +new :: Integer -> Fq +new a = Fq (a `mod` q) + +{-# INLINE norm #-} +norm :: Fq -> Fq +norm (Fq a) = Fq (a `mod` q) + +{-# INLINE fqAdd #-} +fqAdd :: Fq -> Fq -> Fq +fqAdd (Fq a) (Fq b) = norm (Fq (a+b)) + +{-# INLINE fqMul #-} +fqMul :: Fq -> Fq -> Fq +fqMul (Fq a) (Fq b) = norm (Fq (a*b)) + +{-# INLINE fqNeg #-} +fqNeg :: Fq -> Fq +fqNeg (Fq a) = Fq ((-a) `mod` q) + +{-# INLINE fqDiv #-} +fqDiv :: Fq -> Fq -> Fq +fqDiv a b = fqMul a (inv b) + +{-# INLINE fqInv #-} +-- | Multiplicative inverse +fqInv :: Fq -> Fq +fqInv x = 1 / x + +{-# INLINE fqZero #-} +-- | Additive identity +fqZero :: Fq +fqZero = Fq 0 + +{-# INLINE fqOne #-} +-- | Multiplicative identity +fqOne :: Fq +fqOne = Fq 1 + +fqSquare :: Fq -> Fq +fqSquare x = fqMul x x + +fqCube :: Fq -> Fq +fqCube x = fqMul x (fqMul x x) + +inv :: Fq -> Fq +inv (Fq a) = Fq $ euclidean a q `mod` q + +asInteger :: Fq -> Integer +asInteger (Fq n) = n + +-- | Euclidean algorithm to compute inverse in an integral domain @a@ +euclidean :: (Integral a) => a -> a -> a +euclidean a b = fst (inv' a b) + +{-# INLINEABLE inv' #-} +{-# SPECIALISE inv' :: Integer -> Integer -> (Integer, Integer) #-} +inv' :: (Integral a) => a -> a -> (a, a) +inv' a b = + case b of + 1 -> (0, 1) + _ -> let (e, f) = inv' b d + in (f, e - c*f) + where c = a `div` b + d = a `mod` b + +random :: MonadRandom m => Integer -> m Fq +random n = Fq <$> generateMax (2^n) + +fqAddV :: [Fq] -> [Fq] -> [Fq] +fqAddV = zipWith (+) + +fqSubV :: [Fq] -> [Fq] -> [Fq] +fqSubV = zipWith (-) + +fqMulV :: [Fq] -> [Fq] -> [Fq] +fqMulV = zipWith (*) + diff --git a/Bulletproofs/InnerProductProof.hs b/Bulletproofs/InnerProductProof.hs new file mode 100644 index 0000000..a0b4945 --- /dev/null +++ b/Bulletproofs/InnerProductProof.hs @@ -0,0 +1,13 @@ +module Bulletproofs.InnerProductProof +( generateProof +, verifyProof + +, InnerProductProof(..) +, InnerProductBase(..) +, InnerProductWitness(..) +) where + + +import Bulletproofs.InnerProductProof.Internal +import Bulletproofs.InnerProductProof.Prover +import Bulletproofs.InnerProductProof.Verifier diff --git a/Bulletproofs/InnerProductProof/Internal.hs b/Bulletproofs/InnerProductProof/Internal.hs new file mode 100644 index 0000000..d55e3f8 --- /dev/null +++ b/Bulletproofs/InnerProductProof/Internal.hs @@ -0,0 +1,42 @@ +module Bulletproofs.InnerProductProof.Internal where + +import Protolude + +import qualified Crypto.PubKey.ECC.Types as Crypto +import Bulletproofs.Fq + +data InnerProductProof + = InnerProductProof + { lCommits :: [Crypto.Point] + -- ^ Vector of commitments of the elements in the original vector l + -- whose size is the logarithm of base 2 of the size of vector l + , rCommits :: [Crypto.Point] + -- ^ Vector of commitments of the elements in the original vector r + -- whose size is the logarithm of base 2 of the size of vector r + , l :: Fq + -- ^ Remaining element of vector l at the end of + -- the recursive algorithm that generates the inner-product proof + , r :: Fq + -- ^ Remaining element of vector r at the end of + -- the recursive algorithm that generates the inner-product proof + } deriving (Show, Eq) + +data InnerProductWitness + = InnerProductWitness + { ls :: [Fq] + -- ^ Vector of values l that the prover uses to compute lCommits + -- in the recursive inner product algorithm + , rs :: [Fq] + -- ^ Vector of values r that the prover uses to compute rCommits + -- in the recursive inner product algorithm + } deriving (Show, Eq) + +data InnerProductBase + = InnerProductBase + { bGs :: [Crypto.Point] -- ^ Independent generator Gs ∈ G^n + , bHs :: [Crypto.Point] -- ^ Independent generator Hs ∈ G^n + , bH :: Crypto.Point + -- ^ Internally fixed group element H ∈ G + -- for which there is no known discrete-log relation among Gs, Hs, bG + } deriving (Show, Eq) + diff --git a/Bulletproofs/InnerProductProof/Prover.hs b/Bulletproofs/InnerProductProof/Prover.hs new file mode 100644 index 0000000..f75ef79 --- /dev/null +++ b/Bulletproofs/InnerProductProof/Prover.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NamedFieldPuns, MultiWayIf #-} + +module Bulletproofs.InnerProductProof.Prover +( generateProof +) where + +import Protolude + +import qualified Data.List as L +import qualified Data.Map as Map + +import qualified Crypto.PubKey.ECC.Types as Crypto + +import Bulletproofs.Curve +import Bulletproofs.Utils +import Bulletproofs.Fq as Fq + +import Bulletproofs.InnerProductProof.Internal + +-- | Generate proof that a witness l, r satisfies the inner product relation +-- on public input (Gs, Hs, h) +generateProof + :: InnerProductBase -- ^ Generators Gs, Hs, h + -> Crypto.Point + -- ^ Commitment P = A + xS − zG + (z*y^n + z^2 * 2^n) * hs' of vectors l and r + -- whose inner product is t + -> InnerProductWitness + -- ^ Vectors l and r that hide bit vectors aL and aR, respectively + -> InnerProductProof +generateProof productBase commitmentLR witness + = generateProof' productBase commitmentLR witness [] [] + +generateProof' + :: InnerProductBase + -> Crypto.Point + -> InnerProductWitness + -> [Crypto.Point] + -> [Crypto.Point] + -> InnerProductProof +generateProof' + InnerProductBase{ bGs, bHs, bH } + commitmentLR + InnerProductWitness{ ls, rs } + lCommits + rCommits + = case (ls, rs) of + ([l], [r]) -> InnerProductProof (reverse lCommits) (reverse rCommits) l r + _ -> if | not checkLGs -> panic "Error in: l' * Gs' == l * Gs + x^2 * A_L + x^(-2) * A_R" + | not checkRHs -> panic "Error in: r' * Hs' == r * Hs + x^2 * B_L + x^(-2) * B_R" + | not checkLBs -> panic "Error in: l' * r' == l * r + x^2 * (lsLeft * rsRight) + x^-2 * (lsRight * rsLeft)" + | not checkC -> panic "Error in: C == zG + aG + bH'" + | not checkC' -> panic "Error in: C' = C + x^2 L + x^-2 R == z'G + a'G + b'H'" + | otherwise -> generateProof' + InnerProductBase { bGs = gs'', bHs = hs'', bH = bH } + commitmentLR' + InnerProductWitness { ls = ls', rs = rs' } + (lCommit:lCommits) + (rCommit:rCommits) + where + n' = fromIntegral $ length ls + nPrime = n' `div` 2 + + (lsLeft, lsRight) = splitAt nPrime ls + (rsLeft, rsRight) = splitAt nPrime rs + (gsLeft, gsRight) = splitAt nPrime bGs + (hsLeft, hsRight) = splitAt nPrime bHs + + cL = dotp lsLeft rsRight + cR = dotp lsRight rsLeft + + lCommit = foldl' addP Crypto.PointO (zipWith mulP lsLeft gsRight) + `addP` + foldl' addP Crypto.PointO (zipWith mulP rsRight hsLeft) + `addP` + (cL `mulP` bH) + + rCommit = foldl' addP Crypto.PointO (zipWith mulP lsRight gsLeft) + `addP` + foldl' addP Crypto.PointO (zipWith mulP rsLeft hsRight) + `addP` + (cR `mulP` bH) + + x = shamirX' commitmentLR lCommit rCommit + + xInv = inv x + xs = replicate nPrime x + xsInv = replicate nPrime xInv + + gs'' = zipWith addP (zipWith mulP xsInv gsLeft) (zipWith mulP xs gsRight) + hs'' = zipWith addP (zipWith mulP xs hsLeft) (zipWith mulP xsInv hsRight) + + ls' = ((*) x <$> lsLeft) `fqAddV` ((*) xInv <$> lsRight) + rs' = ((*) xInv <$> rsLeft) `fqAddV` ((*) x <$> rsRight) + + commitmentLR' + = (fqSquare x `mulP` lCommit) + `addP` + (fqSquare xInv `mulP` rCommit) + `addP` + commitmentLR + + ----------------------------- + -- Checks + ----------------------------- + + aL' = foldl' addP Crypto.PointO (zipWith mulP lsLeft gsRight) + aR' = foldl' addP Crypto.PointO (zipWith mulP lsRight gsLeft) + + bL' = foldl' addP Crypto.PointO (zipWith mulP rsLeft hsRight) + bR' = foldl' addP Crypto.PointO (zipWith mulP rsRight hsLeft) + + z = dotp ls rs + z' = dotp ls' rs' + + lGs = foldl' addP Crypto.PointO (zipWith mulP ls bGs) + rHs = foldl' addP Crypto.PointO (zipWith mulP rs bHs) + + lGs' = foldl' addP Crypto.PointO (zipWith mulP ls' gs'') + rHs' = foldl' addP Crypto.PointO (zipWith mulP rs' hs'') + + checkLGs + = lGs' + == + foldl' addP Crypto.PointO (zipWith mulP ls bGs) + `addP` + (fqSquare x `mulP` aL') + `addP` + (fqSquare xInv `mulP` aR') + + checkRHs + = rHs' + == + foldl' addP Crypto.PointO (zipWith mulP rs bHs) + `addP` + (fqSquare x `mulP` bR') + `addP` + (fqSquare xInv `mulP` bL') + + checkLBs + = dotp ls' rs' + == + dotp ls rs + fqSquare x * cL + fqSquare xInv * cR + + checkC + = commitmentLR + == + (z `mulP` bH) + `addP` + lGs + `addP` + rHs + + checkC' + = commitmentLR' + == + (z' `mulP` bH) + `addP` + lGs' + `addP` + rHs' + + diff --git a/Bulletproofs/InnerProductProof/Verifier.hs b/Bulletproofs/InnerProductProof/Verifier.hs new file mode 100644 index 0000000..60592fc --- /dev/null +++ b/Bulletproofs/InnerProductProof/Verifier.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns, MultiWayIf #-} + +module Bulletproofs.InnerProductProof.Verifier + ( verifyProof + ) where + +import Protolude + +import qualified Data.List as L +import qualified Data.Map as Map + +import qualified Crypto.PubKey.ECC.Types as Crypto + +import Bulletproofs.Curve +import Bulletproofs.Utils +import Bulletproofs.Fq as Fq + +import Bulletproofs.RangeProof.Internal +import Bulletproofs.InnerProductProof.Internal + +-- | Optimized non-interactive verifier using multi-exponentiation and batch verification +verifyProof + :: Integer -- ^ Range upper bound + -> InnerProductBase -- ^ Generators Gs, Hs, h + -> Crypto.Point -- ^ Commitment P + -> InnerProductProof + -- ^ Proof that a secret committed value lies in a certain interval + -> Bool +verifyProof n productBase@InnerProductBase{..} commitmentLR productProof@InnerProductProof{ l, r } + = c == cProof + where + (challenges, invChallenges, c) = mkChallenges productProof commitmentLR + otherExponents = mkOtherExponents n challenges + cProof + = (l `mulP` gsCommit) + `addP` + (r `mulP` hsCommit) + `addP` + ((l * r) `mulP` bH) + + gsCommit = foldl' addP Crypto.PointO (zipWith mulP otherExponents bGs) + hsCommit = foldl' addP Crypto.PointO (zipWith mulP (reverse otherExponents) bHs) + +mkChallenges :: InnerProductProof -> Crypto.Point -> ([Fq], [Fq], Crypto.Point) +mkChallenges InnerProductProof{ lCommits, rCommits } commitmentLR + = foldl' + (\(xs, xsInv, accC) (li, ri) + -> let x = shamirX' accC li ri + xInv = inv x + c = (fqSquare x `mulP` li) `addP` (fqSquare xInv `mulP` ri) `addP` accC + in (x:xs, xInv:xsInv, c) + ) + ([], [], commitmentLR) + (zip lCommits rCommits) + +mkOtherExponents :: Integer -> [Fq] -> [Fq] +mkOtherExponents n challenges + = Map.elems $ foldl' + f + (Map.fromList [(0, Fq.inv $ product challenges)]) + [0..n'-1] + where + n' = n `div` 2 + f acc i = foldl' (f' i) acc [0..logBase2 n-1] + f' :: Integer -> Map.Map Integer Fq -> Integer -> Map.Map Integer Fq + f' i acc' j + = let i1 = (2^j) + i in + if | i1 >= n -> acc' + | Map.member i1 acc' -> acc' + | otherwise -> Map.insert + i1 + (acc' Map.! i * fqSquare (challenges L.!! fromIntegral j)) + acc' + + diff --git a/Bulletproofs/RangeProof.hs b/Bulletproofs/RangeProof.hs new file mode 100644 index 0000000..0fde047 --- /dev/null +++ b/Bulletproofs/RangeProof.hs @@ -0,0 +1,14 @@ +module Bulletproofs.RangeProof +( RangeProof(..) +, RangeProofError(..) + +, generateProof +, generateProofUnsafe +, verifyProof +) where + + + +import Bulletproofs.RangeProof.Internal +import Bulletproofs.RangeProof.Prover +import Bulletproofs.RangeProof.Verifier diff --git a/Bulletproofs/RangeProof/Internal.hs b/Bulletproofs/RangeProof/Internal.hs new file mode 100644 index 0000000..c580701 --- /dev/null +++ b/Bulletproofs/RangeProof/Internal.hs @@ -0,0 +1,196 @@ +module Bulletproofs.RangeProof.Internal where + +import Protolude + +import Numeric (showIntAtBase) +import Data.Char (intToDigit, digitToInt) + +import Crypto.Random.Types (MonadRandom(..)) +import qualified Crypto.PubKey.ECC.Generate as Crypto +import qualified Crypto.PubKey.ECC.Prim as Crypto +import qualified Crypto.PubKey.ECC.Types as Crypto + +import Bulletproofs.Utils +import Bulletproofs.Curve +import Bulletproofs.Fq as Fq +import Bulletproofs.InnerProductProof.Internal + +data RangeProof + = RangeProof + { tBlinding :: Fq + -- ^ Blinding factor of the T1 and T2 commitments, + -- combined into the form required to make the committed version of the x-polynomial add up + , mu :: Fq + -- ^ Blinding factor required for the Verifier to verify commitments A, S + , t :: Fq + -- ^ Dot product of vectors l and r that prove knowledge of the value in range + -- t = t(x) = l(x) · r(x) + , aCommit :: Crypto.Point + -- ^ Commitment to aL and aR, where aL and aR are vectors of bits + -- such that aL · 2^n = v and aR = aL − 1^n . + -- A = α · H + aL · G + aR · H + , sCommit :: Crypto.Point + -- ^ Commitment to new vectors sL, sR, created at random by the Prover + , t1Commit :: Crypto.Point + -- ^ Pedersen commitment to coefficient t1 + , t2Commit :: Crypto.Point + -- ^ Pedersen commitment to coefficient t2 + , productProof :: InnerProductProof + -- ^ Inner product argument to prove that a commitment P + -- has vectors l, r ∈ Z^n for which P = l · G + r · H + ( l, r ) · U + } deriving (Show, Eq) + +data RangeProofError + = UpperBoundTooLarge Integer -- ^ The upper bound of the range is too large + | ValueNotInRange Integer -- ^ Value is not within the range required + | NNotPowerOf2 Integer -- ^ Dimension n is required to be a power of 2 + deriving (Show) + +----------------------------- +-- Polynomials +----------------------------- + +data LRPolys + = LRPolys + { l0 :: [Fq] + , l1 :: [Fq] + , r0 :: [Fq] + , r1 :: [Fq] + } + +data TPoly + = TPoly + { t0 :: Fq + , t1 :: Fq + , t2 :: Fq + } + +----------------------------- +-- Internal functions +----------------------------- + + +-- | Encode the value v into a bit representation. Let aL be a vector +-- of bits such that = v (put more simply, the components of a L are the +-- binary digits of v). +encodeBit :: Integer -> Fq -> [Fq] +encodeBit n (Fq v) = fillWithZeros n $ Fq.new . fromIntegral . digitToInt <$> showIntAtBase 2 intToDigit v "" + +-- | Bits of v reversed. +-- v = = a_0 * 2^0 + ... + a_n-1 * 2^(n-1) +reversedEncodeBit :: Integer -> Fq -> [Fq] +reversedEncodeBit n = reverse . encodeBit n + +-- | In order to prove that v is in range, each element of aL is either 0 or 1. +-- We construct a “complementary” vector aR = aL − 1^n and require that +-- aL ◦ aR = 0 hold. +complementaryVector :: Num a => [a] -> [a] +complementaryVector aL = (\vi -> vi - 1) <$> aL + +-- | Add non-relevant zeros to a vector to match the size +-- of the other vectors used in the protocol +fillWithZeros :: Integer -> [Fq] -> [Fq] +fillWithZeros n aL = zeros ++ aL + where + zeros = replicate (fromInteger n - length aL) (Fq 0) + +-- | Obfuscate encoded bits with challenges y and z. +-- z^2 * + z * + = (z^2) * v +-- The property holds because = 0 and = 0 +obfuscateEncodedBits :: Integer -> [Fq] -> [Fq] -> Fq -> Fq -> Fq +obfuscateEncodedBits n aL aR y z + = (fqSquare z * dotp aL (powerVector 2 n)) + + (z * dotp ((aL `fqSubV` powerVector 1 n) `fqSubV` aR) yN) + + dotp (hadamardp aL aR) yN + where + yN = powerVector y n + +-- Convert obfuscateEncodedBits into aCommit sCommitingle inner product. +-- We can afford for this factorization to leave terms “dangling”, but +-- what’s important is that the aL , aR terms be kept inside +-- (since they can’t be shared with the Verifier): +-- = z 2 v + δ(y, z) +obfuscateEncodedBitsSingle :: Integer -> [Fq] -> [Fq] -> Fq -> Fq -> Fq +obfuscateEncodedBitsSingle n aL aR y z + = dotp + (aL `fqSubV` z1n) + (hadamardp (powerVector y n) (aR `fqAddV` z1n) `fqAddV` ((*) (fqSquare z) <$> powerVector 2 n)) + where + z1n = (*) z <$> powerVector 1 n + +-- | We need to blind the vectors aL, aR to make the proof zero knowledge. +-- The Prover creates randomly vectors sL and sR. On creating these, the +-- Prover can send commitments to these vectors; +-- these are properly blinded vector Pedersen commitments: +commitBitVectors + :: MonadRandom m + => Fq + -> Fq + -> [Fq] + -> [Fq] + -> [Fq] + -> [Fq] + -> m (Crypto.Point, Crypto.Point) +commitBitVectors aBlinding sBlinding aL aR sL sR = do + let aLG = foldl' addP Crypto.PointO ( zipWith mulP aL gs ) + aRH = foldl' addP Crypto.PointO ( zipWith mulP aR hs ) + sLG = foldl' addP Crypto.PointO ( zipWith mulP sL gs ) + sRH = foldl' addP Crypto.PointO ( zipWith mulP sR hs ) + aBlindingH = mulP aBlinding h + sBlindingH = mulP sBlinding h + + -- Commitment to aL and aR + let aCommit = aBlindingH `addP` aLG `addP` aRH + + -- Commitment to sL and sR + let sCommit = sBlindingH `addP` sLG `addP` sRH + + pure (aCommit, sCommit) + +chooseBlindingVectors :: MonadRandom m => Integer -> m ([Fq], [Fq]) +chooseBlindingVectors n = do + sL <- replicateM (fromInteger n) (Fq.random n) + sR <- replicateM (fromInteger n) (Fq.random n) + pure (sL, sR) + +-- | (z − z^2) * <1^n, y^n> − z^3 * <1^n, 2^n> +delta :: Integer -> Fq -> Fq -> Fq +delta n y z + = ((z - Fq.fqSquare z) * dotp (powerVector 1 n) (powerVector y n)) + - (Fq.fqCube z * dotp (powerVector 1 n) (powerVector 2 n)) + +-- | Check that a value is in aCommit sCommitpecific range +checkRange :: Integer -> Integer -> Bool +checkRange n v = v >= 0 && v < 2 ^ n + +-- | Compute commitment of linear vector polynomials l and r +-- P = A + xS − zG + (z*y^n + z^2 * 2^n) * hs' +computeLRCommitment + :: Integer + -> Crypto.Point + -> Crypto.Point + -> Fq + -> Fq + -> Fq + -> Fq + -> Fq + -> Fq + -> [Crypto.Point] + -> Crypto.Point +computeLRCommitment n aCommit sCommit t tBlinding mu x y z hs' + = aCommit + `addP` + (x `mulP` sCommit) + `addP` + Crypto.pointNegate curve (z `mulP` gsSum) + `addP` + foldl' addP Crypto.PointO (zipWith mulP hExp hs') + `addP` + Crypto.pointNegate curve (mu `mulP` h) + `addP` + (t `mulP` u) + where + gsSum = foldl' addP Crypto.PointO (take (fromIntegral n) gs) + hExp = ((*) z <$> powerVector y n) `fqAddV` ((*) (fqSquare z) <$> powerVector 2 n) + uChallenge = shamirU tBlinding mu t + u = uChallenge `mulP` g diff --git a/Bulletproofs/RangeProof/Prover.hs b/Bulletproofs/RangeProof/Prover.hs new file mode 100644 index 0000000..4cc75cb --- /dev/null +++ b/Bulletproofs/RangeProof/Prover.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE RecordWildCards, MultiWayIf #-} + +module Bulletproofs.RangeProof.Prover where + +import Protolude + +import Crypto.Random.Types (MonadRandom(..)) +import qualified Crypto.PubKey.ECC.Generate as Crypto +import qualified Crypto.PubKey.ECC.Prim as Crypto +import qualified Crypto.PubKey.ECC.Types as Crypto + +import Bulletproofs.Curve +import Bulletproofs.Utils +import Bulletproofs.Fq as Fq +import Bulletproofs.RangeProof.Internal + +import Bulletproofs.InnerProductProof as IPP + +-- | Prove that a value lies in a specific range +generateProof + :: MonadRandom m + => Integer -- ^ Upper bound of the range we want to prove + -> Integer -- ^ Value we want to prove in range + -> Integer -- ^ Blinding factor + -> ExceptT RangeProofError m RangeProof +generateProof upperBound v vBlinding = do + unless (upperBound < q) $ throwE $ UpperBoundTooLarge upperBound + + case doubleLogM of + Nothing -> throwE $ NNotPowerOf2 upperBound + Just n -> do + unless (checkRange n v) $ throwE $ ValueNotInRange v + lift $ generateProofUnsafe upperBound v vBlinding + + where + doubleLogM :: Maybe Integer + doubleLogM = do + x <- logBase2M upperBound + logBase2M x + pure x + + +-- | Generate range proof from valid inputs +generateProofUnsafe + :: MonadRandom m + => Integer -- ^ Upper bound of the range we want to prove + -> Integer -- ^ Value we want to prove in range + -> Integer -- ^ Blinding factor + -> m RangeProof +generateProofUnsafe upperBound v vBlinding = do + let n = logBase2 upperBound + vFq = Fq.new v + vBlindingFq = Fq.new vBlinding + + let aL = reversedEncodeBit n vFq + aR = complementaryVector aL + + (sL, sR) <- chooseBlindingVectors n + + [aBlinding, sBlinding] <- replicateM 2 (Fq.random n) + + (aCommit, sCommit) <- commitBitVectors aBlinding sBlinding aL aR sL sR + + -- Oracle generates y, z from a, c + let y = shamirY aCommit sCommit + z = shamirZ aCommit sCommit y + + let lrPoly@LRPolys{..} = computeLRPolys n aL aR sL sR y z + tPoly@TPoly{..} = computeTPoly lrPoly + + [t1Blinding, t2Blinding] <- replicateM 2 (Fq.random n) + + let t1Commit = commit t1 t1Blinding + t2Commit = commit t2 t2Blinding + + -- Oracle generates x from previous data in transcript + let x = shamirX aCommit sCommit t1Commit t2Commit y z + + let ls = l0 `fqAddV` ((*) x <$> l1) + rs = r0 `fqAddV` ((*) x <$> r1) + t = t0 + (t1 * x) + (t2 * fqSquare x) + + unless (t == dotp ls rs) $ + panic "Error on: t = dotp l r" + + unless (t1 == dotp l1 r0 + dotp l0 r1) $ + panic "Error on: t1 = dotp l1 r0 + dotp l0 r1" + + unless (t0 == (vFq * fqSquare z) + delta n y z) $ + panic "Error on: t0 = v * z^2 + delta(y, z)" + + let tBlinding = (fqSquare z * vBlindingFq) + (t2Blinding * fqSquare x) + (t1Blinding * x) + mu = aBlinding + (sBlinding * x) + + let uChallenge = shamirU tBlinding mu t + u = uChallenge `mulP` g + hs' = zipWith (\yi hi-> inv yi `mulP` hi) (powerVector y n) hs + commitmentLR = computeLRCommitment n aCommit sCommit t tBlinding mu x y z hs' + productProof = IPP.generateProof + InnerProductBase { bGs = gs, bHs = hs', bH = u } + commitmentLR + InnerProductWitness { ls = ls, rs = rs } + + pure RangeProof + { tBlinding = tBlinding + , mu = mu + , t = t + , aCommit = aCommit + , sCommit = sCommit + , t1Commit = t1Commit + , t2Commit = t2Commit + , productProof = productProof + } + + +-- | Compute l and r polynomials to prove knowledge of aL, aR without revealing them. +-- We achieve it by transferring the vectors l, r. +-- The two terms of the dot product above are set as the constant term, +-- while sL, sR are the coefficient of x^1 , in the following two linear polynomials, +-- which are combined into a quadratic in x: +-- l(x) = (a L − z1 n ) + s L x +-- r(x) = y^n ◦ (aR + z * 1^n + sR * x) + z^2 * 2^n +computeLRPolys + :: Integer + -> [Fq] + -> [Fq] + -> [Fq] + -> [Fq] + -> Fq + -> Fq + -> LRPolys +computeLRPolys n aL aR sL sR y z + = LRPolys + { l0 = aL `fqSubV` ((*) z <$> powerVector 1 n) + , l1 = sL + , r0 = (powerVector y n `hadamardp` (aR `fqAddV` z1n)) + `fqAddV` + ((*) (fqSquare z) <$> powerVector 2 n) + , r1 = hadamardp (powerVector y n) sR + } + where + z1n = (*) z <$> powerVector 1 n + + +-- | Compute polynomial t from polynomial r +-- t(x) = l(x) · r(x) = t0 + t1 * x + t2 * x^2 +computeTPoly :: LRPolys -> TPoly +computeTPoly lrPoly@LRPolys{..} + = TPoly + { t0 = t0 + , t1 = (dotp (l0 `fqAddV` l1) (r0 `fqAddV` r1) - t0) - t2 + , t2 = t2 + } + where + t0 = dotp l0 r0 + t2 = dotp l1 r1 + + + diff --git a/Bulletproofs/RangeProof/Verifier.hs b/Bulletproofs/RangeProof/Verifier.hs new file mode 100644 index 0000000..3ca88fb --- /dev/null +++ b/Bulletproofs/RangeProof/Verifier.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE RecordWildCards, MultiWayIf, NamedFieldPuns, ViewPatterns #-} + +module Bulletproofs.RangeProof.Verifier where + +import Protolude +import Prelude (zipWith3) + +import qualified Crypto.PubKey.ECC.Generate as Crypto +import qualified Crypto.PubKey.ECC.Prim as Crypto +import qualified Crypto.PubKey.ECC.Types as Crypto + +import Bulletproofs.RangeProof.Internal +import Bulletproofs.Curve +import Bulletproofs.Utils +import Bulletproofs.Fq as Fq + +import Bulletproofs.InnerProductProof as IPP + +-- | Verify that a commitment was computed from a value in a given range +verifyProof + :: Integer -- ^ Range upper bound + -> Crypto.Point -- ^ Commitment of an in-range value + -> RangeProof + -- ^ Proof that a secret committed value lies in a certain interval + -> Bool +verifyProof upperBound vCommit proof@RangeProof{..} + = and + [ verifyTPoly n vCommit proof x y z + , verifyLRCommitment n proof x y z + ] + where + x = shamirX aCommit sCommit t1Commit t2Commit y z + y = shamirY aCommit sCommit + z = shamirZ aCommit sCommit y + hs' = zipWith (\yi hi-> inv yi `mulP` hi) (powerVector y n) hs + n = logBase2 upperBound + +-- | Verify the constant term of the polynomial t +-- t = t(x) = t0 + t1*x + t2*x^2 +-- This is what binds the proof to the actual original Pedersen commitment V to the actual value +verifyTPoly + :: Integer -- ^ Dimension n of the vectors + -> Crypto.Point -- ^ Commitment of an in-range value + -> RangeProof + -- ^ Proof that a secret committed value lies in a certain interval + -> Fq -- ^ Challenge x + -> Fq -- ^ Challenge y + -> Fq -- ^ Challenge z + -> Bool +verifyTPoly n vCommit proof@RangeProof{..} x y z + = lhs == rhs + where + lhs = commit t tBlinding + rhs = (fqSquare z `mulP` vCommit) + `addP` + (delta n y z `mulP` g) + `addP` + (x `mulP` t1Commit) + `addP` + (fqSquare x `mulP` t2Commit) + +-- | Verify the inner product argument for the vectors l and r that form t +verifyLRCommitment + :: Integer -- ^ Dimension n of the vectors + -> RangeProof + -- ^ Proof that a secret committed value lies in a certain interval + -> Fq -- ^ Challenge x + -> Fq -- ^ Challenge y + -> Fq -- ^ Challenge z + -> Bool +verifyLRCommitment n proof@RangeProof{..} x y z + = IPP.verifyProof + n + IPP.InnerProductBase { bGs = gs, bHs = hs', bH = u } + commitmentLR + productProof + where + commitmentLR = computeLRCommitment n aCommit sCommit t tBlinding mu x y z hs' + hs' = zipWith (\yi hi-> inv yi `mulP` hi) (powerVector y n) hs + uChallenge = shamirU tBlinding mu t + u = uChallenge `mulP` g + + diff --git a/Bulletproofs/Utils.hs b/Bulletproofs/Utils.hs new file mode 100644 index 0000000..53e7f30 --- /dev/null +++ b/Bulletproofs/Utils.hs @@ -0,0 +1,94 @@ +module Bulletproofs.Utils where + +import Protolude + +import qualified Crypto.PubKey.ECC.Prim as Crypto +import qualified Crypto.PubKey.ECC.Types as Crypto + +import Bulletproofs.Fq as Fq +import Bulletproofs.Curve + +-- | Return a vector containing the first n powers of a +powerVector :: Fq -> Integer -> [Fq] +powerVector (Fq a) x = (\i -> Fq.new (a ^ i)) <$> [0..x-1] + +-- | Inner product between two vector polynomials +dotp :: Num a => [a] -> [a] -> a +dotp a b = foldl' (+) 0 (hadamardp a b) + +-- | Hadamard product or entry wise multiplication of two vectors +hadamardp :: Num a => [a] -> [a] -> [a] +hadamardp a b | length a == length b = zipWith (*) a b + | otherwise = panic "Vector sizes must match" + +-- | Add two points of the same curve +addP :: Crypto.Point -> Crypto.Point -> Crypto.Point +addP = Crypto.pointAdd curve + +-- | Substract two points of the same curve +subP :: Crypto.Point -> Crypto.Point -> Crypto.Point +subP x y = Crypto.pointAdd curve x (Crypto.pointNegate curve y) + +-- | Multiply a scalar and a point in an elliptic curve +mulP :: Fq -> Crypto.Point -> Crypto.Point +mulP (Fq x) = Crypto.pointMul curve x + +-- | Create a Pedersen commitment to a value given +-- a value and a blinding factor +commit :: Fq -> Fq -> Crypto.Point +commit x r = (x `mulP` g) `addP` (r `mulP` h) + +isLogBase2 :: Integer -> Bool +isLogBase2 x + | x == 1 = True + | x == 0 || (x `mod` 2 /= 0) = False + | otherwise = isLogBase2 (x `div` 2) + +logBase2 :: Integer -> Integer +logBase2 = floor . logBase 2.0 . fromIntegral + +logBase2M :: Integer -> Maybe Integer +logBase2M x + = if isLogBase2 x + then Just (logBase2 x) + else Nothing + +-------------------------------------------------- +-- Fiat-Shamir transformations +-------------------------------------------------- + +shamirY :: Crypto.Point -> Crypto.Point -> Fq +shamirY aCommit sCommit + = Fq.new $ oracle $ + show q <> pointToBS aCommit <> pointToBS sCommit + +shamirZ :: Crypto.Point -> Crypto.Point -> Fq -> Fq +shamirZ aCommit sCommit y + = Fq.new $ oracle $ + show q <> pointToBS aCommit <> pointToBS sCommit <> show y + +shamirX + :: Crypto.Point + -> Crypto.Point + -> Crypto.Point + -> Crypto.Point + -> Fq + -> Fq + -> Fq +shamirX aCommit sCommit t1Commit t2Commit y z + = Fq.new $ oracle $ + show q <> pointToBS aCommit <> pointToBS sCommit <> pointToBS t1Commit <> pointToBS t2Commit <> show y <> show z + +shamirX' + :: Crypto.Point + -> Crypto.Point + -> Crypto.Point + -> Fq +shamirX' commitmentLR l' r' + = Fq.new $ oracle $ + show q <> pointToBS l' <> pointToBS r' <> pointToBS commitmentLR + +shamirU :: Fq -> Fq -> Fq -> Fq +shamirU tBlinding mu t + = Fq.new $ oracle $ + show q <> show tBlinding <> show mu <> show t diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..5dcb913 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for bulletproofs + +## 0.1 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c437eab --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Adjoint Inc. (c) 2018 + +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 Author name here 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/README.md b/README.md new file mode 100644 index 0000000..24fb015 --- /dev/null +++ b/README.md @@ -0,0 +1,144 @@ +

+ +

+ +[![CircleCI](https://circleci.com/gh/adjoint-io/bulletproofs.svg?style=svg)](https://circleci.com/gh/adjoint-io/bulletproofs) + +Bulletproofs are short zero-knowledge arguments of knowledge that do not require a trusted setup. +Argument systems are proof systems with computational soundness. + +Bulletproofs are suitable for proving statements on committed values, such as range proofs, verifiable suffles, arithmetic circuits, etc. +They rely on the discrete logarithmic assumption and are made non-interactive using +the Fiat-Shamir heuristic. + +The core algorithm of Bulletproofs is the inner-product algorithm presented by Groth [2]. +The algorithm provides an argument of knowledge of two binding vector Pedersen commitments that satisfy a given inner product relation. +Bulletproofs build on the techniques of Bootle et al. [3] to introduce a communication efficient inner-product proof that reduces +overall communication complexity of the argument to only 2log2(n) where n is the dimension +of the two vectors of commitments. + + +Range proofs +============ + +Bulletproofs present a protocol for conducting short and aggregatable range proofs. +They encode a proof of the range of a committed number in an inner product, using polynomials. +Range proofs are proofs that a secret value lies in a certain interval. +Range proofs do not leak any information about the secret value, other +than the fact that they lie in the interval. + +The proof algorithm can be sketched out in 5 steps: + +Let _v_ be a value in _[0, n)_ and **aL** a vector of bit such that <**aL**, **2n**> = _v_. +The components of **aL** are the binary digits of _v_. +We construct a complementary vector **aR** = **aL** − **1**n +and require that **aL** ◦ **aR** = 0 holds. + +- **P -> V : A, S** - where A and S are blinded Pedersen commitments to **aL** and **aR**. + +       ![equation](https://latex.codecogs.com/gif.latex?\\&space;$&space;A&space;=&space;h&space;\cdot&space;\alpha&space;+&space;\textbf{g}&space;\cdot&space;\textbf{a}_L&space;+&space;\textbf{h}&space;\cdot&space;\textbf{a}_R&space;\in&space;\mathcal{G}&space;$) + +       ![equation](https://latex.codecogs.com/gif.latex?\\&space;$&space;S&space;=&space;h&space;\cdot&space;\rho&space;+&space;\textbf{g}&space;\cdot&space;\textbf{s}_L&space;+&space;\textbf{h}&space;\cdot&space;\textbf{s}_R&space;\in&space;\mathcal{G}&space;$) + +- **V -> P : y, z** - Verifier sends challenges _y_ and _z_ to fix **A** and **S**. + +- **P -> V : T1, T2** - where T1 and T2 are commitments to +the coefficients t1, of a polynomial t constructed from the existing values in the protocol. + +       ![equation](https://latex.codecogs.com/gif.latex?\\&space;$&space;\textbf{l}&space;=&space;l(x)&space;=&space;\textbf{a}_L&space;-&space;z&space;\cdot&space;\textbf{1}^n&space;+&space;\textbf{s}_L&space;\cdot&space;x&space;\in&space;\mathcal{Z}^n_p$) + +       ![equation](https://latex.codecogs.com/gif.latex?\\&space;$&space;\textbf{r}&space;=&space;r(x)&space;=&space;\textbf{y}^n&space;\circ&space;(\textbf{a}_R&space;+&space;z&space;\cdot&space;\textbf{1}^n&space;+&space;\textbf{s}_R&space;\cdot&space;x&space;)&space;+&space;z^2&space;\cdot&space;\textbf{2}^n&space;\in&space;\mathcal{Z}^n_p&space;$) + +       ![equation](https://latex.codecogs.com/gif.latex?\\&space;$&space;t&space;=&space;\langle&space;\textbf{l},&space;\textbf{r}&space;\rangle&space;\in&space;\mathcal{Z}_p$) + +       ![equation](https://latex.codecogs.com/gif.latex?\\&space;$T_i&space;=&space;g&space;\cdot&space;t_i&space;+&space;h&space;\cdot&space;\tau_i&space;\in&space;\mathcal{G},&space;\hspace{3em}&space;i&space;=&space;\{1,&space;2\}&space;$) + +- **V -> P : x** - Verifier challenges Prover with value _x_. + +- **P -> V : tau, mu, t, l, r** - Prover sends several commitments that the verifier will then check. + +       ![equation](https://latex.codecogs.com/gif.latex?\\&space;$&space;\tau_x&space;=&space;\tau_2&space;\cdot&space;x^2&space;+&space;\tau_1&space;\cdot&space;x&space;+&space;z^2&space;\cdot&space;\gamma&space;\in&space;\mathcal{Z}_p&space;$) + +       ![equation](https://latex.codecogs.com/gif.latex?\\&space;$&space;\mu&space;=&space;\alpha&space;+&space;\rho&space;\cdot&space;x&space;\in&space;\mathcal{Z}_p&space;$) + +See [Prover.hs](https://github.com/adjoint-io/bulletproofs/blob/master/src/RangeProof/Prover.hs "Prover.hs") for implementation details. + +The interaction described is made non-interactive using the Fiat-Shamir Transform wherein all the random +challenges made by V are replaced with a hash of the transcript up until that point. + +Inner-product range proof +========================= + +The size of the proof is further reduced by leveraging the compact O(logn) inner product proof. + +The inner-product argument in the protocol allows to prove knowledge of vectors **l** and **r**, whose inner product is _t_ and +the commitment _P_ ∈ _G_ is a commitment of these two vectors. We can therefore replace sending +(tau, mu, t, **l**, **r**) with a transfer of (tau, mu, t) and an execution of an inner product argument. + +Then, instead of sharing **l** and **r**, which has a communication cost of 2n elements, the inner-product +argument transmits only 2 [log2] + 2 elements. In total, the prover sends only 2 [log2(n)] + 4 +group elements and 5 elements in _Z_p + +Usage +===== + +```haskell +import Bulletproofs.RangeProof + +testProtocol :: Integer -> Integer -> IO Bool +testProtocol v vBlinding = do + let vCommit = commit v vBlinding + -- n needs to be a power of 2 + n = 2 ^ 8 + upperBound = 2 ^ n + + -- Prover + proofE <- generateProof upperBound v vBlinding + -- Verifier + case proofE of + Left err -> panic $ show err + Right (proof@RangeProof{..}) + -> pure $ verifyProof upperBound vCommit proof +``` + +The dimension _n_ needs to be a power of 2. +This implementation offers support for the SECp256k1 curve, a Koblitz curve. +Further information about this curve can be found in the Uplink docs: +[SECp256k1 curve](https://www.adjoint.io/docs/cryptography.html#id1 "SECp256k1 curve") + + +**References**: + +1. Bunz B., Bootle J., Boneh J., Poelstra A., Wuille P., Maxwell G. + "Bulletproofs: Short Proofs for Confidential Transactions and More". Stanford, UCL, Blockstream, 2017 + +2. Groth J. "Linear Algebra with Sub-linear Zero-Knowledge Arguments". University College London, 2009 + +3. Bootle J., Cerully A., Chaidos P., Groth J, Petit C. "Efficient Zero-Knowledge Arguments for +Arithmetic Circuits in the Discrete Log Setting". University College London and University of Oxford, 2016. + +**Notation**: + +- ◦ : Hadamard product +- <> :Inner product +- **a**: Vector + + +License +------- + +``` +Copyright 2018 Adjoint Inc + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/circle.yml b/circle.yml new file mode 100644 index 0000000..a8dcc20 --- /dev/null +++ b/circle.yml @@ -0,0 +1,16 @@ +dependencies: + cache_directories: + - "~/.stack" + pre: + - wget https://github.com/commercialhaskell/stack/releases/download/v1.7.1/stack-1.7.1-linux-x86_64.tar.gz -O /tmp/stack.tar.gz + - tar -zxvf /tmp/stack.tar.gz -C /tmp + - sudo mv /tmp/stack-**/stack /usr/bin/stack + - sudo apt-get update -q + + override: + - stack upgrade + - stack setup + +test: + override: + - stack test diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..bde74fb --- /dev/null +++ b/package.yaml @@ -0,0 +1,66 @@ +name: bulletproofs +version: 0.1.0 +github: "adjoint-io/bulletproofs" +license: Apache +maintainer: Adjoint Inc (info@adjoint.io) +category: Cryptography +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- protolude >= 0.2 +- text +- cryptonite +- memory +- arithmoi +- containers + +library: + source-dirs: . + exposed-modules: + - Bulletproofs.Curve + - Bulletproofs.Fq + - Bulletproofs.RangeProof + - Bulletproofs.RangeProof.Internal + - Bulletproofs.RangeProof.Prover + - Bulletproofs.RangeProof.Verifier + + - Bulletproofs.InnerProductProof + - Bulletproofs.InnerProductProof.Internal + - Bulletproofs.InnerProductProof.Prover + - Bulletproofs.InnerProductProof.Verifier + + - Bulletproofs.Utils + + default-extensions: + - OverloadedStrings + - NoImplicitPrelude + +tests: + bulletproofs-test: + main: TestDriver.hs + source-dirs: tests + dependencies: + - base + - cryptonite + - memory + - tasty + - tasty-discover + - tasty-hunit + - tasty-quickcheck + - QuickCheck + - bulletproofs + default-extensions: + - OverloadedStrings + - NoImplicitPrelude diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..2dc31f8 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,65 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-11.15 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# using the same syntax as the packages field. +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/tests/TestCommon.hs b/tests/TestCommon.hs new file mode 100644 index 0000000..b6407ec --- /dev/null +++ b/tests/TestCommon.hs @@ -0,0 +1,53 @@ +module TestCommon + ( commutes + , associates + , isIdentity + , isInverse + , distributes + ) where + +import Protolude + +commutes + :: Eq a + => (a -> a -> a) + -> a -> a -> Bool +commutes op x y + = (x `op` y) == (y `op` x) + +associates + :: Eq a + => (a -> a -> a) + -> a -> a -> a -> Bool +associates op x y z + = (x `op` (y `op` z)) == ((x `op` y) `op` z) + +isIdentity + :: Eq a + => (a -> a -> a) + -> a + -> a + -> Bool +isIdentity op e x + = (x `op` e == x) && (e `op` x == x) + +isInverse + :: Eq a + => (a -> a -> a) + -> (a -> a) + -> a + -> a + -> Bool +isInverse op inv e x + = (x `op` inv x == e) && (inv x `op` x == e) + +distributes + :: Eq a + => (a -> a -> a) + -> (a -> a -> a) + -> a + -> a + -> a + -> Bool +distributes mult add x y z + = x `mult` (y `add` z) == (x `mult` y) `add` (x `mult` z) diff --git a/tests/TestDriver.hs b/tests/TestDriver.hs new file mode 100644 index 0000000..327adf4 --- /dev/null +++ b/tests/TestDriver.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/tests/TestField.hs b/tests/TestField.hs new file mode 100644 index 0000000..591e027 --- /dev/null +++ b/tests/TestField.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TestField where + +import Protolude + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit + +import qualified Crypto.PubKey.ECC.Prim as Crypto + +import Bulletproofs.Utils +import Bulletproofs.Fq as Fq +import Bulletproofs.Curve + +import TestCommon + +instance Arbitrary Fq where + arbitrary = Fq.new <$> arbitrary + +prop_addMod :: Fq -> Fq -> Property +prop_addMod x y + = (x + y) `mulP` g === (x `mulP` g) `addP` (y `mulP` g) + +prop_subMod :: Fq -> Fq -> Property +prop_subMod x y + = (x - y) `mulP` g === (x `mulP` g) `addP` Crypto.pointNegate curve (y `mulP` g) + + +------------------------------------------------------------------------------- +-- Laws of field operations +------------------------------------------------------------------------------- + +testFieldLaws + :: forall a . (Num a, Fractional a, Eq a, Arbitrary a, Show a) + => Proxy a + -> TestName + -> TestTree +testFieldLaws _ descr + = testGroup ("Test field laws of " <> descr) + [ testProperty "commutativity of addition" + $ commutes ((+) :: a -> a -> a) + , testProperty "commutativity of multiplication" + $ commutes ((*) :: a -> a -> a) + , testProperty "associavity of addition" + $ associates ((+) :: a -> a -> a) + , testProperty "associavity of multiplication" + $ associates ((*) :: a -> a -> a) + , testProperty "additive identity" + $ isIdentity ((+) :: a -> a -> a) 0 + , testProperty "multiplicative identity" + $ isIdentity ((*) :: a -> a -> a) 1 + , testProperty "additive inverse" + $ isInverse ((+) :: a -> a -> a) negate 0 + , testProperty "multiplicative inverse" + $ \x -> (x /= (0 :: a)) ==> isInverse ((*) :: a -> a -> a) recip 1 x + , testProperty "multiplication distributes over addition" + $ distributes ((*) :: a -> a -> a) (+) + ] + +------------------------------------------------------------------------------- +-- Fq +------------------------------------------------------------------------------- + +test_fieldLaws_Fq :: TestTree +test_fieldLaws_Fq = testFieldLaws (Proxy :: Proxy Fq) "Fq" diff --git a/tests/TestProtocol.hs b/tests/TestProtocol.hs new file mode 100644 index 0000000..b8d321d --- /dev/null +++ b/tests/TestProtocol.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE ViewPatterns, RecordWildCards #-} + +module TestProtocol where + +import Protolude + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.QuickCheck +import qualified Test.QuickCheck.Monadic as QCM + +import Crypto.Random.Types (MonadRandom(..)) +import Crypto.Number.Generate (generateMax) +import qualified Crypto.PubKey.ECC.Generate as Crypto +import qualified Crypto.PubKey.ECC.Prim as Crypto +import qualified Crypto.PubKey.ECC.Types as Crypto + +import Bulletproofs.Curve +import qualified Bulletproofs.RangeProof as RP +import qualified Bulletproofs.RangeProof.Internal as RP +import qualified Bulletproofs.RangeProof.Verifier as RP +import Bulletproofs.Utils +import Bulletproofs.Fq as Fq + +import TestField + +newtype Bin = Bin { unbin :: Int } deriving Show + +instance Arbitrary Bin where + arbitrary = Bin <$> arbitrary `suchThat` flip elem [0,1] + +getUpperBound :: Integer -> Integer +getUpperBound n = 2 ^ n + +prop_complementaryVector_dotp :: [Bin] -> Property +prop_complementaryVector_dotp ((unbin <$>) -> xs) + = dotp xs (RP.complementaryVector xs) === 0 + +prop_complementaryVector_hadamard :: [Bin] -> Property +prop_complementaryVector_hadamard ((toInteger . unbin <$>) -> xs) + = hadamardp xs (RP.complementaryVector xs) === replicate (length xs) 0 + +prop_dotp_aL2n :: Property +prop_dotp_aL2n = QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + v <- QCM.run $ Fq.random n + QCM.assert $ RP.reversedEncodeBit n v `dotp` powerVector (Fq.new 2) n == v + +prop_challengeComplementaryVector :: Property +prop_challengeComplementaryVector = QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + v <- QCM.run $ Fq.random n + let aL = RP.reversedEncodeBit n v + aR = RP.complementaryVector aL + y <- QCM.run $ Fq.random n + QCM.assert + $ dotp + ((aL `fqSubV` powerVector 1 n) `fqSubV` aR) + (powerVector y n) + == + 0 + +prop_obfuscateEncodedBits + :: Fq + -> Fq + -> Property +prop_obfuscateEncodedBits y z + = QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + v <- QCM.run $ Fq.random n + let aL = RP.reversedEncodeBit n v + aR = RP.complementaryVector aL + + QCM.assert $ RP.obfuscateEncodedBits n aL aR y z == fqSquare z * v + +prop_singleInnerProduct + :: Fq + -> Fq + -> Property +prop_singleInnerProduct y z + = QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + v <- QCM.run $ Fq.random n + + let aL = RP.reversedEncodeBit n v + aR = RP.complementaryVector aL + + QCM.assert $ RP.obfuscateEncodedBitsSingle n aL aR y z == (fqSquare z * v) + RP.delta n y z + +setupV :: MonadRandom m => Integer -> m (Integer, Integer, Crypto.Point) +setupV n = do + v <- generateMax (2^n) + vBlinding <- Crypto.scalarGenerate curve + let vCommit = commit (Fq.new v) (Fq.new vBlinding) + pure (v, vBlinding, vCommit) + +test_verifyTPolynomial :: TestTree +test_verifyTPolynomial = localOption (QuickCheckTests 50) $ + testProperty "Verify T polynomial" $ QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + (v, vBlinding, vCommit) <- QCM.run $ setupV n + + proofE <- QCM.run $ runExceptT $ RP.generateProof (getUpperBound n) v vBlinding + case proofE of + Left err -> panic $ show err + Right (proof@RP.RangeProof{..}) -> do + let x = shamirX aCommit sCommit t1Commit t2Commit y z + y = shamirY aCommit sCommit + z = shamirZ aCommit sCommit y + QCM.assert $ RP.verifyTPoly n vCommit proof x y z + +test_verifyLRCommitments :: TestTree +test_verifyLRCommitments = localOption (QuickCheckTests 20) $ + testProperty "Verify LR commitments" $ QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + (v, vBlinding, vCommit) <- QCM.run $ setupV n + + proofE <- QCM.run $ runExceptT $ RP.generateProof (getUpperBound n) v vBlinding + case proofE of + Left err -> panic $ show err + Right (proof@RP.RangeProof{..}) -> do + let x = shamirX aCommit sCommit t1Commit t2Commit y z + y = shamirY aCommit sCommit + z = shamirZ aCommit sCommit y + + QCM.assert $ RP.verifyLRCommitment n proof x y z + +prop_valueNotInRange :: Property +prop_valueNotInRange = expectFailure . QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + (v, vBlinding, vCommit) <- QCM.run $ setupV n + let upperBound = getUpperBound n + vNotInRange = v + upperBound + + proofE <- QCM.run $ runExceptT $ RP.generateProof upperBound vNotInRange vBlinding + case proofE of + Left err -> panic $ show err + Right (proof@RP.RangeProof{..}) -> + QCM.assert $ RP.verifyProof upperBound vCommit proof + +prop_invalidUpperBound :: Property +prop_invalidUpperBound = expectFailure . QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + (v, vBlinding, vCommit) <- QCM.run $ setupV n + let invalidUpperBound = q + 1 + proofE <- QCM.run $ runExceptT $ RP.generateProof invalidUpperBound v vBlinding + case proofE of + Left err -> panic $ show err + Right (proof@RP.RangeProof{..}) -> + QCM.assert $ RP.verifyProof invalidUpperBound vCommit proof + +prop_differentUpperBound :: Positive Integer -> Property +prop_differentUpperBound (Positive upperBound') = expectFailure . QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + (v, vBlinding, vCommit) <- QCM.run $ setupV n + proofE <- QCM.run $ runExceptT $ RP.generateProof (getUpperBound n) v vBlinding + case proofE of + Left err -> panic $ show err + Right (proof@RP.RangeProof{..}) -> + QCM.assert $ RP.verifyProof upperBound' vCommit proof + +test_invalidCommitment :: TestTree +test_invalidCommitment = localOption (QuickCheckTests 20) $ + testProperty "Check invalid commitment" $ QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + (v, vBlinding, vCommit) <- QCM.run $ setupV n + let invalidVCommit = commit (Fq.new $ v + 1) (Fq.new vBlinding) + upperBound = getUpperBound n + proofE <- QCM.run $ runExceptT $ RP.generateProof upperBound v vBlinding + case proofE of + Left err -> panic $ show err + Right (proof@RP.RangeProof{..}) -> + QCM.assert $ not $ RP.verifyProof upperBound invalidVCommit proof + +test_completeness :: TestTree +test_completeness = localOption (QuickCheckTests 20) $ + testProperty "Test range proof completeness" $ QCM.monadicIO $ do + n <- QCM.run $ (2 ^) <$> generateMax 8 + (v, vBlinding, vCommit) <- QCM.run $ setupV n + let upperBound = getUpperBound n + proofE <- QCM.run $ runExceptT $ RP.generateProof upperBound v vBlinding + case proofE of + Left err -> panic $ show err + Right (proof@RP.RangeProof{..}) -> + QCM.assert $ RP.verifyProof upperBound vCommit proof +