]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/src/Voting/Protocol/Election.hs
protocol: split Election module and improve Version
[majurity.git] / hjugement-protocol / src / Voting / Protocol / Election.hs
1 {-# LANGUAGE DeriveAnyClass #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE DerivingStrategies #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE Rank2Types #-} -- for readElection
6 {-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances
7 module Voting.Protocol.Election where
8
9 import Control.DeepSeq (NFData)
10 import Control.Monad (Monad(..), mapM, zipWithM)
11 import Control.Monad.Trans.Class (MonadTrans(..))
12 import Control.Monad.Trans.Except (ExceptT(..), runExcept, throwE, withExceptT)
13 import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))
14 import Data.Bool
15 import Data.Either (either)
16 import Data.Eq (Eq(..))
17 import Data.Foldable (foldMap, and)
18 import Data.Function (($), (.), id, const)
19 import Data.Functor ((<$>))
20 import Data.Functor.Identity (Identity(..))
21 import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe)
22 import Data.Monoid (Monoid(..))
23 import Data.Ord (Ord(..))
24 import Data.Proxy (Proxy(..))
25 import Data.Reflection (Reifies(..), reify)
26 import Data.Semigroup (Semigroup(..))
27 import Data.String (String)
28 import Data.Text (Text)
29 import Data.Traversable (Traversable(..))
30 import Data.Tuple (fst, snd)
31 import GHC.Generics (Generic)
32 import GHC.Natural (minusNaturalMaybe)
33 import Numeric.Natural (Natural)
34 import Prelude (fromIntegral)
35 import System.IO (IO, FilePath)
36 import System.Random (RandomGen)
37 import Text.Show (Show(..))
38 import qualified Control.Monad.Trans.State.Strict as S
39 import qualified Data.Aeson as JSON
40 import qualified Data.Aeson.Encoding as JSON
41 import qualified Data.Aeson.Internal as JSON
42 import qualified Data.Aeson.Parser.Internal as JSON
43 import qualified Data.Aeson.Types as JSON
44 import qualified Data.ByteString as BS
45 import qualified Data.ByteString.Lazy as BSL
46 import qualified Data.List as List
47
48 import Voting.Protocol.Utils
49 import Voting.Protocol.Arithmetic
50 import Voting.Protocol.Version
51 import Voting.Protocol.Credential
52 import Voting.Protocol.Cryptography
53
54 -- * Type 'Question'
55 data Question v = Question
56 { question_text :: !Text
57 , question_choices :: ![Text]
58 , question_mini :: !Natural
59 , question_maxi :: !Natural
60 -- , question_blank :: Maybe Bool
61 } deriving (Eq,Show,Generic,NFData)
62 instance Reifies v Version => ToJSON (Question v) where
63 toJSON Question{..} =
64 JSON.object
65 [ "question" .= question_text
66 , "answers" .= question_choices
67 , "min" .= question_mini
68 , "max" .= question_maxi
69 ]
70 toEncoding Question{..} =
71 JSON.pairs
72 ( "question" .= question_text
73 <> "answers" .= question_choices
74 <> "min" .= question_mini
75 <> "max" .= question_maxi
76 )
77 instance Reifies v Version => FromJSON (Question v) where
78 parseJSON = JSON.withObject "Question" $ \o -> do
79 question_text <- o .: "question"
80 question_choices <- o .: "answers"
81 question_mini <- o .: "min"
82 question_maxi <- o .: "max"
83 return Question{..}
84
85 -- * Type 'Answer'
86 data Answer crypto v c = Answer
87 { answer_opinions :: ![(Encryption crypto v c, DisjProof crypto v c)]
88 -- ^ Encrypted 'Opinion' for each 'question_choices'
89 -- with a 'DisjProof' that they belong to [0,1].
90 , answer_sumProof :: !(DisjProof crypto v c)
91 -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
92 -- is an element of @[mini..maxi]@.
93 -- , answer_blankProof ::
94 } deriving (Generic)
95 deriving instance Eq (G crypto c) => Eq (Answer crypto v c)
96 deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Answer crypto v c)
97 deriving instance NFData (G crypto c) => NFData (Answer crypto v c)
98 instance
99 ( Reifies v Version
100 , CryptoParams crypto c
101 ) => ToJSON (Answer crypto v c) where
102 toJSON Answer{..} =
103 let (answer_choices, answer_individual_proofs) =
104 List.unzip answer_opinions in
105 JSON.object
106 [ "choices" .= answer_choices
107 , "individual_proofs" .= answer_individual_proofs
108 , "overall_proof" .= answer_sumProof
109 ]
110 toEncoding Answer{..} =
111 let (answer_choices, answer_individual_proofs) =
112 List.unzip answer_opinions in
113 JSON.pairs
114 ( "choices" .= answer_choices
115 <> "individual_proofs" .= answer_individual_proofs
116 <> "overall_proof" .= answer_sumProof
117 )
118 instance
119 ( Reifies v Version
120 , CryptoParams crypto c
121 ) => FromJSON (Answer crypto v c) where
122 parseJSON = JSON.withObject "Answer" $ \o -> do
123 answer_choices <- o .: "choices"
124 answer_individual_proofs <- o .: "individual_proofs"
125 let answer_opinions = List.zip answer_choices answer_individual_proofs
126 answer_sumProof <- o .: "overall_proof"
127 return Answer{..}
128
129 -- | @('encryptAnswer' elecPubKey zkp quest opinions)@
130 -- returns an 'Answer' validable by 'verifyAnswer',
131 -- unless an 'ErrorAnswer' is returned.
132 encryptAnswer ::
133 Reifies v Version =>
134 CryptoParams crypto c =>
135 Monad m => RandomGen r =>
136 PublicKey crypto c -> ZKP ->
137 Question v -> [Bool] ->
138 S.StateT r (ExceptT ErrorAnswer m) (Answer crypto v c)
139 encryptAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} opinionByChoice
140 | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
141 lift $ throwE $
142 ErrorAnswer_WrongSumOfOpinions opinionsSum question_mini question_maxi
143 | List.length opinions /= List.length question_choices =
144 lift $ throwE $
145 ErrorAnswer_WrongNumberOfOpinions
146 (fromIntegral $ List.length opinions)
147 (fromIntegral $ List.length question_choices)
148 | otherwise = do
149 encryptions <- encrypt elecPubKey `mapM` opinions
150 individualProofs <- zipWithM
151 (\opinion -> proveEncryption elecPubKey zkp $
152 if opinion
153 then (List.init booleanDisjunctions,[])
154 else ([],List.tail booleanDisjunctions))
155 opinionByChoice encryptions
156 sumProof <- proveEncryption elecPubKey zkp
157 (List.tail <$> List.genericSplitAt
158 (fromJust $ opinionsSum`minusNaturalMaybe`question_mini)
159 (intervalDisjunctions question_mini question_maxi))
160 ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's
161 , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's
162 )
163 return $ Answer
164 { answer_opinions = List.zip
165 (snd <$> encryptions) -- NOTE: drop encNonce
166 individualProofs
167 , answer_sumProof = sumProof
168 }
169 where
170 opinionsSum = sum $ nat <$> opinions
171 opinions = (\o -> if o then one else zero) <$> opinionByChoice
172
173 verifyAnswer ::
174 Reifies v Version =>
175 CryptoParams crypto c =>
176 PublicKey crypto c -> ZKP ->
177 Question v -> Answer crypto v c -> Bool
178 verifyAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} Answer{..}
179 | List.length question_choices /= List.length answer_opinions = False
180 | otherwise = do
181 either (const False) id $ runExcept $ do
182 validOpinions <-
183 verifyEncryption elecPubKey zkp booleanDisjunctions
184 `traverse` answer_opinions
185 validSum <- verifyEncryption elecPubKey zkp
186 (intervalDisjunctions question_mini question_maxi)
187 ( sum (fst <$> answer_opinions)
188 , answer_sumProof )
189 return (and validOpinions && validSum)
190
191 -- ** Type 'ErrorAnswer'
192 -- | Error raised by 'encryptAnswer'.
193 data ErrorAnswer
194 = ErrorAnswer_WrongNumberOfOpinions Natural Natural
195 -- ^ When the number of opinions is different than
196 -- the number of choices ('question_choices').
197 | ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
198 -- ^ When the sum of opinions is not within the bounds
199 -- of 'question_mini' and 'question_maxi'.
200 deriving (Eq,Show,Generic,NFData)
201
202 -- ** Type 'Opinion'
203 -- | Index of a 'Disjunction' within a list of them.
204 -- It is encrypted as a 'GroupExponent' by 'encrypt'.
205 type Opinion = E
206
207 -- * Type 'Election'
208 data Election crypto v c = Election
209 { election_name :: !Text
210 , election_description :: !Text
211 , election_questions :: ![Question v]
212 , election_uuid :: !UUID
213 , election_hash :: Base64SHA256
214 , election_crypto :: !crypto
215 , election_version :: !(Maybe Version)
216 , election_public_key :: !(PublicKey crypto c)
217 } deriving (Generic)
218 deriving instance (Eq crypto, Eq (G crypto c)) => Eq (Election crypto v c)
219 deriving instance (Show crypto, Show (G crypto c)) => Show (Election crypto v c)
220 deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Election crypto v c)
221 instance
222 ( Reifies v Version
223 , CryptoParams crypto c
224 , ToJSON crypto
225 ) => ToJSON (Election crypto v c) where
226 toJSON Election{..} =
227 JSON.object $
228 [ "name" .= election_name
229 , "description" .= election_description
230 , ("public_key", JSON.object
231 [ "group" .= election_crypto
232 , "y" .= election_public_key
233 ])
234 , "questions" .= election_questions
235 , "uuid" .= election_uuid
236 ] <>
237 maybe [] (\version -> [ "version" .= version ]) election_version
238 toEncoding Election{..} =
239 JSON.pairs $
240 ( "name" .= election_name
241 <> "description" .= election_description
242 <> JSON.pair "public_key" (JSON.pairs $
243 "group" .= election_crypto
244 <> "y" .= election_public_key
245 )
246 <> "questions" .= election_questions
247 <> "uuid" .= election_uuid
248 ) <>
249 maybe mempty ("version" .=) election_version
250
251 hashElection ::
252 Reifies v Version =>
253 CryptoParams crypto c =>
254 ToJSON crypto =>
255 Election crypto v c -> Base64SHA256
256 hashElection = base64SHA256 . BSL.toStrict . JSON.encode
257
258 readElection ::
259 forall crypto r.
260 FromJSON crypto =>
261 ReifyCrypto crypto =>
262 FilePath ->
263 (forall v c.
264 Reifies v Version =>
265 CryptoParams crypto c =>
266 Election crypto v c -> r) ->
267 ExceptT String IO r
268 readElection filePath k = do
269 fileData <- lift $ BS.readFile filePath
270 ExceptT $ return $
271 jsonEitherFormatError $
272 JSON.eitherDecodeStrictWith JSON.jsonEOF
273 (JSON.iparse (parseElection fileData))
274 fileData
275 where
276 parseElection fileData = JSON.withObject "Election" $ \o -> do
277 election_version <- o .:? "version"
278 reify (fromMaybe stableVersion election_version) $ \(_v::Proxy v) -> do
279 (election_crypto, elecPubKey) <-
280 JSON.explicitParseField
281 (JSON.withObject "public_key" $ \obj -> do
282 crypto <- obj .: "group"
283 pubKey :: JSON.Value <- obj .: "y"
284 return (crypto, pubKey)
285 ) o "public_key"
286 reifyCrypto election_crypto $ \(_c::Proxy c) -> do
287 election_name <- o .: "name"
288 election_description <- o .: "description"
289 election_questions <- o .: "questions" :: JSON.Parser [Question v]
290 election_uuid <- o .: "uuid"
291 election_public_key :: PublicKey crypto c <- parseJSON elecPubKey
292 return $ k $ Election
293 { election_questions = election_questions
294 , election_public_key = election_public_key
295 , election_hash = base64SHA256 fileData
296 , ..
297 }
298
299 -- * Type 'Ballot'
300 data Ballot crypto v c = Ballot
301 { ballot_answers :: ![Answer crypto v c]
302 , ballot_signature :: !(Maybe (Signature crypto v c))
303 , ballot_election_uuid :: !UUID
304 , ballot_election_hash :: !Base64SHA256
305 } deriving (Generic)
306 deriving instance (NFData (G crypto c), NFData crypto) => NFData (Ballot crypto v c)
307 instance
308 ( Reifies v Version
309 , CryptoParams crypto c
310 , ToJSON (G crypto c)
311 ) => ToJSON (Ballot crypto v c) where
312 toJSON Ballot{..} =
313 JSON.object $
314 [ "answers" .= ballot_answers
315 , "election_uuid" .= ballot_election_uuid
316 , "election_hash" .= ballot_election_hash
317 ] <>
318 maybe [] (\sig -> [ "signature" .= sig ]) ballot_signature
319 toEncoding Ballot{..} =
320 JSON.pairs $
321 ( "answers" .= ballot_answers
322 <> "election_uuid" .= ballot_election_uuid
323 <> "election_hash" .= ballot_election_hash
324 ) <>
325 maybe mempty ("signature" .=) ballot_signature
326 instance
327 ( Reifies v Version
328 , CryptoParams crypto c
329 ) => FromJSON (Ballot crypto v c) where
330 parseJSON = JSON.withObject "Ballot" $ \o -> do
331 ballot_answers <- o .: "answers"
332 ballot_signature <- o .:? "signature"
333 ballot_election_uuid <- o .: "election_uuid"
334 ballot_election_hash <- o .: "election_hash"
335 return Ballot{..}
336
337 -- | @('encryptBallot' c ('Just' ballotSecKey) opinionsByQuest)@
338 -- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
339 -- where 'opinionsByQuest' is a list of 'Opinion's
340 -- on each 'question_choices' of each 'election_questions'.
341 encryptBallot ::
342 Reifies v Version =>
343 CryptoParams crypto c => Key crypto =>
344 Monad m => RandomGen r =>
345 Election crypto v c ->
346 Maybe (SecretKey crypto c) -> [[Bool]] ->
347 S.StateT r (ExceptT ErrorBallot m) (Ballot crypto v c)
348 encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQuest
349 | List.length election_questions /= List.length opinionsByQuest =
350 lift $ throwE $
351 ErrorBallot_WrongNumberOfAnswers
352 (fromIntegral $ List.length opinionsByQuest)
353 (fromIntegral $ List.length election_questions)
354 | otherwise = do
355 let (voterKeys, voterZKP) =
356 case ballotSecKeyMay of
357 Nothing -> (Nothing, ZKP "")
358 Just ballotSecKey ->
359 ( Just (ballotSecKey, ballotPubKey)
360 , ZKP (bytesNat ballotPubKey) )
361 where ballotPubKey = publicKey ballotSecKey
362 ballot_answers <-
363 S.mapStateT (withExceptT ErrorBallot_Answer) $
364 zipWithM (encryptAnswer election_public_key voterZKP)
365 election_questions opinionsByQuest
366 ballot_signature <- case voterKeys of
367 Nothing -> return Nothing
368 Just (ballotSecKey, signature_publicKey) -> do
369 signature_proof <-
370 proveQuicker ballotSecKey (Identity groupGen) $
371 \(Identity commitment) ->
372 hash @crypto
373 -- NOTE: the order is unusual, the commitments are first
374 -- then comes the statement. Best guess is that
375 -- this is easier to code due to their respective types.
376 (ballotCommitments @crypto voterZKP commitment)
377 (ballotStatement @crypto ballot_answers)
378 return $ Just Signature{..}
379 return Ballot
380 { ballot_answers
381 , ballot_election_hash = election_hash
382 , ballot_election_uuid = election_uuid
383 , ballot_signature
384 }
385
386 verifyBallot ::
387 Reifies v Version =>
388 CryptoParams crypto c =>
389 Election crypto v c ->
390 Ballot crypto v c -> Bool
391 verifyBallot (Election{..}::Election crypto v c) Ballot{..} =
392 ballot_election_uuid == election_uuid &&
393 ballot_election_hash == election_hash &&
394 List.length election_questions == List.length ballot_answers &&
395 let (isValidSign, zkpSign) =
396 case ballot_signature of
397 Nothing -> (True, ZKP "")
398 Just Signature{..} ->
399 let zkp = ZKP (bytesNat signature_publicKey) in
400 (, zkp) $
401 proof_challenge signature_proof == hash
402 (ballotCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey))
403 (ballotStatement @crypto ballot_answers)
404 in
405 and $ isValidSign :
406 List.zipWith (verifyAnswer election_public_key zkpSign)
407 election_questions ballot_answers
408
409
410 -- ** Type 'ErrorBallot'
411 -- | Error raised by 'encryptBallot'.
412 data ErrorBallot
413 = ErrorBallot_WrongNumberOfAnswers Natural Natural
414 -- ^ When the number of answers
415 -- is different than the number of questions.
416 | ErrorBallot_Answer ErrorAnswer
417 -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
418 | ErrorBallot_Wrong
419 -- ^ TODO: to be more precise.
420 deriving (Eq,Show,Generic,NFData)
421
422 -- ** Hashing
423
424 -- | @('ballotStatement' ballot)@
425 -- returns the encrypted material to be signed:
426 -- all the 'encryption_nonce's and 'encryption_vault's of the given 'ballot_answers'.
427 ballotStatement :: CryptoParams crypto c => [Answer crypto v c] -> [G crypto c]
428 ballotStatement =
429 foldMap $ \Answer{..} ->
430 (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
431 [encryption_nonce, encryption_vault]
432
433 -- | @('ballotCommitments' voterZKP commitment)@
434 ballotCommitments ::
435 CryptoParams crypto c =>
436 ToNatural (G crypto c) =>
437 ZKP -> Commitment crypto c -> BS.ByteString
438 ballotCommitments (ZKP voterZKP) commitment =
439 "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
440 <> bytesNat commitment<>"|"