]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/tests/QuickCheck/Election.hs
protocol: polish doc
[majurity.git] / hjugement-protocol / tests / QuickCheck / Election.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances
3 {-# OPTIONS -fno-warn-orphans #-}
4 module QuickCheck.Election where
5
6 import Data.Eq (Eq(..))
7 import Data.Int (Int)
8 import Data.Maybe (fromJust)
9 import Data.Ord (Ord(..))
10 import GHC.Natural (minusNaturalMaybe)
11 import Prelude (undefined)
12 import Test.Tasty.QuickCheck
13 import qualified Data.Aeson as JSON
14 import qualified Data.List as List
15 import qualified Data.Text as Text
16
17 import Voting.Protocol
18
19 import Utils
20
21 -- Hardcoded limits to avoid keep a reasonable testing time.
22 maxArbitraryChoices :: Natural
23 maxArbitraryChoices = 5
24 maxArbitraryQuestions :: Natural
25 maxArbitraryQuestions = 2
26
27 quickcheck :: TestTree
28 quickcheck =
29 testGroup "Election"
30 [ testGroup "verifyBallot" $
31 [ testElection weakFFC
32 , testElection beleniosFFC
33 ]
34 ]
35
36 testElection :: FFC -> TestTree
37 testElection ffc =
38 reify ffc $ \(Proxy::Proxy c) ->
39 testGroup (Text.unpack $ ffc_name ffc)
40 [ testProperty "verifyBallot" $ \(seed, (elec::Election c) :> votes) ->
41 isRight $ runExcept $
42 (`evalStateT` mkStdGen seed) $ do
43 -- ballotSecKey :: SecretKey c <- randomSecretKey
44 ballot <- encryptBallot elec Nothing votes
45 unless (verifyBallot elec ballot) $
46 lift $ throwE $ ErrorBallot_Wrong
47 ]
48
49 instance Reifies c FFC => Arbitrary (F c) where
50 arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one)
51 instance Reifies c FFC => Arbitrary (G c) where
52 arbitrary = do
53 m <- arbitrary
54 return (groupGen ^ m)
55 instance Reifies c FFC => Arbitrary (E c) where
56 arbitrary = E <$> choose (zero, fromJust $ groupOrder @c `minusNaturalMaybe` one)
57 instance Arbitrary UUID where
58 arbitrary = do
59 seed <- arbitrary
60 (`evalStateT` mkStdGen seed) $
61 randomUUID
62 instance Reifies c FFC => Arbitrary (Proof c) where
63 arbitrary = do
64 proof_challenge <- arbitrary
65 proof_response <- arbitrary
66 return Proof{..}
67 instance Arbitrary Question where
68 arbitrary = do
69 let question_text = "question"
70 choices :: Natural <- choose (1, maxArbitraryChoices)
71 let question_choices = [Text.pack ("c"<>show c) | c <- [1..choices]]
72 question_mini <- choose (0, choices)
73 question_maxi <- choose (nat question_mini, choices)
74 return Question{..}
75 shrink quest =
76 [ quest{question_choices, question_mini, question_maxi}
77 | question_choices <- shrinkList pure $ question_choices quest
78 , let nChoices = fromIntegral $ List.length question_choices
79 , question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest
80 , question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest
81 ]
82 instance Reifies c FFC => Arbitrary (Election c) where
83 arbitrary = do
84 let election_name = "election"
85 let election_description = "description"
86 election_crypto <- arbitrary
87 election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary
88 election_uuid <- arbitrary
89 let election_hash = hashJSON JSON.Null
90 return Election{..}
91 shrink elec =
92 [ elec{election_questions}
93 | election_questions <- shrink $ election_questions elec
94 ]
95 instance Reifies c FFC => Arbitrary (ElectionCrypto c) where
96 arbitrary = do
97 let electionCrypto_FFC_params = reflect (Proxy::Proxy c)
98 electionCrypto_FFC_PublicKey <- arbitrary
99 return ElectionCrypto_FFC{..}
100
101 -- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@.
102 data (:>) a b = a :> b
103 deriving (Eq,Show)
104 instance Arbitrary (Question :> [Bool]) where
105 arbitrary = do
106 quest@Question{..} <- arbitrary
107 votes <- do
108 let numChoices = List.length question_choices
109 numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
110 rank <- choose (0, nCk numChoices numTrue - 1)
111 return $ boolsOfCombin numChoices numTrue rank
112 return (quest :> votes)
113 shrink (quest :> votes) =
114 [ q :> shrinkVotes q votes
115 | q <- shrink quest
116 ]
117 instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where
118 arbitrary = do
119 elec@Election{..} <- arbitrary
120 votes <- forM election_questions $ \Question{..} -> do
121 let numChoices = List.length question_choices
122 numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
123 rank <- choose (0, nCk numChoices numTrue - 1)
124 return $ boolsOfCombin numChoices numTrue rank
125 return (elec :> votes)
126 shrink (elec :> votes) =
127 [ e :> List.zipWith shrinkVotes (election_questions e) votes
128 | e <- shrink elec
129 ]
130
131 -- | @('boolsOfCombin' nBits nTrue rank)@ returns the 'rank'-th sequence of 'nBits'-bits possible
132 -- with 'nTrue' bits set at 'True' and @(nBits-nTrue)@ set at 'False'.
133 -- @rank@ has to be in @[0 .. 'nCk' nBits nTrue '-' 1]@
134 boolsOfCombin :: Int -> Int -> Int -> [Bool]
135 boolsOfCombin nBits nTrue rank
136 | rank < 0 = undefined
137 | nTrue == 0 = List.replicate nBits False
138 | otherwise = go 0 cs <> List.replicate (nBits-List.last cs) False
139 where
140 cs = combinOfRank nBits nTrue rank
141 go _d [] = []
142 go curr (next:ns) =
143 List.replicate (next-1-curr) False <> [True]
144 <> go next ns
145
146 -- | @('shrinkVotes' quest votes)@
147 -- returns a reduced version of the given @votes@
148 -- to fit the requirement of the given @quest@.
149 shrinkVotes :: Question -> [Bool] -> [Bool]
150 shrinkVotes Question{..} votes =
151 (\(nTrue, b) -> nTrue <= nat question_maxi && b)
152 <$> List.zip (countTrue votes) votes
153 where
154 countTrue :: [Bool] -> [Natural]
155 countTrue = List.foldl' (\ns b -> if b then inc ns else ns) []
156 where
157 inc [] = [zero]
158 inc (n:ns) = (n+one):n:ns
159