From 71667697986f1676c659d28d7e83c7f9729d5cac Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 10 Jun 2024 19:09:46 +0200 Subject: [PATCH 01/17] Add (failing) test for retry logic * Also add manual serialisation of Proof + roundtrip test as it cannot be automatically derived anymore * Write a test that crashes because proof cannot be generated * Add a retryCount field for the Proof to implement the logic --- src/ALBA.hs | 27 ++++++++++++++++++++++----- test/ALBASpec.hs | 35 +++++++++++++++++++++++++++++++---- 2 files changed, 53 insertions(+), 9 deletions(-) diff --git a/src/ALBA.hs b/src/ALBA.hs index 249cf92..fea02d7 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -20,11 +20,12 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Hex import Data.ByteString.Internal (unsafeCreate) import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize, decode, encode, getWord64le, putWord64le, runGet, runPut) +import Data.Serialize (Serialize (..), decode, encode, getWord64le, putWord64le, runGet, runPut) import Data.String (IsString (..)) import Data.Word (Word64) import Foreign (Ptr, Word8, castPtr, countTrailingZeros) import Foreign.C (errnoToIOError, getErrno) +import GHC.Generics (Generic) import GHC.IO.Exception (ioException) import Test.QuickCheck (Gen, arbitrary, sized, vectorOf) @@ -54,9 +55,25 @@ data Params = Params -- | Weight function for type `a`. type W a = a -> Int -newtype Proof = Proof (Integer, [Bytes]) +data Proof = Proof + { index :: Integer + -- ^ The initial index with which the proof was generated + , retryCount :: Integer + , elements :: [Bytes] + } deriving (Show, Eq) - deriving newtype (Serialize) + +instance Serialize Proof where + put Proof{index, retryCount, elements} = do + put index + put retryCount + put elements + + get = do + index <- get + retryCount <- get + elements <- get + pure $ Proof index retryCount elements newtype Hash where Hash :: ByteString -> Hash @@ -145,7 +162,7 @@ prove params@Params{n_p} s_p = let h_i = h_j <> h_si n_pj' = h_i `oracle` prob_q in if n_pj' == 0 - then Just $ Proof (n, s_i : acc) + then Just $ Proof n 0 (s_i : acc) else go 0 rest (n, acc, h_j, n_pj) go _ [] _ = Nothing go k ((s_i, (h_si, n_pi)) : rest) (n, acc, h_j, n_pj) = @@ -262,7 +279,7 @@ data Verification -- | Verify `Proof` that the set of elements known to the prover `s_p` has size greater than $n_f$. verify :: Params -> Proof -> Verification -verify params@Params{n_p} proof@(Proof (d, bs)) = +verify params@Params{n_p} proof@(Proof d _ bs) = let (u, _, q) = computeParams params check item = \case diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index f05e71b..93c2b46 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -30,12 +30,13 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Function ((&)) import qualified Data.List as List -import Data.Serialize (encode) +import Data.Serialize (decode, encode) import Data.Word (Word64) import Debug.Trace import Test.Hspec (Spec, SpecWith, describe, it, shouldBe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck ( + Arbitrary, Gen, Large (..), Positive (..), @@ -94,6 +95,25 @@ spec = do prop "can verify large proof is valid" $ prop_verifyValidProof 400 1000 prop "can reject proof if items are tampered with" prop_rejectTamperedProof + prop "can roundtrip serialisation of proof" prop_roundtripProof + prop "needs to retry when proof is stuck from repeated elements" prop_retryOnStuckProof + +prop_roundtripProof :: Proof -> Property +prop_roundtripProof proof = + let bs = encode proof + in decode bs === Right proof + +prop_retryOnStuckProof :: Property +prop_retryOnStuckProof = + forAll (resize 100 (genItems 10)) $ \items -> do + let params = Params 16 16 80 20 + (u, _, q) = computeParams params + fewerItems = drop 80 items + proof@Proof{retryCount} = prove params fewerItems + verify params proof == Verified{proof, params} + && retryCount > 0 + & counterexample ("u = " <> show u <> ", q = " <> show q <> ", proof = " <> show proof <> ", retryCount = " <> show retryCount) + prop_oracleDistributionIsUniform :: Property prop_oracleDistributionIsUniform = forAll (resize 100 arbitrary) $ \(bytes :: ByteString) -> do @@ -128,10 +148,10 @@ genModifiedProof :: Params -> Gen (Proof, Proof) genModifiedProof params = do items <- resize 100 (genItems 100) let (u, _, q) = computeParams params - proof@(Proof (n, bs)) = prove params items + proof@(Proof n k bs) = prove params items frequency - [ (1, pure $ (proof, Proof (n + 1, bs))) - , (length items, ((proof,) . (Proof . (n,))) <$> flip1Bit bs) + [ (1, pure $ (proof, Proof (n + 1) k bs)) + , (length items, (proof,) . Proof n k <$> flip1Bit bs) ] prop_flip1Bit :: ByteString -> Property @@ -227,3 +247,10 @@ prop_isPowerOf2 = genPowerOf2 :: Gen Word64 genPowerOf2 = arbitrary >>= \(Positive (Small k)) -> pure $ 2 ^ k + +instance Arbitrary Proof where + arbitrary = do + items <- genItems 100 + n <- arbitrary + k <- arbitrary + pure $ Proof n k items From 507f83ebd34b3f89707dc5ad3f1d9948dda8a13f Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 10 Jun 2024 21:34:17 +0200 Subject: [PATCH 02/17] Make proof total by returning NoProof instead of error --- app/Main.hs | 10 ++++++---- src/ALBA.hs | 7 +++++-- test/ALBASpec.hs | 50 +++++++++++++++++++----------------------------- 3 files changed, 31 insertions(+), 36 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 9c8550f..18a785e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -import ALBA (Params (..), Verification (Verified), genItems, prove, readProof, verify, writeProof) +import ALBA (NoProof (..), Params (..), Verification (Verified), genItems, prove, readProof, verify, writeProof) import Data.Word (Word64) import System.Environment (getArgs) import System.Exit (ExitCode (..), exitSuccess, exitWith) @@ -38,9 +38,11 @@ main = do bs <- generate $ resize (fromIntegral size) $ genItems len let opts'@Options{params} = adjustForSize opts putStrLn $ "Generating proof " <> show opts' - let prf = prove params bs - writeProof output prf >>= \n -> - putStrLn ("Written proof to '" <> output <> "' (" <> show n <> " bytes)") + case prove params bs of + Left NoProof -> putStrLn "No proof could be generated" >> exitWith (ExitFailure 1) + Right prf -> + writeProof output prf >>= \n -> + putStrLn ("Written proof to '" <> output <> "' (" <> show n <> " bytes)") Verify opts@Options{size, len, params = pars@Params{n_p, n_f}, output} -> do let opts'@Options{params} = adjustForSize opts putStrLn $ "Verifying proof with " <> show opts' diff --git a/src/ALBA.hs b/src/ALBA.hs index fea02d7..bd8e64e 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -75,6 +75,9 @@ instance Serialize Proof where elements <- get pure $ Proof index retryCount elements +data NoProof = NoProof + deriving (Show, Eq) + newtype Hash where Hash :: ByteString -> Hash deriving newtype (Eq, NFData) @@ -131,9 +134,9 @@ genItems len = sized $ \n -> vectorOf n (Bytes . BS.pack <$> vectorOf len arbitr -- This version of `prove` is much more efficient than the original -- one as constructs the proof using depth-first search over the -- required length. -prove :: Params -> [Bytes] -> Proof +prove :: Params -> [Bytes] -> Either NoProof Proof prove params@Params{n_p} s_p = - fromMaybe (error "No valid proof") $ start round0 + maybe (Left NoProof) Right $ start round0 where preHash = zip s_p $ map (\bs -> let h = hash bs in (h, h `oracle` n_p)) s_p diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index 93c2b46..93d3ce6 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -7,24 +7,7 @@ module ALBASpec where -import ALBA ( - Bytes (..), - Hashable (..), - Params (..), - Proof (..), - Verification (..), - computeParams, - fromBytes, - fromBytesLE, - genItems, - isPowerOf2, - modBS, - modPowerOf2, - oracle, - prove, - toBytesLE, - verify, - ) +import ALBA (Bytes (..), Hashable (..), NoProof (..), Params (..), Proof (..), Verification (..), computeParams, fromBytes, fromBytesLE, genItems, isPowerOf2, modBS, modPowerOf2, oracle, prove, toBytesLE, verify) import Data.Bits (Bits (..), countTrailingZeros) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -109,10 +92,13 @@ prop_retryOnStuckProof = let params = Params 16 16 80 20 (u, _, q) = computeParams params fewerItems = drop 80 items - proof@Proof{retryCount} = prove params fewerItems - verify params proof == Verified{proof, params} - && retryCount > 0 - & counterexample ("u = " <> show u <> ", q = " <> show q <> ", proof = " <> show proof <> ", retryCount = " <> show retryCount) + in counterexample ("u = " <> show u <> ", q = " <> show q) $ + case prove params fewerItems of + Left NoProof -> property False + Right proof@Proof{retryCount} -> + verify params proof == Verified{proof, params} + && retryCount > 0 + & counterexample ("retryCount = " <> show retryCount) prop_oracleDistributionIsUniform :: Property prop_oracleDistributionIsUniform = @@ -148,11 +134,13 @@ genModifiedProof :: Params -> Gen (Proof, Proof) genModifiedProof params = do items <- resize 100 (genItems 100) let (u, _, q) = computeParams params - proof@(Proof n k bs) = prove params items - frequency - [ (1, pure $ (proof, Proof (n + 1) k bs)) - , (length items, (proof,) . Proof n k <$> flip1Bit bs) - ] + in case prove params items of + Left NoProof -> genModifiedProof params + Right proof@(Proof n k bs) -> + frequency + [ (1, pure $ (proof, Proof (n + 1) k bs)) + , (length items, (proof,) . Proof n k <$> flip1Bit bs) + ] prop_flip1Bit :: ByteString -> Property prop_flip1Bit bytes = @@ -194,9 +182,11 @@ prop_verifyValidProof itemSize numItems = forAll (resize (fromIntegral numItems) (genItems itemSize)) $ \items -> do let params = Params 8 8 (numItems * 8 `div` 10) (numItems * 2 `div` 10) (u, _, q) = computeParams params - proof = prove params items - verify params proof === Verified{proof, params} - & counterexample ("u = " <> show u <> ", q = " <> show q <> ", proof = " <> show proof) + in case prove params items of + Left NoProof -> property False + Right proof -> + verify params proof === Verified{proof, params} + & counterexample ("u = " <> show u <> ", q = " <> show q <> ", proof = " <> show proof) shrinkPowerOf2 :: Integer -> [Integer] shrinkPowerOf2 n From bf6795313bc2adecd5da5060d14e0f4b2084e63f Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 11 Jun 2024 06:20:21 +0200 Subject: [PATCH 03/17] Retry proof an unbounded number of times Property is a bit long to run as it now needs to repeat the whole proving process several times for a small set. --- src/ALBA.hs | 60 ++++++++++++++++++++++++++---------------------- test/ALBASpec.hs | 15 +++++++----- 2 files changed, 42 insertions(+), 33 deletions(-) diff --git a/src/ALBA.hs b/src/ALBA.hs index bd8e64e..7b35289 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -136,15 +136,21 @@ genItems len = sized $ \n -> vectorOf n (Bytes . BS.pack <$> vectorOf len arbitr -- required length. prove :: Params -> [Bytes] -> Either NoProof Proof prove params@Params{n_p} s_p = - maybe (Left NoProof) Right $ start round0 + maybe (Left NoProof) Right $ proveWithRetry 0 where - preHash = zip s_p $ map (\bs -> let h = hash bs in (h, h `oracle` n_p)) s_p - (u, d, q) = computeParams params prob_q = ceiling $ 1 / q - round0 = + proveWithRetry :: Integer -> Maybe Proof + proveWithRetry retryCount = + case start preHash (round0 preHash) of + Nothing -> proveWithRetry (retryCount + 1) + Just prf -> Just prf{retryCount} + where + preHash = zip s_p $ map (\bs -> let h = hash retryCount <> hash bs in (h, h `oracle` n_p)) s_p + + round0 preHash = [ (t, [s_i], h_0, n_p0) | (s_i, (h, l)) <- preHash , t <- [1 .. d] @@ -153,28 +159,28 @@ prove params@Params{n_p} s_p = , l == n_p0 ] - start :: [(Integer, [Bytes], Hash, Word64)] -> Maybe Proof - start [] = Nothing - start ((t, s_i, h_i, n_pi) : rest) = + start :: [(Bytes, (Hash, Word64))] -> [(Integer, [Bytes], Hash, Word64)] -> Maybe Proof + start _ [] = Nothing + start preHash ((t, s_i, h_i, n_pi) : rest) = case go (fromInteger $ u - 2) preHash (t, s_i, h_i, n_pi) of - Nothing -> start rest + Nothing -> start preHash rest prf -> prf - - go :: Int -> [(Bytes, (Hash, Word64))] -> (Integer, [Bytes], Hash, Word64) -> Maybe Proof - go 0 ((s_i, (h_si, _)) : rest) (n, acc, h_j, n_pj) = - let h_i = h_j <> h_si - n_pj' = h_i `oracle` prob_q - in if n_pj' == 0 - then Just $ Proof n 0 (s_i : acc) - else go 0 rest (n, acc, h_j, n_pj) - go _ [] _ = Nothing - go k ((s_i, (h_si, n_pi)) : rest) (n, acc, h_j, n_pj) = - let h_i = h_j <> h_si - in if n_pi == n_pj - then case go (k - 1) preHash (n, s_i : acc, h_i, h_i `oracle` n_p) of - Nothing -> go k rest (n, acc, h_j, n_pj) - prf -> prf - else go k rest (n, acc, h_j, n_pj) + where + go :: Int -> [(Bytes, (Hash, Word64))] -> (Integer, [Bytes], Hash, Word64) -> Maybe Proof + go 0 ((s_i, (h_si, _)) : rest) (n, acc, h_j, n_pj) = + let h_i = h_j <> h_si + n_pj' = h_i `oracle` prob_q + in if n_pj' == 0 + then Just $ Proof n 0 (s_i : acc) + else go 0 rest (n, acc, h_j, n_pj) + go _ [] _ = Nothing + go k ((s_i, (h_si, n_pi)) : rest) (n, acc, h_j, n_pj) = + let h_i = h_j <> h_si + in if n_pi == n_pj + then case go (k - 1) preHash (n, s_i : acc, h_i, h_i `oracle` n_p) of + Nothing -> go k rest (n, acc, h_j, n_pj) + prf -> prf + else go k rest (n, acc, h_j, n_pj) -- | Compute ALBA parameters: Length of proof, seed number, and probability of selecting last tuple. -- @@ -282,12 +288,12 @@ data Verification -- | Verify `Proof` that the set of elements known to the prover `s_p` has size greater than $n_f$. verify :: Params -> Proof -> Verification -verify params@Params{n_p} proof@(Proof d _ bs) = +verify params@Params{n_p} proof@(Proof d k bs) = let (u, _, q) = computeParams params check item = \case (v@Verified{}, _, []) -> - let h = hash item + let h = hash k <> hash item l = oracle h n_p h_0 = hash d <> h n_p0 = h_0 `oracle` n_p @@ -295,7 +301,7 @@ verify params@Params{n_p} proof@(Proof d _ bs) = in (m, h_0, [item]) (v@Verified{}, h_j, acc) -> let prf = item : acc - h_si = hash item + h_si = hash k <> hash item n_pi = h_si `oracle` n_p h_i = h_j <> h_si n_pj = oracle h_j n_p diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index 93d3ce6..8bcbc28 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -79,25 +79,28 @@ spec = do prop "can reject proof if items are tampered with" prop_rejectTamperedProof prop "can roundtrip serialisation of proof" prop_roundtripProof - prop "needs to retry when proof is stuck from repeated elements" prop_retryOnStuckProof + modifyMaxSuccess (const 30) $ + prop "needs to retry proving given number of elements is too small" prop_retryProofOnSmallSet prop_roundtripProof :: Proof -> Property prop_roundtripProof proof = let bs = encode proof in decode bs === Right proof -prop_retryOnStuckProof :: Property -prop_retryOnStuckProof = +prop_retryProofOnSmallSet :: Property +prop_retryProofOnSmallSet = forAll (resize 100 (genItems 10)) $ \items -> do let params = Params 16 16 80 20 (u, _, q) = computeParams params - fewerItems = drop 80 items + fewerItems = drop 70 items in counterexample ("u = " <> show u <> ", q = " <> show q) $ case prove params fewerItems of - Left NoProof -> property False + Left NoProof -> property True & label "no proof" Right proof@Proof{retryCount} -> verify params proof == Verified{proof, params} - && retryCount > 0 + & label ("retryCount <= " <> show ((retryCount `div` 10 + 1) * 10)) + & cover 60 (retryCount > 0) "retried proof" + & checkCoverage & counterexample ("retryCount = " <> show retryCount) prop_oracleDistributionIsUniform :: Property From 29d86bc306d31ef343956371ab4b1495c28a72c9 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 11 Jun 2024 07:36:53 +0200 Subject: [PATCH 04/17] =?UTF-8?q?Bound=20retries=20by=20=CE=BB=20security?= =?UTF-8?q?=20parameter?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/ALBA.hs | 23 ++++++++++++++--------- test/ALBASpec.hs | 21 +++++++++++++++------ 2 files changed, 29 insertions(+), 15 deletions(-) diff --git a/src/ALBA.hs b/src/ALBA.hs index 7b35289..2b9f863 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -75,8 +75,11 @@ instance Serialize Proof where elements <- get pure $ Proof index retryCount elements -data NoProof = NoProof - deriving (Show, Eq) +newtype NoProof = NoProof Retries + deriving stock (Show, Eq) + +newtype Retries = Retries Integer + deriving stock (Show, Eq) newtype Hash where Hash :: ByteString -> Hash @@ -135,18 +138,20 @@ genItems len = sized $ \n -> vectorOf n (Bytes . BS.pack <$> vectorOf len arbitr -- one as constructs the proof using depth-first search over the -- required length. prove :: Params -> [Bytes] -> Either NoProof Proof -prove params@Params{n_p} s_p = - maybe (Left NoProof) Right $ proveWithRetry 0 +prove params@Params{λ_sec, n_p} s_p = + proveWithRetry 0 where (u, d, q) = computeParams params prob_q = ceiling $ 1 / q - proveWithRetry :: Integer -> Maybe Proof - proveWithRetry retryCount = - case start preHash (round0 preHash) of - Nothing -> proveWithRetry (retryCount + 1) - Just prf -> Just prf{retryCount} + proveWithRetry :: Integer -> Either NoProof Proof + proveWithRetry retryCount + | retryCount >= λ_sec = Left $ NoProof $ Retries retryCount + | otherwise = + case start preHash (round0 preHash) of + Nothing -> proveWithRetry (retryCount + 1) + Just prf -> Right prf{retryCount} where preHash = zip s_p $ map (\bs -> let h = hash retryCount <> hash bs in (h, h `oracle` n_p)) s_p diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index 8bcbc28..16ddbd0 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -7,14 +7,14 @@ module ALBASpec where -import ALBA (Bytes (..), Hashable (..), NoProof (..), Params (..), Proof (..), Verification (..), computeParams, fromBytes, fromBytesLE, genItems, isPowerOf2, modBS, modPowerOf2, oracle, prove, toBytesLE, verify) +import ALBA (Bytes (..), Hashable (..), NoProof (..), Params (..), Proof (..), Retries (..), Verification (..), computeParams, fromBytes, fromBytesLE, genItems, isPowerOf2, modBS, modPowerOf2, oracle, prove, toBytesLE, verify) import Data.Bits (Bits (..), countTrailingZeros) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Function ((&)) import qualified Data.List as List import Data.Serialize (decode, encode) -import Data.Word (Word64) +import Data.Word (Word64, Word8) import Debug.Trace import Test.Hspec (Spec, SpecWith, describe, it, shouldBe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) @@ -79,8 +79,17 @@ spec = do prop "can reject proof if items are tampered with" prop_rejectTamperedProof prop "can roundtrip serialisation of proof" prop_roundtripProof - modifyMaxSuccess (const 30) $ + modifyMaxSuccess (const 30) $ do prop "needs to retry proving given number of elements is too small" prop_retryProofOnSmallSet + prop "stops retrying proof after λ attempts" prop_stopRetryingProof + +prop_stopRetryingProof :: Property +prop_stopRetryingProof = + forAll (resize 100 (genItems 10)) $ \items -> + forAll (choose (16, 32)) $ \λ -> + let params = Params λ λ 80 20 + fewerItems = drop 81 items + in prove params fewerItems === Left (NoProof $ Retries λ) prop_roundtripProof :: Proof -> Property prop_roundtripProof proof = @@ -95,7 +104,7 @@ prop_retryProofOnSmallSet = fewerItems = drop 70 items in counterexample ("u = " <> show u <> ", q = " <> show q) $ case prove params fewerItems of - Left NoProof -> property True & label "no proof" + Left (NoProof _) -> property True & label "no proof" Right proof@Proof{retryCount} -> verify params proof == Verified{proof, params} & label ("retryCount <= " <> show ((retryCount `div` 10 + 1) * 10)) @@ -138,7 +147,7 @@ genModifiedProof params = do items <- resize 100 (genItems 100) let (u, _, q) = computeParams params in case prove params items of - Left NoProof -> genModifiedProof params + Left (NoProof _) -> genModifiedProof params Right proof@(Proof n k bs) -> frequency [ (1, pure $ (proof, Proof (n + 1) k bs)) @@ -186,7 +195,7 @@ prop_verifyValidProof itemSize numItems = let params = Params 8 8 (numItems * 8 `div` 10) (numItems * 2 `div` 10) (u, _, q) = computeParams params in case prove params items of - Left NoProof -> property False + Left (NoProof _) -> property False Right proof -> verify params proof === Verified{proof, params} & counterexample ("u = " <> show u <> ", q = " <> show q <> ", proof = " <> show proof) From b59ad3e2c1188012269262617c47bc9fd7bfaa70 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sat, 15 Jun 2024 08:24:52 +0200 Subject: [PATCH 05/17] Introduce test and State monad to accumulate hash counts --- alba.cabal | 11 ++-- src/ALBA.hs | 135 +++++++++++++++++++++++++++++------------------ test/ALBASpec.hs | 36 ++++++++++++- 3 files changed, 125 insertions(+), 57 deletions(-) diff --git a/alba.cabal b/alba.cabal index 9ddb9f7..5ef0a86 100644 --- a/alba.cabal +++ b/alba.cabal @@ -20,11 +20,12 @@ library hs-source-dirs: src build-depends: base >=4.9 && <5 - , QuickCheck - , base16-bytestring - , bytestring - , cereal - , deepseq + , QuickCheck + , base16-bytestring + , bytestring + , cereal + , deepseq + , mtl default-extensions: StrictData default-language: Haskell2010 ghc-options: -Wall -Wunused-packages diff --git a/src/ALBA.hs b/src/ALBA.hs index 2b9f863..d52c0f5 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -10,22 +10,50 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module ALBA where +{- HLINT ignore "Redundant do" -} + +module ALBA ( + -- * API + + -- ** Core Functions + prove, + verify, + + -- ** Utilities + computeParams, + genItems, + oracle, + writeProof, + readProof, + fromBytesLE, + toBytesLE, + modPowerOf2, + isPowerOf2, + + -- * Types + Bytes (..), + Params (..), + Proof (..), + NoProof (..), + Hashable (..), + Retries (..), + Verification (..), +) +where import Control.DeepSeq (NFData) import Control.Monad (unless) +import Control.Monad.State.Strict (State, evalState) import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize, (.&.), (.<<.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Hex import Data.ByteString.Internal (unsafeCreate) -import Data.Maybe (fromMaybe) import Data.Serialize (Serialize (..), decode, encode, getWord64le, putWord64le, runGet, runPut) import Data.String (IsString (..)) import Data.Word (Word64) import Foreign (Ptr, Word8, castPtr, countTrailingZeros) import Foreign.C (errnoToIOError, getErrno) -import GHC.Generics (Generic) import GHC.IO.Exception (ioException) import Test.QuickCheck (Gen, arbitrary, sized, vectorOf) @@ -37,29 +65,28 @@ foreign import capi unsafe "blake2b.h blake2b256_hash" blake2b256_hash :: Ptr Wo -- such that $|S_p| \geq n_p$, the prover can convince the verifier that $|S_p| \geq n_f$ -- with $n_f < n_p$. data Params = Params - { λ_sec :: Integer + { λ_sec :: !Integer -- ^ Security parameter -- Controls the probability that `extract` returns a set of size less than `n_f`. -- 128 seems like a good value - , λ_rel :: Integer + , λ_rel :: !Integer -- ^ Verification parameter. -- Controls the probability that `verify` returns `True` when the proof is invalid. -- 128 seems like a good value - , n_p :: Word64 + , n_p :: !Word64 -- ^ Estimated size of "honest" parties set. - , n_f :: Word64 + , n_f :: !Word64 -- ^ Estimated size of "adversarial" parties set. } deriving (Show, Eq) --- | Weight function for type `a`. -type W a = a -> Int - data Proof = Proof - { index :: Integer + { index :: !Integer -- ^ The initial index with which the proof was generated - , retryCount :: Integer - , elements :: [Bytes] + , retryCount :: !Integer + -- ^ Number of retries before a proof was generated + , elements :: ![Bytes] + -- ^ The set of elements witnessing knowledge of a set of size greater than $n_f$. } deriving (Show, Eq) @@ -132,6 +159,14 @@ instance IsString Bytes where genItems :: Int -> Gen [Bytes] genItems len = sized $ \n -> vectorOf n (Bytes . BS.pack <$> vectorOf len arbitrary) +data ProofStep = ProofStep + { t :: !Integer + , s :: ![Bytes] + , h :: !Hash + , n :: !Word64 + } + deriving (Show, Eq) + -- | Output a proof `the set of elements known to the prover `s_p` has size greater than $n_f$. -- -- This version of `prove` is much more efficient than the original @@ -139,53 +174,59 @@ genItems len = sized $ \n -> vectorOf n (Bytes . BS.pack <$> vectorOf len arbitr -- required length. prove :: Params -> [Bytes] -> Either NoProof Proof prove params@Params{λ_sec, n_p} s_p = - proveWithRetry 0 + evalState (proveWithRetry 0) 0 where + hashBounds = λ_sec * λ_sec + (u, d, q) = computeParams params prob_q = ceiling $ 1 / q - proveWithRetry :: Integer -> Either NoProof Proof + proveWithRetry :: Integer -> State Int (Either NoProof Proof) proveWithRetry retryCount - | retryCount >= λ_sec = Left $ NoProof $ Retries retryCount - | otherwise = - case start preHash (round0 preHash) of + | retryCount >= λ_sec = pure $ Left $ NoProof $ Retries retryCount + | otherwise = do + step0 <- round0 preHash + stepn <- start preHash step0 + case stepn of Nothing -> proveWithRetry (retryCount + 1) - Just prf -> Right prf{retryCount} + Just prf -> pure $ Right prf{retryCount} where preHash = zip s_p $ map (\bs -> let h = hash retryCount <> hash bs in (h, h `oracle` n_p)) s_p + round0 :: [(Bytes, (Hash, Word64))] -> State Int [ProofStep] round0 preHash = - [ (t, [s_i], h_0, n_p0) - | (s_i, (h, l)) <- preHash - , t <- [1 .. d] - , let !h_0 = hash t <> h - , let n_p0 = h_0 `oracle` n_p - , l == n_p0 - ] - - start :: [(Bytes, (Hash, Word64))] -> [(Integer, [Bytes], Hash, Word64)] -> Maybe Proof - start _ [] = Nothing - start preHash ((t, s_i, h_i, n_pi) : rest) = - case go (fromInteger $ u - 2) preHash (t, s_i, h_i, n_pi) of - Nothing -> start preHash rest - prf -> prf + pure + [ ProofStep t [s_i] h_0 n_p0 + | (s_i, (h, l)) <- preHash + , t <- [1 .. d] + , let !h_0 = hash t <> h + , let n_p0 = h_0 `oracle` n_p + , l == n_p0 + ] + + start :: [(Bytes, (Hash, Word64))] -> [ProofStep] -> State Int (Maybe Proof) + start _ [] = pure Nothing + start preHash (element : elements) = + case go (fromInteger $ u - 2) preHash element of + Nothing -> start preHash elements + prf -> pure prf where - go :: Int -> [(Bytes, (Hash, Word64))] -> (Integer, [Bytes], Hash, Word64) -> Maybe Proof - go 0 ((s_i, (h_si, _)) : rest) (n, acc, h_j, n_pj) = + go :: Int -> [(Bytes, (Hash, Word64))] -> ProofStep -> Maybe Proof + go 0 ((s_i, (h_si, _)) : rest) step@(ProofStep n acc h_j n_pj) = let h_i = h_j <> h_si n_pj' = h_i `oracle` prob_q in if n_pj' == 0 then Just $ Proof n 0 (s_i : acc) - else go 0 rest (n, acc, h_j, n_pj) + else go 0 rest step go _ [] _ = Nothing - go k ((s_i, (h_si, n_pi)) : rest) (n, acc, h_j, n_pj) = + go k ((s_i, (h_si, n_pi)) : rest) step@(ProofStep n acc h_j n_pj) = let h_i = h_j <> h_si in if n_pi == n_pj - then case go (k - 1) preHash (n, s_i : acc, h_i, h_i `oracle` n_p) of - Nothing -> go k rest (n, acc, h_j, n_pj) + then case go (k - 1) preHash (ProofStep n (s_i : acc) h_i (h_i `oracle` n_p)) of + Nothing -> go k rest step prf -> prf - else go k rest (n, acc, h_j, n_pj) + else go k rest step -- | Compute ALBA parameters: Length of proof, seed number, and probability of selecting last tuple. -- @@ -215,14 +256,6 @@ computeParams Params{λ_rel, λ_sec, n_p, n_f} = q :: Double q = 2 * (fromIntegral λ_rel + log3) / (fromIntegral d * loge) -modBS :: ByteString -> Integer -> Integer -modBS bs q = - let n = fromBytes bs q - in n `mod` q - -fromBytes :: ByteString -> Integer -> Integer -fromBytes bs q = BS.foldl' (\acc b -> (acc * 256 + fromIntegral b) `mod` q) 0 bs - fromBytesLE :: ByteString -> Word64 fromBytesLE = either error id . runGet getWord64le . BS.take 8 @@ -286,9 +319,9 @@ isPowerOf2 n = countLeadingZeros n + countTrailingZeros n == 63 data Verification - = Verified {proof :: Proof, params :: Params} - | InvalidItem {proof :: Proof, item :: Bytes, level :: Int} - | InvalidLength {proof :: Proof, expected :: Int} + = Verified {proof :: !Proof, params :: !Params} + | InvalidItem {proof :: !Proof, item :: !Bytes, level :: !Int} + | InvalidLength {proof :: !Proof, expected :: !Int} deriving (Show, Eq) -- | Verify `Proof` that the set of elements known to the prover `s_p` has size greater than $n_f$. diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index 16ddbd0..0e71040 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -7,7 +7,24 @@ module ALBASpec where -import ALBA (Bytes (..), Hashable (..), NoProof (..), Params (..), Proof (..), Retries (..), Verification (..), computeParams, fromBytes, fromBytesLE, genItems, isPowerOf2, modBS, modPowerOf2, oracle, prove, toBytesLE, verify) +import ALBA ( + Bytes (..), + Hashable (..), + NoProof (..), + Params (..), + Proof (..), + Retries (..), + Verification (..), + computeParams, + fromBytesLE, + genItems, + isPowerOf2, + modPowerOf2, + oracle, + prove, + toBytesLE, + verify, + ) import Data.Bits (Bits (..), countTrailingZeros) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -82,6 +99,23 @@ spec = do modifyMaxSuccess (const 30) $ do prop "needs to retry proving given number of elements is too small" prop_retryProofOnSmallSet prop "stops retrying proof after λ attempts" prop_stopRetryingProof + prop "retries proof after number of hashes is above λ² given number of items lower than λ²" prop_retryProofOnHashBounds + +prop_retryProofOnHashBounds :: Property +prop_retryProofOnHashBounds = + forAll (choose (10, 20)) $ \λ -> + forAll (resize (fromIntegral $ λ * λ `div` 2) (genItems 10)) $ \items -> + let numItems = fromIntegral $ length items + params = Params λ λ (numItems * 80 `div` 100) (numItems * 20 `div` 100) + in case prove params items of + Right Proof{retryCount} -> + retryCount >= 0 && retryCount <= λ + & counterexample ("retryCount = " <> show retryCount) + & counterexample ("numItems = " <> show numItems) + & label ("retryCount <= " <> show ((retryCount `div` 10 + 1) * 10)) + & cover 60 (retryCount > 0) "retried proof" + & checkCoverage + Left (NoProof _) -> property True & label "no proof" prop_stopRetryingProof :: Property prop_stopRetryingProof = From 12590e781a88baae25ad2b5af0a189fb46c2763c Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sat, 15 Jun 2024 08:43:11 +0200 Subject: [PATCH 06/17] Replace State monad with ST computation Even without benchmark, it's obvious from running tests State monad will be unbearably slow --- src/ALBA.hs | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/src/ALBA.hs b/src/ALBA.hs index d52c0f5..8138379 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -43,12 +43,15 @@ where import Control.DeepSeq (NFData) import Control.Monad (unless) +import Control.Monad.ST.Strict (ST, runST) import Control.Monad.State.Strict (State, evalState) import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize, (.&.), (.<<.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Hex import Data.ByteString.Internal (unsafeCreate) +import Data.STRef (newSTRef) +import Data.STRef.Strict (STRef) import Data.Serialize (Serialize (..), decode, encode, getWord64le, putWord64le, runGet, runPut) import Data.String (IsString (..)) import Data.Word (Word64) @@ -174,7 +177,7 @@ data ProofStep = ProofStep -- required length. prove :: Params -> [Bytes] -> Either NoProof Proof prove params@Params{λ_sec, n_p} s_p = - evalState (proveWithRetry 0) 0 + runST $ newSTRef 0 >>= proveWithRetry 0 where hashBounds = λ_sec * λ_sec @@ -182,20 +185,20 @@ prove params@Params{λ_sec, n_p} s_p = prob_q = ceiling $ 1 / q - proveWithRetry :: Integer -> State Int (Either NoProof Proof) - proveWithRetry retryCount + proveWithRetry :: Integer -> STRef s Int -> ST s (Either NoProof Proof) + proveWithRetry retryCount hashCount | retryCount >= λ_sec = pure $ Left $ NoProof $ Retries retryCount | otherwise = do - step0 <- round0 preHash - stepn <- start preHash step0 + step0 <- round0 preHash hashCount + stepn <- start hashCount preHash step0 case stepn of - Nothing -> proveWithRetry (retryCount + 1) + Nothing -> proveWithRetry (retryCount + 1) hashCount Just prf -> pure $ Right prf{retryCount} where preHash = zip s_p $ map (\bs -> let h = hash retryCount <> hash bs in (h, h `oracle` n_p)) s_p - round0 :: [(Bytes, (Hash, Word64))] -> State Int [ProofStep] - round0 preHash = + round0 :: [(Bytes, (Hash, Word64))] -> STRef s Int -> ST s [ProofStep] + round0 preHash hashCount = pure [ ProofStep t [s_i] h_0 n_p0 | (s_i, (h, l)) <- preHash @@ -205,12 +208,13 @@ prove params@Params{λ_sec, n_p} s_p = , l == n_p0 ] - start :: [(Bytes, (Hash, Word64))] -> [ProofStep] -> State Int (Maybe Proof) - start _ [] = pure Nothing - start preHash (element : elements) = - case go (fromInteger $ u - 2) preHash element of - Nothing -> start preHash elements - prf -> pure prf + start :: STRef s Int -> [(Bytes, (Hash, Word64))] -> [ProofStep] -> ST s (Maybe Proof) + start hashCount preHash = \case + [] -> pure Nothing + (element : elements) -> + case go (fromInteger $ u - 2) preHash element of + Nothing -> start hashCount preHash elements + prf -> pure prf where go :: Int -> [(Bytes, (Hash, Word64))] -> ProofStep -> Maybe Proof go 0 ((s_i, (h_si, _)) : rest) step@(ProofStep n acc h_j n_pj) = From e48655992e7f59c7422cdabe9b0da2212a8ecec3 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sat, 15 Jun 2024 18:52:58 +0200 Subject: [PATCH 07/17] Bound DFS with number of hashes in the "small" set case This completely ditch ST or State monad based computation which are way too expensive. --- src/ALBA.hs | 59 ++++++++++++++++++++++++------------------------ test/ALBASpec.hs | 8 +++++-- 2 files changed, 36 insertions(+), 31 deletions(-) diff --git a/src/ALBA.hs b/src/ALBA.hs index 8138379..6543721 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -177,29 +177,28 @@ data ProofStep = ProofStep -- required length. prove :: Params -> [Bytes] -> Either NoProof Proof prove params@Params{λ_sec, n_p} s_p = - runST $ newSTRef 0 >>= proveWithRetry 0 + proveWithRetry 0 where - hashBounds = λ_sec * λ_sec + hashBounds = fromInteger $ λ_sec * λ_sec (u, d, q) = computeParams params prob_q = ceiling $ 1 / q - proveWithRetry :: Integer -> STRef s Int -> ST s (Either NoProof Proof) - proveWithRetry retryCount hashCount - | retryCount >= λ_sec = pure $ Left $ NoProof $ Retries retryCount - | otherwise = do - step0 <- round0 preHash hashCount - stepn <- start hashCount preHash step0 - case stepn of - Nothing -> proveWithRetry (retryCount + 1) hashCount - Just prf -> pure $ Right prf{retryCount} + proveWithRetry :: Integer -> Either NoProof Proof + proveWithRetry retryCount + | retryCount >= λ_sec = Left $ NoProof $ Retries retryCount + | otherwise = + case round0 preHash $ start preHash of + Nothing -> proveWithRetry (retryCount + 1) + Just prf -> Right prf{retryCount} where preHash = zip s_p $ map (\bs -> let h = hash retryCount <> hash bs in (h, h `oracle` n_p)) s_p - round0 :: [(Bytes, (Hash, Word64))] -> STRef s Int -> ST s [ProofStep] - round0 preHash hashCount = - pure + round0 :: [(Bytes, (Hash, Word64))] -> (Int -> [ProofStep] -> Maybe Proof) -> Maybe Proof + round0 preHash k = + k + (length preHash * fromInteger d) [ ProofStep t [s_i] h_0 n_p0 | (s_i, (h, l)) <- preHash , t <- [1 .. d] @@ -208,29 +207,31 @@ prove params@Params{λ_sec, n_p} s_p = , l == n_p0 ] - start :: STRef s Int -> [(Bytes, (Hash, Word64))] -> [ProofStep] -> ST s (Maybe Proof) - start hashCount preHash = \case - [] -> pure Nothing + start :: [(Bytes, (Hash, Word64))] -> Int -> [ProofStep] -> Maybe Proof + start preHash hashCount = \case + [] -> Nothing (element : elements) -> - case go (fromInteger $ u - 2) preHash element of - Nothing -> start hashCount preHash elements - prf -> pure prf + case go (fromInteger $ u - 2) hashCount preHash element of + (hashCount', Nothing) + | hashCount' < hashBounds -> start preHash hashCount' elements + | otherwise -> Nothing + (_, prf) -> prf where - go :: Int -> [(Bytes, (Hash, Word64))] -> ProofStep -> Maybe Proof - go 0 ((s_i, (h_si, _)) : rest) step@(ProofStep n acc h_j n_pj) = + go :: Int -> Int -> [(Bytes, (Hash, Word64))] -> ProofStep -> (Int, Maybe Proof) + go 0 hCount ((s_i, (h_si, _)) : rest) step@(ProofStep n acc h_j _) = let h_i = h_j <> h_si n_pj' = h_i `oracle` prob_q in if n_pj' == 0 - then Just $ Proof n 0 (s_i : acc) - else go 0 rest step - go _ [] _ = Nothing - go k ((s_i, (h_si, n_pi)) : rest) step@(ProofStep n acc h_j n_pj) = + then (succ hCount, Just $ Proof n 0 (s_i : acc)) + else go 0 (succ hCount) rest step + go k hCount ((s_i, (h_si, n_pi)) : rest) step@(ProofStep n acc h_j n_pj) = let h_i = h_j <> h_si in if n_pi == n_pj - then case go (k - 1) preHash (ProofStep n (s_i : acc) h_i (h_i `oracle` n_p)) of - Nothing -> go k rest step + then case go (k - 1) (succ hCount) preHash (ProofStep n (s_i : acc) h_i (h_i `oracle` n_p)) of + (hCount', Nothing) -> go k hCount' rest step prf -> prf - else go k rest step + else go k (succ hCount) rest step + go _ hCount [] _ = (hCount, Nothing) -- | Compute ALBA parameters: Length of proof, seed number, and probability of selecting last tuple. -- diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index 0e71040..0d01d21 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -112,8 +112,12 @@ prop_retryProofOnHashBounds = retryCount >= 0 && retryCount <= λ & counterexample ("retryCount = " <> show retryCount) & counterexample ("numItems = " <> show numItems) - & label ("retryCount <= " <> show ((retryCount `div` 10 + 1) * 10)) - & cover 60 (retryCount > 0) "retried proof" + & label ("# prove run = " <> show (succ retryCount)) + -- 35% is completely empirical, the real target is for + -- the average number of proof run to be around 2 but + -- QuickCheck does not provide an easy way to target + -- an average value + & cover 35 (retryCount > 0) "retried proof" & checkCoverage Left (NoProof _) -> property True & label "no proof" From ea49f2625f3d70b1c5c2f351d21e3eae8b6e114d Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sat, 15 Jun 2024 19:25:48 +0200 Subject: [PATCH 08/17] Use different bounds for nr. of hash depending on honest set size MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Note the test case does not actually matches the expected theoretical values. The average and max number of proof run should be 1 when n_p is greater than λ³ but it's not the case. --- alba.cabal | 2 +- src/ALBA.hs | 40 +++++++++++++++++++++------------------- test/ALBASpec.hs | 24 ++++++++++++++++++++++-- 3 files changed, 44 insertions(+), 22 deletions(-) diff --git a/alba.cabal b/alba.cabal index 5ef0a86..cae5b07 100644 --- a/alba.cabal +++ b/alba.cabal @@ -25,7 +25,7 @@ library , bytestring , cereal , deepseq - , mtl + default-extensions: StrictData default-language: Haskell2010 ghc-options: -Wall -Wunused-packages diff --git a/src/ALBA.hs b/src/ALBA.hs index 6543721..1187fcc 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -43,15 +43,11 @@ where import Control.DeepSeq (NFData) import Control.Monad (unless) -import Control.Monad.ST.Strict (ST, runST) -import Control.Monad.State.Strict (State, evalState) import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize, (.&.), (.<<.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Hex import Data.ByteString.Internal (unsafeCreate) -import Data.STRef (newSTRef) -import Data.STRef.Strict (STRef) import Data.Serialize (Serialize (..), decode, encode, getWord64le, putWord64le, runGet, runPut) import Data.String (IsString (..)) import Data.Word (Word64) @@ -179,7 +175,14 @@ prove :: Params -> [Bytes] -> Either NoProof Proof prove params@Params{λ_sec, n_p} s_p = proveWithRetry 0 where - hashBounds = fromInteger $ λ_sec * λ_sec + λ_squared = λ_sec * λ_sec + λ_cubed = λ_sec * λ_squared + + hashBounds = + fromIntegral $ + if fromIntegral n_p <= λ_squared + then λ_squared + else λ_cubed (u, d, q) = computeParams params @@ -189,23 +192,22 @@ prove params@Params{λ_sec, n_p} s_p = proveWithRetry retryCount | retryCount >= λ_sec = Left $ NoProof $ Retries retryCount | otherwise = - case round0 preHash $ start preHash of - Nothing -> proveWithRetry (retryCount + 1) - Just prf -> Right prf{retryCount} + let hashCount = length preHash * fromInteger d + in case start preHash hashCount (round0 preHash) of + Nothing -> proveWithRetry (retryCount + 1) + Just prf -> Right prf{retryCount} where preHash = zip s_p $ map (\bs -> let h = hash retryCount <> hash bs in (h, h `oracle` n_p)) s_p - round0 :: [(Bytes, (Hash, Word64))] -> (Int -> [ProofStep] -> Maybe Proof) -> Maybe Proof - round0 preHash k = - k - (length preHash * fromInteger d) - [ ProofStep t [s_i] h_0 n_p0 - | (s_i, (h, l)) <- preHash - , t <- [1 .. d] - , let !h_0 = hash t <> h - , let n_p0 = h_0 `oracle` n_p - , l == n_p0 - ] + round0 :: [(Bytes, (Hash, Word64))] -> [ProofStep] + round0 preHash = + [ ProofStep t [s_i] h_0 n_p0 + | (s_i, (h, l)) <- preHash + , t <- [1 .. d] + , let !h_0 = hash t <> h + , let n_p0 = h_0 `oracle` n_p + , l == n_p0 + ] start :: [(Bytes, (Hash, Word64))] -> Int -> [ProofStep] -> Maybe Proof start preHash hashCount = \case diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index 0d01d21..b946c87 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -50,6 +50,7 @@ import Test.QuickCheck ( cover, coverTable, forAll, + forAllBlind, forAllShrink, frequency, generate, @@ -99,12 +100,14 @@ spec = do modifyMaxSuccess (const 30) $ do prop "needs to retry proving given number of elements is too small" prop_retryProofOnSmallSet prop "stops retrying proof after λ attempts" prop_stopRetryingProof - prop "retries proof after number of hashes is above λ² given number of items lower than λ²" prop_retryProofOnHashBounds + prop "retries proof after number of hashes is above λ² given n_p is lower than λ²" prop_retryProofOnHashBounds + prop "does not retry proof given n_p is greater than λ³" prop_doesNoRetryProofOnHashBounds prop_retryProofOnHashBounds :: Property prop_retryProofOnHashBounds = forAll (choose (10, 20)) $ \λ -> - forAll (resize (fromIntegral $ λ * λ `div` 2) (genItems 10)) $ \items -> + -- we want n_p to be lower than λ² so we generate exactly λ² items + forAll (resize (fromIntegral $ λ * λ) (genItems 10)) $ \items -> let numItems = fromIntegral $ length items params = Params λ λ (numItems * 80 `div` 100) (numItems * 20 `div` 100) in case prove params items of @@ -121,6 +124,23 @@ prop_retryProofOnHashBounds = & checkCoverage Left (NoProof _) -> property True & label "no proof" +prop_doesNoRetryProofOnHashBounds :: Property +prop_doesNoRetryProofOnHashBounds = + forAll (choose (10, 20)) $ \λ -> + -- we want n_p to be greater than λ³ so we need to generate more items + forAllBlind (resize (fromIntegral $ λ * λ * λ * 6 `div` 5) (genItems 10)) $ \items -> + let numItems = fromIntegral $ length items + params = Params λ λ (numItems * 80 `div` 100) (numItems * 20 `div` 100) + in case prove params items of + Right Proof{retryCount} -> + property True + & label ("# prove run = " <> show (succ retryCount)) + -- This bound is also empirical, the real target is for the average and max number of proof run to be 1. + -- It's not clear why the distribution is actually quite similar to the other retry-related test + & cover 65 (retryCount < 1) "no retry" + & checkCoverage + Left (NoProof _) -> property False + prop_stopRetryingProof :: Property prop_stopRetryingProof = forAll (resize 100 (genItems 10)) $ \items -> From 35716c746c79978da8a96e07664d577f6d49f9bf Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sat, 15 Jun 2024 23:30:53 +0200 Subject: [PATCH 09/17] Update some benchmarks --- docs/src/bench-size-bound.html | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/src/bench-size-bound.html b/docs/src/bench-size-bound.html index f25ed1b..6a14813 100644 --- a/docs/src/bench-size-bound.html +++ b/docs/src/bench-size-bound.html @@ -1031,7 +1031,7 @@ From 0db1d97270ac6d4a17082d1372ff93dec34d23bf Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sun, 16 Jun 2024 08:54:55 +0200 Subject: [PATCH 10/17] Update test application --- app/Main.hs | 9 +++++---- src/ALBA.hs | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 18a785e..1c6c61b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -import ALBA (NoProof (..), Params (..), Verification (Verified), genItems, prove, readProof, verify, writeProof) +import ALBA (NoProof (..), Params (..), Proof (..), Verification (Verified), genItems, prove, readProof, verify, writeProof) import Data.Word (Word64) import System.Environment (getArgs) import System.Exit (ExitCode (..), exitSuccess, exitWith) @@ -39,10 +39,11 @@ main = do let opts'@Options{params} = adjustForSize opts putStrLn $ "Generating proof " <> show opts' case prove params bs of - Left NoProof -> putStrLn "No proof could be generated" >> exitWith (ExitFailure 1) - Right prf -> + Left (NoProof retries) -> + putStrLn ("No proof could be generated after " <> show retries <> " retries") >> exitWith (ExitFailure 1) + Right prf@Proof{retryCount} -> writeProof output prf >>= \n -> - putStrLn ("Written proof to '" <> output <> "' (" <> show n <> " bytes)") + putStrLn ("Written proof to '" <> output <> "' (" <> show n <> " bytes, " <> show retryCount <> " retries)") Verify opts@Options{size, len, params = pars@Params{n_p, n_f}, output} -> do let opts'@Options{params} = adjustForSize opts putStrLn $ "Verifying proof with " <> show opts' diff --git a/src/ALBA.hs b/src/ALBA.hs index 1187fcc..d898453 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -105,7 +105,7 @@ newtype NoProof = NoProof Retries deriving stock (Show, Eq) newtype Retries = Retries Integer - deriving stock (Show, Eq) + deriving newtype (Show, Eq) newtype Hash where Hash :: ByteString -> Hash From 2fa11056a433ae8197b650e993faa00056bbe3dd Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Wed, 19 Jun 2024 23:14:19 +0200 Subject: [PATCH 11/17] Use refined parameters computations for small and large n_p --- src/ALBA.hs | 19 +++++++++++++++---- test/ALBASpec.hs | 37 +++++++++++++++++++++++++++---------- 2 files changed, 42 insertions(+), 14 deletions(-) diff --git a/src/ALBA.hs b/src/ALBA.hs index d898453..480c6b1 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -242,6 +242,8 @@ computeParams :: Params -> (Integer, Integer, Double) computeParams Params{λ_rel, λ_sec, n_p, n_f} = (u, d, q) where + λ_squared = λ_sec * λ_sec + e = exp 1 log_2 = logBase 2 @@ -252,16 +254,25 @@ computeParams Params{λ_rel, λ_sec, n_p, n_f} = log3 :: Double log3 = log_2 3 + log12 :: Double + log12 = log_2 12 + u' = - (fromIntegral λ_sec + log_2 (fromIntegral λ_rel + log3) + 1 - log_2 loge) + (fromIntegral λ_sec + log_2 (fromIntegral λ_rel) + 5 - log_2 loge) / logBase 2 (fromIntegral n_p / fromIntegral n_f) u = ceiling u' - d = ceiling $ 16 * u' * (fromIntegral λ_rel + log3) / loge + (d, q) = + if fromIntegral n_p <= λ_squared + then (d_small, q_small) + else (d_large, q_large) + + d_large = ceiling $ 16 * u' * (fromIntegral λ_rel + log3) / loge + q_large = 2 * (fromIntegral λ_rel + log3) / (fromIntegral d_large * loge) - q :: Double - q = 2 * (fromIntegral λ_rel + log3) / (fromIntegral d * loge) + d_small = ceiling $ 32 * u' * log12 + q_small = 2 * (fromIntegral λ_rel + log12) / fromIntegral d_small fromBytesLE :: ByteString -> Word64 fromBytesLE = either error id . runGet getWord64le . BS.take 8 diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index b946c87..f053407 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -86,22 +86,38 @@ spec = do describe "parameters" $ do mapM_ - checkParameters - [ (Params 128 128 600 400, 232) - , (Params 128 128 660 330, 136) + checkParameterU + [ (Params 128 128 24000 16000, 239) + , (Params 128 128 600 400, 239) + , (Params 128 128 660 330, 140) , (Params 128 128 800 200, 68) ] + it "has significantly smaller d and larger q if n_p is smaller than λ²" $ + let small_n_p = Params 128 128 16000 10666 + large_n_p = Params 128 128 17000 11333 + (u_small, d_small, q_small) = computeParams small_n_p + (u_large, d_large, q_large) = computeParams large_n_p + in conjoin + [ u_small === u_large + , d_small < d_large + & counterexample ("d (small) = " <> show d_small <> ", d (large) = " <> show d_large) + , q_small > q_large + & counterexample ("q (small) = " <> show q_small <> ", q (large) = " <> show q_large) + ] + prop "can verify small proof is valid" $ prop_verifyValidProof 8 100 prop "can verify large proof is valid" $ prop_verifyValidProof 400 1000 prop "can reject proof if items are tampered with" prop_rejectTamperedProof prop "can roundtrip serialisation of proof" prop_roundtripProof - modifyMaxSuccess (const 30) $ do - prop "needs to retry proving given number of elements is too small" prop_retryProofOnSmallSet - prop "stops retrying proof after λ attempts" prop_stopRetryingProof - prop "retries proof after number of hashes is above λ² given n_p is lower than λ²" prop_retryProofOnHashBounds - prop "does not retry proof given n_p is greater than λ³" prop_doesNoRetryProofOnHashBounds + + modifyMaxSuccess (const 30) $ + describe "Retry logic" $ do + prop "needs to retry proving given number of elements is too small" prop_retryProofOnSmallSet + prop "stops retrying proof after λ attempts" prop_stopRetryingProof + prop "retries proof after number of hashes is above λ² given n_p is lower than λ²" prop_retryProofOnHashBounds + prop "does not retry proof given n_p is greater than λ³" prop_doesNoRetryProofOnHashBounds prop_retryProofOnHashBounds :: Property prop_retryProofOnHashBounds = @@ -263,11 +279,12 @@ shrinkPowerOf2 n | n > 2 = [n `div` 2] | otherwise = [] -checkParameters :: (Params, Integer) -> SpecWith () -checkParameters (params, expected) = +checkParameterU :: (Params, Integer) -> SpecWith () +checkParameterU (params, expected) = it ("check u = " <> show expected <> " for " <> show params) $ let (u, _, _) = computeParams params in abs (u - expected) <= 3 + & counterexample ("u = " <> show u) prop_hashBytestring :: ByteString -> ByteString -> Property prop_hashBytestring bytes1 bytes2 = From 7e218838bfd6a574b51f59b36fddc593ad70562a Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 25 Jun 2024 09:20:32 +0200 Subject: [PATCH 12/17] Benchmark verification time Also improve readability of benchmarks' label --- alba.cabal | 78 ++- bench-proof.html | 1159 +++++++++++++++++++++++++++++++++++++++ bench-verification.html | 1159 +++++++++++++++++++++++++++++++++++++++ bench/ALBABench.hs | 316 ++--------- src/ALBA.hs | 17 +- 5 files changed, 2403 insertions(+), 326 deletions(-) create mode 100644 bench-proof.html create mode 100644 bench-verification.html diff --git a/alba.cabal b/alba.cabal index cae5b07..240eacc 100644 --- a/alba.cabal +++ b/alba.cabal @@ -11,28 +11,27 @@ build-type: Simple extra-source-files: README.md flag dump - manual: True + manual: True default: True library - exposed-modules: - ALBA - hs-source-dirs: src + exposed-modules: ALBA + hs-source-dirs: src build-depends: - base >=4.9 && <5 - , QuickCheck - , base16-bytestring - , bytestring - , cereal - , deepseq + , base >=4.9 && <5 + , base16-bytestring + , bytestring + , cereal + , deepseq + , QuickCheck - default-extensions: StrictData - default-language: Haskell2010 - ghc-options: -Wall -Wunused-packages - extra-libraries: sodium - include-dirs: cbits - includes: cbits/blake2b.h - c-sources: cbits/blake2b.c + default-extensions: StrictData + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages + extra-libraries: sodium + include-dirs: cbits + includes: cbits/blake2b.h + c-sources: cbits/blake2b.c if flag(dump) ghc-options: -ddump-simpl -ddump-stg-final -ddump-to-file @@ -41,33 +40,31 @@ executable alba hs-source-dirs: app main-is: Main.hs build-depends: - alba - , QuickCheck - , base + , alba + , base + , QuickCheck ghc-options: -threaded -rtsopts test-suite test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - other-modules: ALBASpec - build-depends: - base >= 4.9 && <5 - , QuickCheck - , base16-bytestring - , bytestring - , cereal - , hspec - , alba - , quickcheck-classes - , quickcheck-instances - - build-tool-depends: - hspec-discover:hspec-discover + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: ALBASpec + build-depends: + , alba + , base >=4.9 && <5 + , base16-bytestring + , bytestring + , cereal + , hspec + , QuickCheck + , quickcheck-classes + , quickcheck-instances - ghc-options: -rtsopts -threaded + build-tool-depends: hspec-discover:hspec-discover + ghc-options: -rtsopts -threaded benchmark bench hs-source-dirs: bench/ @@ -75,10 +72,11 @@ benchmark bench type: exitcode-stdio-1.0 build-depends: , aeson + , alba , base , bytestring , criterion - , alba + , deepseq , QuickCheck ghc-options: -threaded -rtsopts diff --git a/bench-proof.html b/bench-proof.html new file mode 100644 index 0000000..74aa85a --- /dev/null +++ b/bench-proof.html @@ -0,0 +1,1159 @@ + + + + + criterion report + + + + + + +
+

criterion performance measurements

+

want to understand this report?

+

overview

+
+ + + ⓘ + + +
+ +
+
+ + + + + +
+
+

colophon

+

+ This report was created using the criterion + benchmark execution and performance analysis tool. +

+

+ Criterion is developed and maintained + by Bryan O'Sullivan. +

+
+
+ + diff --git a/bench-verification.html b/bench-verification.html new file mode 100644 index 0000000..470629e --- /dev/null +++ b/bench-verification.html @@ -0,0 +1,1159 @@ + + + + + criterion report + + + + + + +
+

criterion performance measurements

+

want to understand this report?

+

overview

+
+ + + ⓘ + + +
+ +
+
+ + + + + +
+
+

colophon

+

+ This report was created using the criterion + benchmark execution and performance analysis tool. +

+

+ Criterion is developed and maintained + by Bryan O'Sullivan. +

+
+
+ + diff --git a/bench/ALBABench.hs b/bench/ALBABench.hs index e21a884..e8a6aaf 100644 --- a/bench/ALBABench.hs +++ b/bench/ALBABench.hs @@ -1,7 +1,10 @@ -import ALBA (Bytes (..), Params (..), Proof, hash, prove) +import ALBA (Bytes (..), Params (..), Proof, hash, prove, verify) +import Control.DeepSeq (rnf) +import Control.Exception (evaluate) import Control.Monad (forM) -import Criterion (Benchmark) +import Criterion (Benchmark, env, perRunEnv) import Criterion.Main (bench, bgroup, defaultMain, nf, whnf) +import Criterion.Types (Benchmarkable (perRun)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Word (Word8) @@ -9,302 +12,53 @@ import Test.QuickCheck (Gen, arbitrary, generate, vectorOf) main :: IO () main = do - benches <- - forM - [(s_p, 256) | s_p <- [1000, 5000, 10000, 50000, 100000]] - genItems + let benchSizes = [1000, 5000, 10000] defaultMain - [ bgroup "Hashing" [benchHash testBytes] - , bgroup - "Proof Generation" + [ bgroup + "Proving" $ [ benchProof (b, s_p, n_p) - | b <- benches + | b <- benchSizes , n_p <- [60, 66, 80] - , let high = fromIntegral (length b) + , let high = fromIntegral b , let low = high * n_p `div` 100 , let mid = (high + low) `div` 2 , s_p <- [low, mid, high] ] + , bgroup + "Verifying" + [ benchVerification (b, n_p) + | b <- benchSizes + , n_p <- [60, 66, 80] + ] ] +benchVerification :: (Int, Int) -> Benchmark +benchVerification (total, n_p) = + let params = Params 128 128 (fromIntegral $ total * n_p `div` 100) (fromIntegral $ (total * (100 - n_p)) `div` 100) + label = "s_p = " <> show total <> "/n_p = " <> show n_p <> "%" + mkProof bytes = either (error . show) id $ prove params (Bytes <$> bytes) + in -- NOTE: no need to generate different proofs per run as the verification time is + -- tied to the proof size, not the proof content + env (mkProof <$> genItems (total, 710)) $ \proof -> + bench label $ + nf (verify params) proof + benchHash :: ByteString -> Benchmark benchHash bytes = bench label $ nf hash bytes where label = "hashing len=" <> show (BS.length bytes) -benchProof :: ([ByteString], Int, Int) -> Benchmark -benchProof (bytes, s_p, n_p) = - let coeff = fromIntegral $ length bytes - params = Params 128 128 (coeff * fromIntegral n_p `div` 100) (coeff * (100 - fromIntegral n_p) `div` 100) - label = show s_p <> "/" <> show coeff <> "/" <> show n_p <> "%" +benchProof :: (Int, Int, Int) -> Benchmark +benchProof (total, s_p, n_p) = + let params = Params 128 128 (fromIntegral $ total * n_p `div` 100) (fromIntegral $ (total * (100 - n_p)) `div` 100) + label = "total = " <> show total <> "/s_p = " <> show s_p <> "/n_p = " <> show n_p <> "%" in bench label $ - whnf - (uncurry prove) - (params, Bytes <$> take s_p bytes) + -- NOTE: we generate a new proof per run to highlight the potential high variance in proving time + -- depending on the bytes generated + perRunEnv (genItems (s_p, 710)) $ \bytes -> + evaluate $ rnf $ prove params (Bytes <$> bytes) genItems :: (Int, Int) -> IO [ByteString] genItems (numItems, itemSize) = generate $ vectorOf numItems (BS.pack <$> vectorOf itemSize (arbitrary :: Gen Word8)) - -testBytes :: ByteString -testBytes = - BS.pack - -- Totally random, determined by fair dice rolls - [ 0xa8 - , 0x53 - , 0x16 - , 0x1f - , 0xef - , 0x50 - , 0xc0 - , 0x6d - , 0x7a - , 0x21 - , 0xc1 - , 0xfa - , 0x78 - , 0x33 - , 0x96 - , 0xf1 - , 0x7b - , 0x2d - , 0xa8 - , 0x4b - , 0x5a - , 0x7f - , 0xe4 - , 0x49 - , 0x94 - , 0x5f - , 0xe8 - , 0x9d - , 0xd1 - , 0x41 - , 0xc6 - , 0x05 - , 0x03 - , 0xd9 - , 0x70 - , 0x9b - , 0xa6 - , 0xe6 - , 0x5a - , 0xce - , 0xde - , 0xe5 - , 0x78 - , 0x12 - , 0x87 - , 0x0f - , 0x1d - , 0x0d - , 0x8c - , 0x64 - , 0xbb - , 0x82 - , 0xdc - , 0xee - , 0x31 - , 0x6c - , 0xf0 - , 0xba - , 0xc1 - , 0xfe - , 0x44 - , 0xb7 - , 0x5e - , 0x36 - , 0x86 - , 0x05 - , 0x4f - , 0xad - , 0x13 - , 0xc4 - , 0x03 - , 0x22 - , 0xd7 - , 0x07 - , 0x54 - , 0xf5 - , 0x0d - , 0xdd - , 0x73 - , 0x2a - , 0x78 - , 0x75 - , 0x95 - , 0xb1 - , 0x3c - , 0xa9 - , 0x7e - , 0x75 - , 0xc5 - , 0x3f - , 0x45 - , 0x35 - , 0x1a - , 0xa0 - , 0x79 - , 0x44 - , 0xf3 - , 0xc4 - , 0x4c - , 0x58 - , 0x2f - , 0xfc - , 0x5f - , 0x8b - , 0xad - , 0x05 - , 0x2b - , 0xbd - , 0xcb - , 0xfe - , 0x2c - , 0x83 - , 0x90 - , 0x7a - , 0x8f - , 0xbb - , 0xd4 - , 0xde - , 0xa6 - , 0x89 - , 0xc9 - , 0xb1 - , 0x70 - , 0xbe - , 0xbc - , 0x71 - , 0x6f - , 0x63 - , 0xe5 - , 0xce - , 0x21 - , 0xa6 - , 0xfd - , 0xbf - , 0xd6 - , 0x95 - , 0x76 - , 0xf9 - , 0x4c - , 0x48 - , 0xa2 - , 0x15 - , 0xca - , 0x2a - , 0x2f - , 0x82 - , 0xb4 - , 0xcb - , 0x12 - , 0x24 - , 0x9a - , 0x80 - , 0x66 - , 0xfc - , 0x4e - , 0xee - , 0xc0 - , 0x87 - , 0x84 - , 0x0e - , 0x37 - , 0xf2 - , 0x44 - , 0x56 - , 0x2c - , 0xec - , 0x16 - , 0xe6 - , 0x45 - , 0x3a - , 0x2f - , 0x5c - , 0xa7 - , 0x71 - , 0xfb - , 0xfc - , 0x68 - , 0x5b - , 0x30 - , 0x10 - , 0xac - , 0x5f - , 0x31 - , 0x06 - , 0xa9 - , 0xc4 - , 0x5a - , 0x6e - , 0xf2 - , 0x86 - , 0x68 - , 0xfb - , 0x89 - , 0xf7 - , 0x32 - , 0x37 - , 0xe1 - , 0x71 - , 0xcd - , 0x0c - , 0xba - , 0xfc - , 0x03 - , 0xb9 - , 0x79 - , 0x25 - , 0x35 - , 0xcb - , 0x3d - , 0x77 - , 0x0a - , 0x74 - , 0x02 - , 0x49 - , 0x5f - , 0xdf - , 0xfa - , 0xac - , 0xb9 - , 0x8c - , 0xe0 - , 0xcb - , 0x76 - , 0xfe - , 0xc2 - , 0x7a - , 0x6a - , 0xc8 - , 0xa9 - , 0xd6 - , 0x1a - , 0xe7 - , 0x5d - , 0xba - , 0xc6 - , 0xee - , 0x93 - , 0x52 - , 0x60 - , 0xf2 - , 0xd7 - , 0x51 - , 0x22 - , 0xa8 - , 0x84 - , 0x29 - , 0x23 - , 0x5e - , 0x1a - , 0x55 - , 0xb0 - , 0xe8 - , 0xf9 - , 0x82 - , 0xb8 - , 0xf4 - ] diff --git a/src/ALBA.hs b/src/ALBA.hs index 480c6b1..a722207 100644 --- a/src/ALBA.hs +++ b/src/ALBA.hs @@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GADTs #-} @@ -53,6 +55,7 @@ import Data.String (IsString (..)) import Data.Word (Word64) import Foreign (Ptr, Word8, castPtr, countTrailingZeros) import Foreign.C (errnoToIOError, getErrno) +import GHC.Generics (Generic) import GHC.IO.Exception (ioException) import Test.QuickCheck (Gen, arbitrary, sized, vectorOf) @@ -77,7 +80,8 @@ data Params = Params , n_f :: !Word64 -- ^ Estimated size of "adversarial" parties set. } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) data Proof = Proof { index :: !Integer @@ -87,7 +91,8 @@ data Proof = Proof , elements :: ![Bytes] -- ^ The set of elements witnessing knowledge of a set of size greater than $n_f$. } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) instance Serialize Proof where put Proof{index, retryCount, elements} = do @@ -103,9 +108,10 @@ instance Serialize Proof where newtype NoProof = NoProof Retries deriving stock (Show, Eq) + deriving newtype (NFData) newtype Retries = Retries Integer - deriving newtype (Show, Eq) + deriving newtype (Show, Eq, NFData) newtype Hash where Hash :: ByteString -> Hash @@ -147,7 +153,7 @@ instance (Hashable a, Hashable b) => Hashable (a, b) where hash a <> hash b newtype Bytes = Bytes ByteString - deriving newtype (Hashable, Eq, Serialize) + deriving newtype (Hashable, Eq, Serialize, NFData) instance Show Bytes where show (Bytes bs) = show $ Hex.encode bs @@ -340,7 +346,8 @@ data Verification = Verified {proof :: !Proof, params :: !Params} | InvalidItem {proof :: !Proof, item :: !Bytes, level :: !Int} | InvalidLength {proof :: !Proof, expected :: !Int} - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) -- | Verify `Proof` that the set of elements known to the prover `s_p` has size greater than $n_f$. verify :: Params -> Proof -> Verification From 9f634d18805177c79d851b31e7c97ed8515ed6b4 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Thu, 5 Sep 2024 11:40:53 +0200 Subject: [PATCH 13/17] Add 'generate' command to be able to work on a fixed set of items --- alba.cabal | 41 +++++++++++++++++++++++++++-------------- app/Main.hs | 46 ++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 65 insertions(+), 22 deletions(-) diff --git a/alba.cabal b/alba.cabal index 240eacc..f29122d 100644 --- a/alba.cabal +++ b/alba.cabal @@ -14,7 +14,17 @@ flag dump manual: True default: True +common warnings + ghc-options: -Wall -Wunused-packages -Werror + -fno-warn-missing-pattern-synonym-signatures + -fno-warn-missing-signatures + -fno-warn-name-shadowing + -fno-warn-type-defaults + -fno-warn-unused-imports + -fno-warn-unused-matches + library + import: warnings exposed-modules: ALBA hs-source-dirs: src build-depends: @@ -27,7 +37,6 @@ library default-extensions: StrictData default-language: Haskell2010 - ghc-options: -Wall -Wunused-packages extra-libraries: sodium include-dirs: cbits includes: cbits/blake2b.h @@ -37,41 +46,45 @@ library ghc-options: -ddump-simpl -ddump-stg-final -ddump-to-file executable alba + import: warnings hs-source-dirs: app main-is: Main.hs build-depends: - , alba - , base - , QuickCheck + QuickCheck + , alba + , base + , bytestring + , directory + , filepath ghc-options: -threaded -rtsopts test-suite test + import: warnings default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs other-modules: ALBASpec build-depends: - , alba - , base >=4.9 && <5 - , base16-bytestring - , bytestring - , cereal - , hspec - , QuickCheck - , quickcheck-classes - , quickcheck-instances + QuickCheck + , alba + , base >=4.9 && <5 + , bytestring + , cereal + , directory + , hspec + , quickcheck-instances build-tool-depends: hspec-discover:hspec-discover ghc-options: -rtsopts -threaded benchmark bench + import: warnings hs-source-dirs: bench/ main-is: ALBABench.hs type: exitcode-stdio-1.0 build-depends: - , aeson , alba , base , bytestring diff --git a/app/Main.hs b/app/Main.hs index 1c6c61b..7d46249 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,21 +2,27 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -import ALBA (NoProof (..), Params (..), Proof (..), Verification (Verified), genItems, prove, readProof, verify, writeProof) +import ALBA (Bytes (..), NoProof (..), Params (..), Proof (..), Verification (Verified), genItems, prove, readProof, verify, writeProof) +import Control.Monad (forM, forM_, unless) +import qualified Data.ByteString as BS import Data.Word (Word64) +import System.Directory (createDirectory, doesDirectoryExist) import System.Environment (getArgs) import System.Exit (ExitCode (..), exitSuccess, exitWith) +import System.FilePath (()) import Test.QuickCheck (generate, resize) data Command = Prove !Options | Verify !Options + | Generate !Options data Options = Options { size :: Word64 , bound :: Word64 , len :: Int , params :: Params + , input :: Maybe FilePath , output :: FilePath } deriving (Show) @@ -27,6 +33,7 @@ defaultOptions = , bound = 100 , len = 8 , params = Params 128 128 80 20 + , input = Nothing , output = "proof.alba" } @@ -34,13 +41,20 @@ main :: IO () main = do opts <- getArgs >>= parseCommand case opts of - Prove opts@Options{size, len, params = pars@Params{n_p, n_f}, output} -> do - bs <- generate $ resize (fromIntegral size) $ genItems len + Prove opts@Options{size, len, params = pars@Params{n_p, n_f}, output, input} -> do + bs <- case input of + Just dir -> do + putStrLn $ "Reading items from " <> dir + forM [1 .. size] $ \idx -> + Bytes <$> BS.readFile (dir show idx) + Nothing -> do + putStrLn "Generating random items" + generate $ resize (fromIntegral size) $ genItems len let opts'@Options{params} = adjustForSize opts putStrLn $ "Generating proof " <> show opts' case prove params bs of Left (NoProof retries) -> - putStrLn ("No proof could be generated after " <> show retries <> " retries") >> exitWith (ExitFailure 1) + putStrLn ("No proof could be written after " <> show retries <> " retries") >> exitWith (ExitFailure 1) Right prf@Proof{retryCount} -> writeProof output prf >>= \n -> putStrLn ("Written proof to '" <> output <> "' (" <> show n <> " bytes, " <> show retryCount <> " retries)") @@ -51,6 +65,15 @@ main = do case verify params prf of Verified{} -> putStrLn ("Verified proof " <> show prf) other -> putStrLn ("Cannot verify proof " <> show prf <> ", failure: " <> show other) >> exitWith (ExitFailure 1) + Generate opts@Options{output} -> do + let baseDir = output + putStrLn $ "Generating random items to " <> baseDir + exist <- doesDirectoryExist baseDir + unless exist $ createDirectory baseDir + bs <- generate $ resize (fromIntegral $ size opts) $ genItems (len opts) + forM_ (zip bs [1 ..]) $ + \(Bytes bytes, idx) -> BS.writeFile (baseDir show idx) bytes + putStrLn $ "Generated " <> show (length bs) <> " items" usage :: IO () usage = @@ -59,9 +82,9 @@ usage = [ "alba: Command-line utility for creating and verifying ALBA proofs" , "" , "Usage:" - , "alba prove : Generate an ALBA proof file from a (random) set of items" - , "alba verify : Verify an ALBA proof. Note that options must be consistent with" - , " the options used for proving" + , "alba prove : Generate an ALBA proof file from a (random) set of items" + , "alba verify : Verify an ALBA proof. Note that options must be consistent with" + , "alba generate : Generate a set of random items to be used for proof generation" , "" , "Options:" , "--help : Display this help text" @@ -72,6 +95,8 @@ usage = , "--honest-ratio " , " : The assumed _percentage_ of \"honest\" items in the input set (default: 80)" , "--output : The file containing proof to write or verify (default: alba.proof)" + , "--input : If set, reads the item to prove from the given directory instead of generating" + , " them" ] adjustForSize :: Options -> Options @@ -84,6 +109,8 @@ parseCommand = \case Prove <$> parseOptions rest ("verify" : rest) -> Verify <$> parseOptions rest + ("generate" : rest) -> + Generate <$> parseOptions rest ("--help" : _) -> usage >> exitSuccess other -> @@ -92,7 +119,7 @@ parseCommand = \case parseOptions = \case [] -> pure defaultOptions ("--help" : _) -> - usage >> exitWith ExitSuccess + usage >> exitSuccess ("--security" : lam : rest) -> do let λ = read lam opts <- parseOptions rest @@ -116,5 +143,8 @@ parseOptions = \case ("--output" : output : rest) -> do opts <- parseOptions rest pure $ opts{output} + ("--input" : input : rest) -> do + opts <- parseOptions rest + pure $ opts{input = Just input} other -> do usage >> exitWith (ExitFailure 2) From aa0ca13a0312f70abdfb3aa659ac3b4a7aea7849 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Thu, 5 Sep 2024 11:42:22 +0200 Subject: [PATCH 14/17] Edit help --- app/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 7d46249..e05d88e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -94,7 +94,8 @@ usage = , "--len : The length (in bytes) of each item in the input set (default: 8)" , "--honest-ratio " , " : The assumed _percentage_ of \"honest\" items in the input set (default: 80)" - , "--output : The file containing proof to write or verify (default: alba.proof)" + , "--output : The file containing proof to write or verify, or the directory where to generate" + , " items in (default: alba.proof)" , "--input : If set, reads the item to prove from the given directory instead of generating" , " them" ] From 824418d657fc8617a94a0d3b440d2286f58bf59f Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Thu, 5 Sep 2024 11:52:34 +0200 Subject: [PATCH 15/17] Remove unneeded package --- alba.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/alba.cabal b/alba.cabal index f29122d..b771105 100644 --- a/alba.cabal +++ b/alba.cabal @@ -72,7 +72,6 @@ test-suite test , base >=4.9 && <5 , bytestring , cereal - , directory , hspec , quickcheck-instances From 2dc09eb3cd4366bb5536457149b8e4fb557f9a4e Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Thu, 5 Sep 2024 17:24:52 +0200 Subject: [PATCH 16/17] Fix warnings --- bench/ALBABench.hs | 22 ++++++++-------------- test/ALBASpec.hs | 18 +++++++++--------- 2 files changed, 17 insertions(+), 23 deletions(-) diff --git a/bench/ALBABench.hs b/bench/ALBABench.hs index e8a6aaf..d60c342 100644 --- a/bench/ALBABench.hs +++ b/bench/ALBABench.hs @@ -16,14 +16,14 @@ main = do defaultMain [ bgroup "Proving" - $ [ benchProof (b, s_p, n_p) - | b <- benchSizes - , n_p <- [60, 66, 80] - , let high = fromIntegral b - , let low = high * n_p `div` 100 - , let mid = (high + low) `div` 2 - , s_p <- [low, mid, high] - ] + [ benchProof (b, s_p, n_p) + | b <- benchSizes + , n_p <- [60, 66, 80] + , let high = fromIntegral b + , let low = high * n_p `div` 100 + , let mid = (high + low) `div` 2 + , s_p <- [low, mid, high] + ] , bgroup "Verifying" [ benchVerification (b, n_p) @@ -43,12 +43,6 @@ benchVerification (total, n_p) = bench label $ nf (verify params) proof -benchHash :: ByteString -> Benchmark -benchHash bytes = - bench label $ nf hash bytes - where - label = "hashing len=" <> show (BS.length bytes) - benchProof :: (Int, Int, Int) -> Benchmark benchProof (total, s_p, n_p) = let params = Params 128 128 (fromIntegral $ total * n_p `div` 100) (fromIntegral $ (total * (100 - n_p)) `div` 100) diff --git a/test/ALBASpec.hs b/test/ALBASpec.hs index f053407..def9b7d 100644 --- a/test/ALBASpec.hs +++ b/test/ALBASpec.hs @@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} module ALBASpec where @@ -219,14 +221,13 @@ prop_rejectTamperedProof = genModifiedProof :: Params -> Gen (Proof, Proof) genModifiedProof params = do items <- resize 100 (genItems 100) - let (u, _, q) = computeParams params - in case prove params items of - Left (NoProof _) -> genModifiedProof params - Right proof@(Proof n k bs) -> - frequency - [ (1, pure $ (proof, Proof (n + 1) k bs)) - , (length items, (proof,) . Proof n k <$> flip1Bit bs) - ] + case prove params items of + Left (NoProof _) -> genModifiedProof params + Right proof@(Proof n k bs) -> + frequency + [ (1, pure $ (proof, Proof (n + 1) k bs)) + , (length items, (proof,) . Proof n k <$> flip1Bit bs) + ] prop_flip1Bit :: ByteString -> Property prop_flip1Bit bytes = @@ -298,7 +299,6 @@ prop_randomOracle = let h = hash bytes o = h `oracle` n oracleBytes = BS.dropWhile (== 0) $ toBytesLE o - allButOneBytes = BS.reverse $ BS.drop 1 oracleBytes in o < n & counterexample ("fast oracle (as bytes): " <> show (BS.unpack oracleBytes)) & counterexample ("fast oracle: " <> show o) From c9240f2a314ffab50f53d729db257c31489e803b Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Fri, 13 Sep 2024 09:10:46 +0200 Subject: [PATCH 17/17] Change parameters to directly set n_p and n_f --- app/Main.hs | 37 ++++++++++++++----------------------- 1 file changed, 14 insertions(+), 23 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index e05d88e..1eedd12 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -19,7 +19,6 @@ data Command data Options = Options { size :: Word64 - , bound :: Word64 , len :: Int , params :: Params , input :: Maybe FilePath @@ -30,7 +29,6 @@ data Options = Options defaultOptions = Options { size = 100 - , bound = 100 , len = 8 , params = Params 128 128 80 20 , input = Nothing @@ -41,7 +39,7 @@ main :: IO () main = do opts <- getArgs >>= parseCommand case opts of - Prove opts@Options{size, len, params = pars@Params{n_p, n_f}, output, input} -> do + Prove opts@Options{size, len, params, output, input} -> do bs <- case input of Just dir -> do putStrLn $ "Reading items from " <> dir @@ -50,17 +48,15 @@ main = do Nothing -> do putStrLn "Generating random items" generate $ resize (fromIntegral size) $ genItems len - let opts'@Options{params} = adjustForSize opts - putStrLn $ "Generating proof " <> show opts' + putStrLn $ "Generating proof " <> show opts case prove params bs of Left (NoProof retries) -> putStrLn ("No proof could be written after " <> show retries <> " retries") >> exitWith (ExitFailure 1) Right prf@Proof{retryCount} -> writeProof output prf >>= \n -> putStrLn ("Written proof to '" <> output <> "' (" <> show n <> " bytes, " <> show retryCount <> " retries)") - Verify opts@Options{size, len, params = pars@Params{n_p, n_f}, output} -> do - let opts'@Options{params} = adjustForSize opts - putStrLn $ "Verifying proof with " <> show opts' + Verify opts@Options{size, len, params, output} -> do + putStrLn $ "Verifying proof with " <> show opts readProof output >>= \prf -> case verify params prf of Verified{} -> putStrLn ("Verified proof " <> show prf) @@ -89,21 +85,16 @@ usage = , "Options:" , "--help : Display this help text" , "--security : The security level of the proof (default: 128)" - , "--size : The actual number of elements to build a proof for (default: bound * honest_ratio)" - , "--bound : The maximum number of elements in the input set (default: 100)" + , "--size : The actual number of elements to build a proof for (default: 100)" + , "--n-p : ALBA n_p parameter, e.g expected \"honest\" set size (default: 80)" + , "--n-f : ALBA n_f parameter, e.g expected \"faulty\" set size (default: 20)" , "--len : The length (in bytes) of each item in the input set (default: 8)" - , "--honest-ratio " - , " : The assumed _percentage_ of \"honest\" items in the input set (default: 80)" , "--output : The file containing proof to write or verify, or the directory where to generate" , " items in (default: alba.proof)" , "--input : If set, reads the item to prove from the given directory instead of generating" , " them" ] -adjustForSize :: Options -> Options -adjustForSize opts@Options{size, bound, params = pars@Params{n_p, n_f}} = - opts{params = pars{n_p = bound * n_p `div` 100, n_f = bound * n_f `div` 100}} - parseCommand :: [String] -> IO Command parseCommand = \case ("prove" : rest) -> @@ -129,18 +120,18 @@ parseOptions = \case let size = read sz opts <- parseOptions rest pure $ opts{size} - ("--bound" : sz : rest) -> do - let bound = read sz + ("--n-p" : np : rest) -> do + let n_p = read np + opts <- parseOptions rest + pure $ opts{params = (params opts){n_p}} + ("--n-f" : nf : rest) -> do + let n_f = read nf opts <- parseOptions rest - pure $ opts{bound} + pure $ opts{params = (params opts){n_f}} ("--len" : ln : rest) -> do let len = read ln opts <- parseOptions rest pure $ opts{len} - ("--honest-ratio" : hn : rest) -> do - let rat = read hn - opts <- parseOptions rest - pure $ opts{params = (params opts){n_p = rat, n_f = 100 - rat}} ("--output" : output : rest) -> do opts <- parseOptions rest pure $ opts{output}