Implement Sonic protocol

Author: Acentelles

.gitignore

@@ -0,0 +1,4 @@
+.stack-work/
+sonic.cabal
+*~
+TAGS

README.md

@@ -0,0 +1,33 @@
+<p align="center">
+  <a href="http://www.adjoint.io"><img src="https://www.adjoint.io/assets/img/[email protected]" width="250"/></a>
+</p>
+
+Sonic
+-----
+
+Zero-Knowledge SNARKs from Linear-Size Universal and Updatable Structured Reference Strings
+
+License
+-------
+
+```
+Copyright (c) 2018-2019 Adjoint Inc.
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
+OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE
+OR OTHER DEALINGS IN THE SOFTWARE.
+```

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

package.yaml

@@ -0,0 +1,54 @@
+name:                sonic
+version:             0.1.0
+github:              "adjoint-io/sonic"
+license:             MIT
+maintainer:          "Adjoint Inc ([email protected])"
+category:            Cryptography
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+description:         Please see the README on GitHub at <https://github.com/adjoint-io/sonic#readme>
+
+dependencies:
+- base
+- pairing
+- protolude
+- cryptonite
+- bulletproofs
+- wl-pprint-text
+- polynomial
+
+default-extensions:
+  - LambdaCase
+  - RecordWildCards
+  - OverloadedStrings
+  - NoImplicitPrelude
+  - FlexibleInstances
+  - FlexibleContexts
+  - ScopedTypeVariables
+  - RankNTypes
+
+library:
+  source-dirs: src
+  exposed-modules:
+  - Sonic.CommitmentScheme
+  - Sonic.Constraints
+  - Sonic.Protocol
+  - Sonic.SRS
+  - Sonic.Signature
+  - Sonic.Utils
+
+
+tests:
+  sonic-test:
+    main: Driver.hs
+    source-dirs: test
+    dependencies:
+      - sonic
+      - tasty
+      - tasty-discover
+      - tasty-hunit
+      - tasty-quickcheck
+      - QuickCheck

src/Sonic/CommitmentScheme.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE RecordWildCards #-}
+module Sonic.CommitmentScheme where
+
+import Protolude
+import Data.List ((!!))
+import Pairing.Group as Group (G1, G2, GT, g1, g2, expn)
+import Pairing.Fr as Fr (Fr, random, frInv, new)
+import Pairing.Pairing (reducedPairing)
+import Pairing.CyclicGroup (AsInteger(..))
+import Pairing.Point (gMul)
+
+import qualified Math.Polynomial as Poly
+import Math.Polynomial.Laurent
+
+import Sonic.Utils
+import Sonic.SRS
+
+type Commitment = G1
+type Opening f = (f, G1)
+
+commitPoly
+  :: (AsInteger f, Num f, Eq f, Fractional f)
+  => SRS
+  -> Integer
+  -> f
+  -> f
+  -> Laurent f
+  -> Commitment
+commitPoly SRS{..} maxm alpha x poly
+  = if diff >= 0
+    then g1 `expn` (alpha * (x ^ (d - maxm)) * (evalLaurent poly x))
+    else g1 `expn` (alpha * (recip x ^ (abs (d - maxm))) * (evalLaurent poly x))
+  where
+    diff = fromInteger (d - maxm)
+
+openPoly
+  :: (AsInteger f, Num f, Eq f, Fractional f)
+  => SRS
+  -> Commitment
+  -> f
+  -> f
+  -> Laurent f
+  -> Opening f
+openPoly srs _commitment x z fX
+  = let fz = evalLaurent fX z
+        wPoly = (fX - newLaurent 0 [fz]) `quotLaurent` (newLaurent 0 [-z, 1])
+        w = g1 `expn` (evalLaurent wPoly x)
+    in (fz, w)
+
+pcV
+  :: (AsInteger f, Num f, Eq f, Fractional f)
+  => SRS
+  -> Integer
+  -> Commitment
+  -> f
+  -> Opening f
+  -> Bool
+pcV srs@SRS{..} maxm commitment z (v, w)
+  = reducedPairing w (hPositiveAlphaX !! 1) -- when i = 1
+    <>
+    (reducedPairing ((g1 `expn` v) <> (w `expn` (negate z))) (hPositiveAlphaX !! 0)) -- when i = 0
+    ==
+    (reducedPairing commitment hxi)
+  where
+    diff = fromInteger (-d + maxm)
+    hxi = if diff >= 0
+          then hPositiveX !! diff
+          else hNegativeX !! (abs diff - 1)
+

src/Sonic/Constraints.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE RecordWildCards, FlexibleInstances, OverlappingInstances, RankNTypes #-}
+module Sonic.Constraints where
+
+import Protolude hiding (head)
+import Data.List (zipWith4, head)
+import Pairing.CyclicGroup (CyclicGroup(..))
+import Pairing.Fr as Fr (Fr, new)
+import Bulletproofs.ArithmeticCircuit
+import Math.Polynomial (poly, Endianness(..))
+import Math.Polynomial.Laurent
+-- import Poly
+import Sonic.Utils
+
+compressMulConstraints :: Assignment Fr -> Fr -> Fr
+compressMulConstraints Assignment{..} y = sum $ zipWith4 f aL aR aO [1..]
+  where
+    f ai bi ci i = (ai * bi - ci) * ((y ^ i) + y ^ (-i))
+
+rPoly
+  :: (Eq f, Num f)
+  => Assignment f
+  -> Laurent (Laurent f)
+rPoly Assignment{..} =
+  newLaurent (negate (2 * n)) (reorder $ newLaurent 0 [] : (concat $ zipWith4 f aL aR aO [1..]))
+  where
+    f ai bi ci i = [newLaurent i [ai], newLaurent (-i) [bi], newLaurent (-i - n) [ci]]
+    reorder = sortBy (\l1 l2 -> compare (expLaurent l1) (expLaurent l2))
+    n = length aL
+
+sPoly
+  :: (Eq f, Num f)
+  => GateWeights f
+  -> Laurent (Laurent f)
+sPoly GateWeights{..}
+  = addLaurent
+      (addLaurent
+        (newLaurent (negate n) (zipWith f (reverse wL) [1..]))
+        (newLaurent 1 (zipWith f wR [1..]))
+      )
+      (newLaurent (n+1) (zipWith g wO [1..]))
+  where
+    f wi i = newLaurent (n+1) wi
+    g wi i = addLaurent
+      (addLaurent (newLaurent i [-1]) (newLaurent (-i) [-1]))
+      (newLaurent (n+1) wi)
+    n = length $ head wL
+    -- ^ size(wL) = Q x n
+
+tPoly
+  :: (Eq f, Num f, Fractional f)
+  => Laurent (Laurent f)
+  -> Laurent (Laurent f)
+  -> Laurent f
+  -> Laurent (Laurent f)
+tPoly rP sP kP
+  -- r(X, 1) * (r(X,Y) + s(X, Y)) - k(Y)
+  = addLaurent
+      (multLaurent
+        (convertToTwoVariateX $ evalOnY 1 rP)
+        (addLaurent rP sP)
+      )
+     (convertToTwoVariateY $ negate kP)
+
+polyK
+  :: (Eq f, Num f)
+  => [f]
+  -> Int
+  -> Laurent f
+polyK k n = newLaurent (n+1) k

src/Sonic/Protocol.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE RecordWildCards #-}
+module Sonic.Protocol where
+
+import Protolude hiding (head)
+import Data.List (head)
+import Crypto.Random (MonadRandom)
+import Crypto.Number.Generate (generateMax)
+import Pairing.Group as Group (G1, G2, GT, g1, g2, expn)
+import Pairing.CyclicGroup (AsInteger(..))
+import Bulletproofs.ArithmeticCircuit
+import Math.Polynomial.Laurent
+
+-- import Text.Pretty.Simple
+import Text.PrettyPrint.Leijen.Text as PP (pretty, Pretty(..))
+-- import Poly
+import Sonic.SRS
+import Sonic.Constraints
+import Sonic.CommitmentScheme
+import Sonic.Signature
+import Sonic.Utils as Utils
+
+data Proof f = Proof
+  { prR :: G1
+  , prT :: G1
+  , prA :: f
+  , prWa :: G1
+  , prB :: f
+  , prWb :: G1
+  , prWt :: G1
+  , prS :: f
+  , prHscProof :: HscProof f
+  , prt' :: f
+  }
+
+prover
+  :: (Num f, Eq f, Fractional f, AsInteger f, MonadRandom m)
+  => SRS
+  -> Assignment f
+  -> ArithCircuit f
+  -> f
+  -> f
+  -> m (Proof f, f, f, [f])
+prover srs assignment@Assignment{..} arithCircuit@ArithCircuit{..} alpha x = do
+  cns <- replicateM 4 Utils.random
+  let rXY = rPoly assignment
+      sumcXY = newLaurent
+                (negate (2 * n + 4))
+                (reverse $ zipWith (\cni i -> newLaurent (negate (2 * n + i)) [cni]) cns [1..])
+      polyR' = addLaurent rXY sumcXY
+      commitR = commitPoly srs (fromIntegral n) alpha x (evalOnY 1 polyR')
+  -- zkV -> zkP: Send y to prover
+  -- (Random oracle)
+  y <- Utils.random
+  let ky = polyK cs n
+  let sP = sPoly weights
+  let tP = tPoly polyR' sP ky
+  let commitT = commitPoly srs (d srs) alpha x (evalOnY y tP)
+  -- zkV -> zkP: Send y to prover
+  -- (Random oracle)
+  z <- Utils.random
+  let (a, wa) = openPoly srs commitR x z (evalOnY 1 polyR')
+      (b, wb) = openPoly srs commitR x (y * z) (evalOnY 1 polyR')
+      (t', wt) = openPoly srs commitT x z (evalOnY y tP)
+
+  let s = evalLaurent (evalOnY y sP) z
+  ys <- replicateM m Utils.random
+  hscProof <- hscP srs weights alpha x ys
+
+  pure ( Proof
+          { prR = commitR
+          , prT = commitT
+          , prA = a
+          , prWa = wa
+          , prB = b
+          , prWb = wb
+          , prWt = wt
+          , prS = s
+          , prHscProof = hscProof
+          }
+       , y
+       , z
+       , ys
+       )
+  where
+    n :: Int
+    n = length aL
+    m :: Int
+    m = length . wL $ weights
+
+verifier
+  :: (Num f, Eq f, Fractional f, AsInteger f)
+  => SRS
+  -> ArithCircuit f
+  -> Proof f
+  -> f
+  -> f
+  -> [f]
+  -> Bool
+verifier srs@SRS{..} ArithCircuit{..} Proof{..} y z ys
+  = let t = (prA * (prB + prS)) + (negate $ evalLaurent ky y)
+        checks = [ hscV srs ys weights prHscProof
+                , pcV srs (fromIntegral n) prR z (prA, prWa)
+                , pcV srs (fromIntegral n) prR (y * z) (prB, prWb)
+                , pcV srs d prT z (t, prWt)
+                ]
+    in and checks
+  where
+    n = length . head . wL $ weights
+    ky = polyK cs n

src/Sonic/SRS.hs

@@ -0,0 +1,38 @@
+module Sonic.SRS where
+
+import Protolude
+import Pairing.Group as Group (G1, G2, GT, g1, g2, expn)
+import Pairing.CyclicGroup (AsInteger(..))
+import Pairing.Fr as Fr (Fr, frInv)
+import Pairing.Pairing (reducedPairing)
+
+data SRS = SRS
+  { d :: Integer
+  , gNegativeX :: [G1]
+  , gPositiveX :: [G1]
+  , hNegativeX :: [G2]
+  , hPositiveX :: [G2]
+  , gNegativeAlphaX :: [G1]
+  , gPositiveAlphaX :: [G1]
+  , hNegativeAlphaX :: [G2]
+  , hPositiveAlphaX :: [G2]
+  , srsPairing :: GT
+  }
+
+new :: (Num f, Eq f, Fractional f, AsInteger f) => Integer -> f -> f -> SRS
+new d x alpha
+  = let xInv = recip x
+    in SRS
+        { d = d
+        , gNegativeX = (\i -> expn g1 (xInv ^ i)) <$> [1..d]
+        , gPositiveX = (\i -> expn g1 (x ^ i)) <$> [0..d]
+        , hNegativeX = (\i -> expn g2 (xInv ^ i)) <$> [1..d]
+        , hPositiveX = (\i -> expn g2 (x ^ i)) <$> [0..d]
+        -- Notice that we omit g^alpha, i.e. when i=0
+        , gNegativeAlphaX = (\i -> expn g1 (alpha * (xInv ^ i))) <$> [1..d]
+        , gPositiveAlphaX = (\i -> expn g1 (alpha * (x ^ i))) <$> [1..d]
+        , hNegativeAlphaX = (\i -> expn g2 (alpha * (xInv ^ i))) <$> [1..d]
+        , hPositiveAlphaX = (\i -> expn g2 (alpha * (x ^ i))) <$> [0..d]
+        , srsPairing = reducedPairing g1 (expn g2 alpha)
+        }
+