]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/tests/QuickCheck/Election.hs
cli: admin: directly use election_hash
[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 :: Reifies v Version => Proxy v -> TestTree
28 quickcheck v =
29 testGroup "Election"
30 [ testGroup "verifyBallot" $
31 [ reify weakFFC $ quickcheckElection v
32 , reify beleniosFFC $ quickcheckElection v
33 ]
34 ]
35
36 quickcheckElection ::
37 Reifies v Version =>
38 CryptoParams crypto c =>
39 Key crypto => JSON.ToJSON crypto => Show crypto =>
40 Proxy v -> Proxy c -> TestTree
41 quickcheckElection (_v::Proxy v) (c::Proxy c) =
42 testGroup (Text.unpack $ cryptoName (reflect c))
43 [ testProperty "verifyBallot" $ \(seed, (elec::Election crypto v c) :> votes) ->
44 isRight $ runExcept $
45 (`evalStateT` mkStdGen seed) $ do
46 -- ballotSecKey :: SecretKey c <- randomSecretKey
47 ballot <- encryptBallot elec Nothing votes
48 unless (verifyBallot elec ballot) $
49 lift $ throwE $ ErrorBallot_Wrong
50 ]
51
52 {-
53 instance Reifies c FFC => Arbitrary (F c) where
54 arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one)
55 -}
56 instance CryptoParams crypto c => Arbitrary (G crypto c) where
57 arbitrary = do
58 m <- arbitrary
59 return (groupGen ^ m)
60 instance CryptoParams crypto c => Arbitrary (E crypto c) where
61 arbitrary = E <$> choose (zero, fromJust $ groupOrder @crypto (Proxy @c) `minusNaturalMaybe` one)
62 instance Arbitrary UUID where
63 arbitrary = do
64 seed <- arbitrary
65 (`evalStateT` mkStdGen seed) $
66 randomUUID
67 instance
68 ( Reifies v Version
69 , CryptoParams crypto c
70 , Arbitrary (E crypto c)
71 ) => Arbitrary (Proof crypto v c) where
72 arbitrary = do
73 proof_challenge <- arbitrary
74 proof_response <- arbitrary
75 return Proof{..}
76 instance Reifies v Version => Arbitrary (Question v) where
77 arbitrary = do
78 let question_text = "question"
79 choices :: Natural <- choose (1, maxArbitraryChoices)
80 let question_choices = [Text.pack ("c"<>show c) | c <- [1..choices]]
81 question_mini <- choose (0, choices)
82 question_maxi <- choose (nat question_mini, choices)
83 return Question{..}
84 shrink quest =
85 [ quest{question_choices, question_mini, question_maxi}
86 | question_choices <- shrinkList pure $ question_choices quest
87 , let nChoices = fromIntegral $ List.length question_choices
88 , question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest
89 , question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest
90 ]
91 instance
92 ( Reifies v Version
93 , CryptoParams crypto c
94 , Key crypto
95 , JSON.ToJSON crypto
96 ) => Arbitrary (Election crypto v c) where
97 arbitrary = do
98 let election_name = "election"
99 let election_description = "description"
100 let election_crypto = reflect (Proxy @c)
101 election_secret_key <- arbitrary
102 let election_public_key = publicKey election_secret_key
103 election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary
104 election_uuid <- arbitrary
105 let elec = Election
106 { election_hash = hashElection elec
107 , election_version = Just (reflect (Proxy @v))
108 , ..
109 }
110 return elec
111 shrink elec =
112 [ elec{election_questions}
113 | election_questions <- shrink $ election_questions elec
114 ]
115 {-
116 instance Reifies c FFC => Arbitrary (ElectionCrypto c) where
117 arbitrary = do
118 let electionCrypto_FFC_params = reflect (Proxy::Proxy c)
119 electionCrypto_FFC_PublicKey <- arbitrary
120 return ElectionCrypto_FFC{..}
121 -}
122
123 -- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@.
124 data (:>) a b = a :> b
125 deriving (Eq,Show)
126 instance Reifies v Version => Arbitrary (Question v :> [Bool]) where
127 arbitrary = do
128 quest@Question{..} <- arbitrary
129 votes <- do
130 let numChoices = List.length question_choices
131 numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
132 rank <- choose (0, nCk numChoices numTrue - 1)
133 return $ boolsOfCombin numChoices numTrue rank
134 return (quest :> votes)
135 shrink (quest :> votes) =
136 [ q :> shrinkVotes q votes
137 | q <- shrink quest
138 ]
139 instance
140 ( Reifies v Version
141 , CryptoParams crypto c
142 , Key crypto
143 , JSON.ToJSON crypto
144 ) => Arbitrary (Election crypto v c :> [[Bool]]) where
145 arbitrary = do
146 elec@Election{..} <- arbitrary
147 votes <- forM election_questions $ \Question{..} -> do
148 let numChoices = List.length question_choices
149 numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)
150 rank <- choose (0, nCk numChoices numTrue - 1)
151 return $ boolsOfCombin numChoices numTrue rank
152 return (elec :> votes)
153 shrink (elec :> votes) =
154 [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes
155 | e <- shrink elec
156 ]
157
158 -- | @('boolsOfCombin' nBits nTrue rank)@ returns the 'rank'-th sequence of 'nBits'-bits possible
159 -- with 'nTrue' bits set at 'True' and @(nBits-nTrue)@ set at 'False'.
160 -- @rank@ has to be in @[0 .. 'nCk' nBits nTrue '-' 1]@
161 boolsOfCombin :: Int -> Int -> Int -> [Bool]
162 boolsOfCombin nBits nTrue rank
163 | rank < 0 = undefined
164 | nTrue == 0 = List.replicate nBits False
165 | otherwise = go 0 cs <> List.replicate (nBits-List.last cs) False
166 where
167 cs = combinOfRank nBits nTrue rank
168 go _d [] = []
169 go curr (next:ns) =
170 List.replicate (next-1-curr) False <> [True]
171 <> go next ns
172
173 -- | @('shrinkVotes' quest votes)@
174 -- returns a reduced version of the given @votes@
175 -- to fit the requirement of the given @quest@.
176 shrinkVotes :: Reifies v Version => Question v -> [Bool] -> [Bool]
177 shrinkVotes Question{..} votes =
178 (\(nTrue, b) -> nTrue <= nat question_maxi && b)
179 <$> List.zip (countTrue votes) votes
180 where
181 countTrue :: [Bool] -> [Natural]
182 countTrue = List.foldl' (\ns b -> if b then inc ns else ns) []
183 where
184 inc [] = [zero]
185 inc (n:ns) = (n+one):n:ns