summaryrefslogtreecommitdiff
path: root/tests/QuickCheck/Election.hs
diff options
context:
space:
mode:
authorjulm <>2019-05-19 15:15:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-05-19 15:15:00 (GMT)
commit443a44b7b7ccc2e5d865868f88e1c3fe62bb6364 (patch)
treefa0a42b3e25658c12d8c5b26b5ca0c9ca032c80c /tests/QuickCheck/Election.hs
parentc09719458ba041997078c969250bd7f8fa3e5a20 (diff)
version 0.0.0.201905190.0.0.20190519
Diffstat (limited to 'tests/QuickCheck/Election.hs')
-rw-r--r--tests/QuickCheck/Election.hs68
1 files changed, 39 insertions, 29 deletions
diff --git a/tests/QuickCheck/Election.hs b/tests/QuickCheck/Election.hs
index 9ea92d8..5bd09df 100644
--- a/tests/QuickCheck/Election.hs
+++ b/tests/QuickCheck/Election.hs
@@ -1,14 +1,18 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances
{-# OPTIONS -fno-warn-orphans #-}
module QuickCheck.Election where
-import Test.Tasty.QuickCheck
-import qualified Data.List as List
-import qualified Data.Text as Text
import Data.Eq (Eq(..))
import Data.Int (Int)
+import Data.Maybe (fromJust)
import Data.Ord (Ord(..))
+import GHC.Natural (minusNaturalMaybe)
import Prelude (undefined)
+import Test.Tasty.QuickCheck
+import qualified Data.Aeson as JSON
+import qualified Data.List as List
+import qualified Data.Text as Text
import Voting.Protocol
@@ -18,80 +22,86 @@ import Utils
maxArbitraryChoices :: Natural
maxArbitraryChoices = 5
maxArbitraryQuestions :: Natural
-maxArbitraryQuestions = 5
+maxArbitraryQuestions = 2
quickcheck :: TestTree
quickcheck =
testGroup "Election"
[ testGroup "verifyBallot" $
- [ testElection @WeakParams
- , testElection @BeleniosParams
+ [ testElection weakFFC
+ , testElection beleniosFFC
]
]
-testElection :: forall q. Params q => TestTree
-testElection =
- testGroup (paramsName @q)
- [ testProperty "verifyBallot" $ \(seed, (elec::Election q) :> votes) ->
+testElection :: FFC -> TestTree
+testElection ffc =
+ reify ffc $ \(Proxy::Proxy c) ->
+ testGroup (Text.unpack $ ffc_name ffc)
+ [ testProperty "verifyBallot" $ \(seed, (elec::Election c) :> votes) ->
isRight $ runExcept $
(`evalStateT` mkStdGen seed) $ do
- -- ballotSecKey :: SecretKey q <- randomSecretKey
+ -- ballotSecKey :: SecretKey c <- randomSecretKey
ballot <- encryptBallot elec Nothing votes
unless (verifyBallot elec ballot) $
lift $ throwE $ ErrorBallot_Wrong
]
-instance PrimeField p => Arbitrary (F p) where
- arbitrary = choose (zero, F (fieldCharac @p) - one)
-instance SubGroup q => Arbitrary (G q) where
+instance Reifies c FFC => Arbitrary (F c) where
+ arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one)
+instance Reifies c FFC => Arbitrary (G c) where
arbitrary = do
m <- arbitrary
return (groupGen ^ m)
-instance SubGroup q => Arbitrary (E q) where
- arbitrary = E <$> choose (zero, groupOrder @q - one)
+instance Reifies c FFC => Arbitrary (E c) where
+ arbitrary = E <$> choose (zero, fromJust $ groupOrder @c `minusNaturalMaybe` one)
instance Arbitrary UUID where
arbitrary = do
seed <- arbitrary
(`evalStateT` mkStdGen seed) $
randomUUID
-instance SubGroup q => Arbitrary (Proof q) where
+instance Reifies c FFC => Arbitrary (Proof c) where
arbitrary = do
proof_challenge <- arbitrary
proof_response <- arbitrary
return Proof{..}
-instance SubGroup q => Arbitrary (Question q) where
+instance Arbitrary Question where
arbitrary = do
let question_text = "question"
choices :: Natural <- choose (1, maxArbitraryChoices)
let question_choices = [Text.pack ("c"<>show c) | c <- [1..choices]]
- question_mini <- fromNatural <$> choose (0, choices)
- question_maxi <- fromNatural <$> choose (nat question_mini, choices)
+ question_mini <- choose (0, choices)
+ question_maxi <- choose (nat question_mini, choices)
return Question{..}
shrink quest =
[ quest{question_choices, question_mini, question_maxi}
| question_choices <- shrinkList pure $ question_choices quest
- , let nChoices = fromNatural $ fromIntegral $ List.length question_choices
- , question_mini <- shrink $ min nChoices $ max zero $ question_mini quest
- , question_maxi <- shrink $ min nChoices $ max question_mini $ question_maxi quest
+ , let nChoices = fromIntegral $ List.length question_choices
+ , question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest
+ , question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest
]
-instance SubGroup q => Arbitrary (Election q) where
+instance Reifies c FFC => Arbitrary (Election c) where
arbitrary = do
let election_name = "election"
let election_description = "description"
- election_PublicKey <- arbitrary
+ election_crypto <- arbitrary
election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary
election_uuid <- arbitrary
- let election_hash = Hash ""
+ let election_hash = hashJSON JSON.Null
return Election{..}
shrink elec =
[ elec{election_questions}
| election_questions <- shrink $ election_questions elec
]
+instance Reifies c FFC => Arbitrary (ElectionCrypto c) where
+ arbitrary = do
+ let electionCrypto_FFC_params = reflect (Proxy::Proxy c)
+ electionCrypto_FFC_PublicKey <- arbitrary
+ return ElectionCrypto_FFC{..}
-- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@.
data (:>) a b = a :> b
deriving (Eq,Show)
-instance SubGroup q => Arbitrary (Question q :> [Bool]) where
+instance Arbitrary (Question :> [Bool]) where
arbitrary = do
quest@Question{..} <- arbitrary
votes <- do
@@ -104,7 +114,7 @@ instance SubGroup q => Arbitrary (Question q :> [Bool]) where
[ q :> shrinkVotes q votes
| q <- shrink quest
]
-instance SubGroup q => Arbitrary (Election q :> [[Bool]]) where
+instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where
arbitrary = do
elec@Election{..} <- arbitrary
votes <- forM election_questions $ \Question{..} -> do
@@ -136,7 +146,7 @@ boolsOfCombin nBits nTrue rank
-- | @('shrinkVotes' quest votes)@
-- returns a reduced version of the given @votes@
-- to fit the requirement of the given @quest@.
-shrinkVotes :: Question q -> [Bool] -> [Bool]
+shrinkVotes :: Question -> [Bool] -> [Bool]
shrinkVotes Question{..} votes =
(\(nTrue, b) -> nTrue <= nat question_maxi && b)
<$> List.zip (countTrue votes) votes