bulletproofs (empty) → 0.1.0
raw patch · 20 files changed
+1594/−0 lines, 20 filesdep +QuickCheckdep +arithmoidep +basesetup-changed
Dependencies added: QuickCheck, arithmoi, base, bulletproofs, containers, cryptonite, memory, protolude, tasty, tasty-discover, tasty-hunit, tasty-quickcheck, text
Files
- Bulletproofs/Curve.hs +79/−0
- Bulletproofs/Fq.hs +110/−0
- Bulletproofs/InnerProductProof.hs +13/−0
- Bulletproofs/InnerProductProof/Internal.hs +42/−0
- Bulletproofs/InnerProductProof/Prover.hs +162/−0
- Bulletproofs/InnerProductProof/Verifier.hs +75/−0
- Bulletproofs/RangeProof.hs +14/−0
- Bulletproofs/RangeProof/Internal.hs +196/−0
- Bulletproofs/RangeProof/Prover.hs +159/−0
- Bulletproofs/RangeProof/Verifier.hs +83/−0
- Bulletproofs/Utils.hs +94/−0
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +144/−0
- Setup.hs +2/−0
- bulletproofs.cabal +79/−0
- tests/TestCommon.hs +53/−0
- tests/TestDriver.hs +1/−0
- tests/TestField.hs +67/−0
- tests/TestProtocol.hs +186/−0
+ Bulletproofs/Curve.hs view
@@ -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+
+ Bulletproofs/Fq.hs view
@@ -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 (*)+
+ Bulletproofs/InnerProductProof.hs view
@@ -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
+ Bulletproofs/InnerProductProof/Internal.hs view
@@ -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)+
+ Bulletproofs/InnerProductProof/Prover.hs view
@@ -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'++
+ Bulletproofs/InnerProductProof/Verifier.hs view
@@ -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'++
+ Bulletproofs/RangeProof.hs view
@@ -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
+ Bulletproofs/RangeProof/Internal.hs view
@@ -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 <aL, 2^n> = 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, 2^n> = 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 * <aL, 2^n> + z * <aL − 1^n − aR, y^n> + <aL, aR · y^n> = (z^2) * v+-- The property holds because <aL − 1^n − aR, y^n> = 0 and <aL · aR, y^n> = 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):+-- <aL − z * 1^n , y^n ◦ (aR + z * 1^n) + z^2 * 2^n> = 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
+ Bulletproofs/RangeProof/Prover.hs view
@@ -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+++
+ Bulletproofs/RangeProof/Verifier.hs view
@@ -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++
+ Bulletproofs/Utils.hs view
@@ -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
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for bulletproofs++## 0.1++* Initial release.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,144 @@+<p align="center">+ <a href="http://www.adjoint.io"><img src="https://www.adjoint.io/assets/img/adjoint-logo@2x.png" width="250"/></a>+</p>++[](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 2log<sub>2</sub>(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 **a<sub>L</sub>** a vector of bit such that <**a<sub>L</sub>**, **2<sup>n</sup>**> = _v_.+The components of **a<sub>L</sub>** are the binary digits of _v_.+We construct a complementary vector **a<sub>R</sub>** = **a<sub>L</sub>** − **1**<sup>n</sup>+and require that **a<sub>L</sub>** ◦ **a<sub>R</sub>** = 0 holds.++- **P -> V : A, S** - where A and S are blinded Pedersen commitments to **a<sub>L</sub>** and **a<sub>R</sub>**.++ ++ ++- **V -> P : y, z** - Verifier sends challenges _y_ and _z_ to fix **A** and **S**.++- **P -> V : T<sub>1</sub>, T<sub>2</sub>** - where T<sub>1</sub> and T<sub>2</sub> are commitments to+the coefficients t<sub>1</sub>, of a polynomial t constructed from the existing values in the protocol.++ &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$)++ &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;$)++ ++ ++- **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.++ ++ ++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(log<sub>n</sub>) 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 [log<sub>2</sub>] + 2 elements. In total, the prover sends only 2 [log<sub>2</sub>(n)] + 4+group elements and 5 elements in _Z_<sub>p</sub>++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.+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bulletproofs.cabal view
@@ -0,0 +1,79 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 3b89183974f949f3c27e1427d8945ec87f154533ac162d13451c5e50045d5d78++name: bulletproofs+version: 0.1.0+description: Please see the README on GitHub at <https://github.com/githubuser/bulletproofs#readme>+category: Cryptography+homepage: https://github.com/adjoint-io/bulletproofs#readme+bug-reports: https://github.com/adjoint-io/bulletproofs/issues+maintainer: Adjoint Inc (info@adjoint.io)+license: Apache+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/adjoint-io/bulletproofs++library+ 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+ other-modules:+ Paths_bulletproofs+ hs-source-dirs:+ ./.+ default-extensions: OverloadedStrings NoImplicitPrelude+ build-depends:+ arithmoi+ , base >=4.7 && <5+ , containers+ , cryptonite+ , memory+ , protolude >=0.2+ , text+ default-language: Haskell2010++test-suite bulletproofs-test+ type: exitcode-stdio-1.0+ main-is: TestDriver.hs+ other-modules:+ TestCommon+ TestField+ TestProtocol+ Paths_bulletproofs+ hs-source-dirs:+ tests+ default-extensions: OverloadedStrings NoImplicitPrelude+ build-depends:+ QuickCheck+ , arithmoi+ , base+ , bulletproofs+ , containers+ , cryptonite+ , memory+ , protolude >=0.2+ , tasty+ , tasty-discover+ , tasty-hunit+ , tasty-quickcheck+ , text+ default-language: Haskell2010
+ tests/TestCommon.hs view
@@ -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)
+ tests/TestDriver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
+ tests/TestField.hs view
@@ -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"
+ tests/TestProtocol.hs view
@@ -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+