Merge pull request #84 from zkFold/eitan-binary2

Binary package and class

.github/workflows/main-pull.yml

@@ -34,7 +34,7 @@ jobs:
           ${{ runner.os }}-
 
     - name: Install stylish-haskell
-      run: cabal install stylish-haskell
+      run: cabal install stylish-haskell --overwrite-policy=always
 
     - name: Run stylish-haskell
       run: |

examples/Examples/MiMCHash.hs

@@ -19,4 +19,3 @@ exampleMiMC = do
     putStrLn "\nExample: MiMC hash function\n"
 
     compileIO @(Zp BLS12_381_Scalar) file (mimcHash @(ArithmeticCircuit (Zp BLS12_381_Scalar)) nRounds zero)
-

src/ZkFold/Base/Algebra/Basic/Field.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes  #-}
+{-# LANGUAGE DerivingStrategies   #-}
 {-# LANGUAGE OverloadedLists      #-}
 {-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE TypeOperators        #-}
@@ -143,11 +144,7 @@ instance ToJSON (Zp p) where
 instance FromJSON (Zp p) where
     parseJSON = fmap Zp . parseJSON
 
-instance ToByteString (Zp p) where
-    toByteString (Zp a) = toByteString a
-
-instance FromByteString (Zp p) where
-    fromByteString = fmap Zp . fromByteString
+deriving newtype instance Binary (Zp p)
 
 instance KnownNat p => Arbitrary (Zp p) where
     arbitrary = toZp <$> chooseInteger (0, fromIntegral (order @(Zp p)) - 1)
@@ -225,8 +222,9 @@ instance (Field f, Eq f, IrreduciblePoly f e) => Semiring (Ext2 f e)
 
 instance (Field f, Eq f, IrreduciblePoly f e) => Ring (Ext2 f e)
 
-instance ToByteString f => ToByteString (Ext2 f e) where
-    toByteString (Ext2 a b) = toByteString a <> toByteString b
+instance Binary f => Binary (Ext2 f e) where
+    put (Ext2 a b) = put a <> put b
+    get = Ext2 <$> get <*> get
 
 instance (Field f, Eq f, IrreduciblePoly f e, Arbitrary f) => Arbitrary (Ext2 f e) where
     arbitrary = Ext2 <$> arbitrary <*> arbitrary
@@ -284,8 +282,9 @@ instance (Field f, Eq f, IrreduciblePoly f e) => Semiring (Ext3 f e)
 
 instance (Field f, Eq f, IrreduciblePoly f e) => Ring (Ext3 f e)
 
-instance ToByteString f => ToByteString (Ext3 f e) where
-    toByteString (Ext3 a b c) = toByteString a <> toByteString b <> toByteString c
+instance Binary f => Binary (Ext3 f e) where
+    put (Ext3 a b c) = put a <> put b <> put c
+    get = Ext3 <$> get <*> get <*> get
 
 instance (Field f, Eq f, IrreduciblePoly f e, Arbitrary f) => Arbitrary (Ext3 f e) where
     arbitrary = Ext3 <$> arbitrary <*> arbitrary <*> arbitrary

src/ZkFold/Base/Algebra/EllipticCurve/Class.hs

@@ -9,15 +9,15 @@ import qualified Prelude                         as Haskell
 import           Test.QuickCheck                 hiding (scale)
 
 import           ZkFold.Base.Algebra.Basic.Class
-import           ZkFold.Base.Data.ByteString     (ToByteString (..))
+import           ZkFold.Base.Data.ByteString
 
 type family BaseField curve
 
 type family ScalarField curve
 
 data Point curve = Point (BaseField curve) (BaseField curve) | Inf
 
-class (FiniteField (BaseField curve), Eq (BaseField curve), Show (BaseField curve), ToByteString (BaseField curve),
+class (FiniteField (BaseField curve), Eq (BaseField curve), Show (BaseField curve), Binary (BaseField curve),
       Haskell.Show (ScalarField curve), Haskell.Num (ScalarField curve), Haskell.Ord (ScalarField curve),
       PrimeField (ScalarField curve), Eq (ScalarField curve), BinaryExpansion (ScalarField curve), Arbitrary (ScalarField curve)
     ) => EllipticCurve curve where
@@ -54,9 +54,18 @@ instance EllipticCurve curve => Scale Integer (Point curve) where
 instance EllipticCurve curve => AdditiveGroup (Point curve) where
     negate = pointNegate
 
-instance EllipticCurve curve => ToByteString (Point curve) where
-    toByteString Inf         = toByteString (0 :: Integer)
-    toByteString (Point x y) = toByteString (1 :: Integer) <> toByteString x <> toByteString y
+instance EllipticCurve curve => Binary (Point curve) where
+    -- TODO: Point Compression
+    -- When we know the equation of an elliptic curve, y^2 = x^3 + a * x + b
+    -- then we only need to retain a flag sign byte,
+    -- and the x-value to reconstruct the y-value of a point.
+    put Inf         = putWord8 0
+    put (Point x y) = putWord8 1 <> put x <> put y
+    get = do
+        flag <- getWord8
+        if flag == 0 then return Inf
+        else if flag == 1 then Point <$> get <*> get
+        else fail ("Binary (Point curve): unexpected flag " <> show flag)
 
 instance EllipticCurve curve => Arbitrary (Point curve) where
     arbitrary = arbitrary <&> (`mul` gen)

src/ZkFold/Base/Data/ByteString.hs

@@ -1,52 +1,46 @@
-module ZkFold.Base.Data.ByteString where
-
-import           Data.ByteString (ByteString, cons, empty, uncons)
-import           Data.Map        (Map, toList)
-import qualified Data.Vector     as V
-import           Data.Word       (Word8)
+{-# LANGUAGE DerivingStrategies #-}
+
+module ZkFold.Base.Data.ByteString
+  ( Binary (..)
+  , toByteString
+  , fromByteString
+  , putWord8
+  , getWord8
+  , LittleEndian (..)
+  ) where
+
+import           Control.Applicative  (many)
+import           Data.Binary
+import           Data.Binary.Get
+import           Data.Binary.Put
+import qualified Data.ByteString      as Strict
+import qualified Data.ByteString.Lazy as Lazy
+import           Data.Foldable        (foldl')
+import           Numeric.Natural      (Natural)
 import           Prelude
 
--- This module is currently used for transcripts in non-interactive proof protocols.
--- TODO (Issue #19): use a serialisation library instead
-
-class ToByteString a where
-    toByteString :: a -> ByteString
-
-instance ToByteString ByteString where
-    toByteString = id
-
--- Little-endian encoding for unsigned integers
-instance ToByteString Integer where
-    toByteString n
-        | n < 0     = error "ToByteString: Negative numbers are not supported"
-        | n == 0    = empty
-        | otherwise =
-            let bs = toByteString (n `div` 256)
-                b  = fromIntegral (n `mod` 256) :: Word8
-            in b `cons` bs
-
-instance (ToByteString a, ToByteString b) => ToByteString (a, b) where
-    toByteString (a, b) = toByteString a <> toByteString b
-
-instance ToByteString a => ToByteString [a] where
-    toByteString = foldMap toByteString
-
-instance ToByteString a => ToByteString (V.Vector a) where
-    toByteString = V.foldMap toByteString
-
-instance (ToByteString k, ToByteString a) => ToByteString (Map k a) where
-    toByteString = toByteString . toList
-
-class FromByteString a where
-    fromByteString :: ByteString -> Maybe a
-
-instance FromByteString ByteString where
-    fromByteString = Just
-
-instance FromByteString Integer where
-    fromByteString bs
-        | bs == empty = Just 0
-        | otherwise   = do
-            (b, bs') <- uncons bs
-            let r = fromIntegral b :: Integer
-            (r +) . (256 *) <$> fromByteString bs'
+toByteString :: Binary a => a -> Strict.ByteString
+toByteString = Lazy.toStrict . runPut . put
+
+fromByteString :: Binary a => Strict.ByteString -> Maybe a
+fromByteString x = case runGetOrFail get (Lazy.fromStrict x) of
+  Left _ -> Nothing
+  Right (leftover, _, a) ->
+    if Lazy.null leftover then Just a else Nothing
+
+-- Little-endian encoding for unsigned & unsized integers
+-- un little, deux little, trois little endians
+newtype LittleEndian = LittleEndian {unLittleEndian :: Natural}
+  deriving stock (Read, Show)
+  deriving newtype (Eq, Ord, Num, Enum, Real, Integral)
+instance Binary LittleEndian where
+  get = do
+    ns <- many getWord8
+    let accum n w8 = n * 256 + fromIntegral w8
+        littleEndian = LittleEndian (foldl' accum 0 ns)
+    return littleEndian
+  put (LittleEndian n)
+    | n == 0 = mempty
+    | otherwise =
+      let (n', r) = n `divMod` 256
+      in putWord8 (fromIntegral r) <> put (LittleEndian n')

src/ZkFold/Base/Data/Sparse/Vector.hs

@@ -1,6 +1,6 @@
 module ZkFold.Base.Data.Sparse.Vector where
 
-import           Data.Map                         (Map, empty, filter, map)
+import           Data.Map                         (Map, empty, filter, fromList, map, toList)
 import           Data.These                       (These (..))
 import           Data.Zip                         (Semialign (..), Zip (..))
 import           Prelude                          hiding (Num (..), filter, length, map, sum, zip, zipWith, (/))
@@ -9,13 +9,14 @@ import           Test.QuickCheck                  (Arbitrary (..))
 import           ZkFold.Base.Algebra.Basic.Class
 import           ZkFold.Base.Algebra.Basic.Field  (Zp)
 import           ZkFold.Base.Algebra.Basic.Number (KnownNat)
-import           ZkFold.Base.Data.ByteString      (ToByteString (..))
+import           ZkFold.Base.Data.ByteString      (Binary (..))
 
 newtype SVector size a = SVector { fromSVector :: Map (Zp size) a }
     deriving (Show, Eq)
 
-instance ToByteString a => ToByteString (SVector n a) where
-    toByteString = toByteString . fromSVector
+instance (Binary a, KnownNat n) => Binary (SVector n a) where
+    put = put . toList . fromSVector
+    get = SVector . fromList <$> get
 
 instance Foldable (SVector size) where
     foldr f z (SVector as) = foldr f z as

src/ZkFold/Base/Data/Vector.hs

@@ -13,7 +13,7 @@ import           Test.QuickCheck                  (Arbitrary (..))
 
 import           ZkFold.Base.Algebra.Basic.Class
 import           ZkFold.Base.Algebra.Basic.Number
-import           ZkFold.Base.Data.ByteString      (ToByteString (..))
+import           ZkFold.Base.Data.ByteString      (Binary (..))
 import           ZkFold.Prelude                   (length, replicate)
 
 newtype Vector (size :: Natural) a = Vector [a]
@@ -33,8 +33,9 @@ vectorDotProduct (Vector as) (Vector bs) = sum $ zipWith (*) as bs
 concat :: Vector m (Vector n a) -> Vector (m * n) a
 concat = Vector . concatMap fromVector
 
-instance ToByteString a => ToByteString (Vector n a) where
-    toByteString = toByteString . fromVector
+instance Binary a => Binary (Vector n a) where
+    put = put . fromVector
+    get = Vector <$> get
 
 instance KnownNat size => Applicative (Vector size) where
     pure a = Vector $ replicate (value @size) a

src/ZkFold/Base/Protocol/ARK/Protostar/CommitOpen.hs

@@ -1,19 +1,25 @@
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module ZkFold.Base.Protocol.ARK.Protostar.CommitOpen where
 
 import           Prelude                                         hiding (length)
 
-import           ZkFold.Base.Data.ByteString                     (ToByteString (..))
+import           ZkFold.Base.Data.ByteString
 import           ZkFold.Base.Protocol.ARK.Protostar.SpecialSound (SpecialSoundProtocol (..), SpecialSoundTranscript)
 import           ZkFold.Prelude                                  (length)
 
 data CommitOpen f c a = CommitOpen (ProverMessage f a -> c) a
 
 data CommitOpenProverMessage t c a = Commit c | Open [ProverMessage t a]
-instance ToByteString c => ToByteString (CommitOpenProverMessage t c a) where
-      toByteString (Commit c) = toByteString c
-      toByteString _          = mempty
+instance (Binary c, Binary (ProverMessage t a)) => Binary (CommitOpenProverMessage t c a) where
+      put (Commit c)  = putWord8 0 <> put c
+      put (Open msgs) = putWord8 1 <> put msgs
+      get = do
+            flag <- getWord8
+            if flag == 0 then Commit <$> get
+            else if flag == 1 then Open <$> get
+            else fail ("Binary (CommitOpenProverMessage t c a): unexpected flag " <> show flag)
 
 instance (SpecialSoundProtocol f a, Eq c) => SpecialSoundProtocol f (CommitOpen f c a) where
       type Witness f (CommitOpen f c a)         = (Witness f a, [ProverMessage f a])

src/ZkFold/Base/Protocol/ARK/Protostar/FiatShamir.hs

@@ -6,7 +6,7 @@ module ZkFold.Base.Protocol.ARK.Protostar.FiatShamir where
 import           Data.ByteString                                 (ByteString)
 import           Prelude                                         hiding (length)
 
-import           ZkFold.Base.Data.ByteString                     (FromByteString, ToByteString (..))
+import           ZkFold.Base.Data.ByteString                     (Binary (..))
 import           ZkFold.Base.Protocol.ARK.Protostar.CommitOpen
 import qualified ZkFold.Base.Protocol.ARK.Protostar.SpecialSound as SpS
 import           ZkFold.Base.Protocol.ARK.Protostar.SpecialSound (SpecialSoundProtocol (..), SpecialSoundTranscript)
@@ -15,16 +15,16 @@ import           ZkFold.Base.Protocol.NonInteractiveProof        (NonInteractive
 
 data FiatShamir f a = FiatShamir a (SpS.Input f a)
 
-fsChallenge :: forall f a c . (ToByteString (SpS.Input f a), FromByteString (VerifierMessage f a),
-      ToByteString c, ToByteString (VerifierMessage f a)) => FiatShamir f (CommitOpen f c a)
+fsChallenge :: forall f a c . (Binary (SpS.Input f a), Binary (VerifierMessage f a))
+      => FiatShamir f (CommitOpen f c a)
       -> SpecialSoundTranscript f (CommitOpen f c a) -> ProverMessage f (CommitOpen f c a) -> VerifierMessage f a
 fsChallenge (FiatShamir _ ip) []           c =
       let r0 = fst $ challenge @ByteString $ toTranscript ip :: VerifierMessage f a
       in fst $ challenge @ByteString $ toTranscript r0 <> toTranscript c
 fsChallenge _                 ((_, r) : _) c = fst $ challenge @ByteString $ toTranscript r <> toTranscript c
 
-instance (SpS.SpecialSoundProtocol f a, Eq c, ToByteString (SpS.Input f a), FromByteString (VerifierMessage f a),
-            ToByteString c, ToByteString (VerifierMessage f a)) => NonInteractiveProof (FiatShamir f (CommitOpen f c a)) where
+instance (SpS.SpecialSoundProtocol f a, Eq c, Binary (SpS.Input f a), Binary (VerifierMessage f a),
+            Binary c, Binary (VerifierMessage f a)) => NonInteractiveProof (FiatShamir f (CommitOpen f c a)) where
       type Transcript (FiatShamir f (CommitOpen f c a)) = ByteString
       type Setup (FiatShamir f (CommitOpen f c a))      = FiatShamir f (CommitOpen f c a)
       type Witness (FiatShamir f (CommitOpen f c a))    = SpS.Witness f a

src/ZkFold/Base/Protocol/Commitment/KZG.hs

@@ -9,6 +9,7 @@ import           Data.ByteString                            (ByteString, empty)
 import           Data.Kind                                  (Type)
 import           Data.Map.Strict                            (Map, fromList, insert, keys, toList, (!))
 import qualified Data.Vector                                as V
+import           Data.Vector.Binary                         ()
 import           Numeric.Natural                            (Natural)
 import           Prelude                                    hiding (Num (..), length, sum, (/), (^))
 import           Test.QuickCheck                            (Arbitrary (..), chooseInt)
@@ -17,7 +18,7 @@ import           ZkFold.Base.Algebra.Basic.Class
 import           ZkFold.Base.Algebra.Basic.Number
 import           ZkFold.Base.Algebra.EllipticCurve.Class
 import           ZkFold.Base.Algebra.Polynomials.Univariate
-import           ZkFold.Base.Data.ByteString                (FromByteString, ToByteString)
+import           ZkFold.Base.Data.ByteString                (Binary)
 import           ZkFold.Base.Protocol.NonInteractiveProof
 
 -- | `d` is the degree of polynomials in the protocol
@@ -35,7 +36,7 @@ instance (EllipticCurve c1, f ~ ScalarField c1, KnownNat d) => Arbitrary (Witnes
 
 -- TODO (Issue #18): check list lengths
 instance forall (c1 :: Type) (c2 :: Type) t f d kzg . (f ~ ScalarField c1, f ~ ScalarField c2,
-        Pairing c1 c2 t, ToByteString f, FromByteString f, KnownNat d, KZG c1 c2 t f d ~ kzg)
+        Pairing c1 c2 t, Binary f, KnownNat d, KZG c1 c2 t f d ~ kzg)
         => NonInteractiveProof (KZG c1 c2 t f d) where
     type Transcript (KZG c1 c2 t f d)   = ByteString
     type Setup (KZG c1 c2 t f d)        = (V.Vector (Point c1), Point c2, Point c2)

src/ZkFold/Base/Protocol/NonInteractiveProof.hs

@@ -9,12 +9,12 @@ import           Data.Maybe                  (fromJust)
 import           Numeric.Natural             (Natural)
 import           Prelude
 
-import           ZkFold.Base.Data.ByteString (FromByteString (..), ToByteString (..))
+import           ZkFold.Base.Data.ByteString
 
 class Monoid t => ToTranscript t a where
     toTranscript :: a -> t
 
-instance ToByteString a => ToTranscript ByteString a where
+instance Binary a => ToTranscript ByteString a where
     toTranscript = toByteString
 
 transcript :: ToTranscript t a => t -> a -> t
@@ -24,7 +24,7 @@ class Monoid t => FromTranscript t a where
     newTranscript  :: t -> t
     fromTranscript :: t -> a
 
-instance FromByteString a => FromTranscript ByteString a where
+instance Binary a => FromTranscript ByteString a where
     newTranscript  = cons 0
     fromTranscript = fromJust . fromByteString . hash
 

src/ZkFold/Symbolic/Algorithms/Hash/MiMC/Constants.hs

@@ -5,16 +5,18 @@ import           Data.Maybe                      (fromJust)
 import           Prelude
 
 import           ZkFold.Base.Algebra.Basic.Class (FromConstant (..))
-import           ZkFold.Base.Data.ByteString     (FromByteString (..), ToByteString (..))
+import           ZkFold.Base.Data.ByteString
 import           ZkFold.Symbolic.Types           (I)
 
-mimcSeed :: Integer
+mimcSeed :: LittleEndian
 mimcSeed = 42
 
 -- | The round constants ci are random elements of F_2n except for the first and
 --   last round constants which are equal to 0.
 --
 mimcConstants :: forall a . (FromConstant I a) => [a]
 mimcConstants =
-  let cs = take 218 $ map (fromJust . fromByteString) $ iterate hash $ toByteString mimcSeed
+  let
+    getI = fromIntegral . fromJust . fromByteString @LittleEndian
+    cs = take 218 $ map getI $ iterate hash $ toByteString mimcSeed
   in map (fromConstant @I @a) (0 : cs ++ [0])

zkfold-base.cabal

@@ -155,6 +155,7 @@ library
     build-depends:
       base                          >= 4.9 && < 5,
       aeson                                 < 2.3,
+      binary                               < 0.11,
       bytestring                           < 0.12,
       containers                            < 0.7,
       cryptohash-sha256                    < 0.12,
@@ -168,7 +169,8 @@ library
       split                               < 0.2.6,
       tfp                                   < 1.1,
       these                                 < 1.3,
-      vector                                < 0.14
+      vector                                < 0.14,
+      vector-binary-instances               < 0.3
     hs-source-dirs: src
 
 test-suite zkfold-base-test