]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/src/Voting/Protocol/Election.hs
protocol: fix import in tests
[majurity.git] / hjugement-protocol / src / Voting / Protocol / Election.hs
1 {-# LANGUAGE DeriveAnyClass #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Voting.Protocol.Election where
5
6 import Control.DeepSeq (NFData)
7 import Control.Monad (Monad(..), join, mapM, replicateM, unless, zipWithM)
8 import Control.Monad.Trans.Class (MonadTrans(..))
9 import Control.Monad.Trans.Except (Except, ExceptT, runExcept, throwE, withExceptT)
10 import Data.Bool
11 import Data.Either (either)
12 import Data.Eq (Eq(..))
13 import Data.Foldable (Foldable, foldMap, and)
14 import Data.Function (($), id, const)
15 import Data.Functor (Functor, (<$>))
16 import Data.Functor.Identity (Identity(..))
17 import Data.Maybe (Maybe(..), fromMaybe, maybe)
18 import Data.Ord (Ord(..))
19 import Data.Semigroup (Semigroup(..))
20 import Data.Text (Text)
21 import Data.Traversable (Traversable(..))
22 import Data.Tuple (fst, snd, uncurry)
23 import GHC.Natural (minusNaturalMaybe)
24 import GHC.Generics (Generic)
25 import Numeric.Natural (Natural)
26 import Prelude (fromIntegral)
27 import Text.Show (Show(..))
28 import qualified Control.Monad.Trans.State.Strict as S
29 import qualified Data.ByteString as BS
30 import qualified Data.List as List
31 import qualified Data.Map.Strict as Map
32
33 import Voting.Protocol.Utils
34 import Voting.Protocol.Arithmetic
35 import Voting.Protocol.Credential
36
37 -- * Type 'Encryption'
38 -- | ElGamal-like encryption.
39 -- Its security relies on the /Discrete Logarithm problem/.
40 --
41 -- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),
42 -- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@
43 -- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable,
44 -- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like")
45 -- to enable the additive homomorphism.
46 --
47 -- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@,
48 -- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.
49 data Encryption q = Encryption
50 { encryption_nonce :: G q
51 -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text,
52 -- equal to @('groupGen' '^'encNonce)@
53 , encryption_vault :: G q
54 -- ^ Encrypted 'clear' text,
55 -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@
56 } deriving (Eq,Show,Generic,NFData)
57
58 -- | Additive homomorphism.
59 -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
60 instance SubGroup q => Additive (Encryption q) where
61 zero = Encryption one one
62 x+y = Encryption
63 (encryption_nonce x * encryption_nonce y)
64 (encryption_vault x * encryption_vault y)
65
66 -- *** Type 'EncryptionNonce'
67 type EncryptionNonce = E
68
69 -- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.
70 --
71 -- WARNING: the secret encryption nonce (@encNonce@)
72 -- is returned alongside the 'Encryption'
73 -- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption',
74 -- but this secret @encNonce@ MUST be forgotten after that,
75 -- as it may be used to decipher the 'Encryption'
76 -- without the 'SecretKey' associated with 'pubKey'.
77 encrypt ::
78 Monad m => RandomGen r => SubGroup q =>
79 PublicKey q -> E q ->
80 S.StateT r m (EncryptionNonce q, Encryption q)
81 encrypt pubKey clear = do
82 encNonce <- random
83 -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.
84 return $ (encNonce,)
85 Encryption
86 { encryption_nonce = groupGen^encNonce
87 , encryption_vault = pubKey ^encNonce * groupGen^clear
88 }
89
90 -- * Type 'Proof'
91 -- | Non-Interactive Zero-Knowledge 'Proof'
92 -- of knowledge of a discrete logarithm:
93 -- @(secret == logBase base (base^secret))@.
94 data Proof q = Proof
95 { proof_challenge :: Challenge q
96 -- ^ 'Challenge' sent by the verifier to the prover
97 -- to ensure that the prover really has knowledge
98 -- of the secret and is not replaying.
99 -- Actually, 'proof_challenge' is not sent to the prover,
100 -- but derived from the prover's 'Commitment's and statements
101 -- with a collision resistant 'hash'.
102 -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.
103 , proof_response :: E q
104 -- ^ A discrete logarithm sent by the prover to the verifier,
105 -- as a response to 'proof_challenge'.
106 --
107 -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:
108 --
109 -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@,
110 -- * @commitment '==' 'commit' proof base basePowSec '=='
111 -- base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@,
112 -- * and @basePowSec '==' base'^'sec@,
113 --
114 -- then, with overwhelming probability (due to the 'hash' function),
115 -- the prover was not able to choose 'proof_challenge'
116 -- yet was able to compute a 'proof_response' such that
117 -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),
118 -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,
119 -- therefore the prover knows 'sec'.
120 --
121 -- The prover choses 'commitment' to be a random power of @base@,
122 -- to ensure that each 'prove' does not reveal any information
123 -- about its secret.
124 } deriving (Eq,Show,Generic,NFData)
125
126 -- ** Type 'ZKP'
127 -- | Zero-knowledge proof.
128 --
129 -- A protocol is /zero-knowledge/ if the verifier
130 -- learns nothing from the protocol except that the prover
131 -- knows the secret.
132 --
133 -- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:
134 -- A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.
135 newtype ZKP = ZKP BS.ByteString
136
137 -- ** Type 'Challenge'
138 type Challenge = E
139
140 -- ** Type 'Oracle'
141 -- An 'Oracle' returns the 'Challenge' of the 'Commitment's
142 -- by 'hash'ing them (eventually with other 'Commitment's).
143 --
144 -- Used in 'prove' it enables a Fiat-Shamir transformation
145 -- of an /interactive zero-knowledge/ (IZK) proof
146 -- into a /non-interactive zero-knowledge/ (NIZK) proof.
147 -- That is to say that the verifier does not have
148 -- to send a 'Challenge' to the prover.
149 -- Indeed, the prover now handles the 'Challenge'
150 -- which becomes a (collision resistant) 'hash'
151 -- of the prover's commitments (and statements to be a stronger proof).
152 type Oracle list q = list (Commitment q) -> Challenge q
153
154 -- | @('prove' sec commitBases oracle)@
155 -- returns a 'Proof' that @sec@ is known
156 -- (by proving the knowledge of its discrete logarithm).
157 --
158 -- The 'Oracle' is given 'Commitment's equal to the 'commitBases'
159 -- raised to the power of the secret nonce of the 'Proof',
160 -- as those are the 'Commitment's that the verifier will obtain
161 -- when composing the 'proof_challenge' and 'proof_response' together
162 -- (with 'commit').
163 --
164 -- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):
165 -- the statement must be included in the 'hash' (along with the commitments).
166 --
167 -- NOTE: a 'random' @nonce@ is used to ensure each 'prove'
168 -- does not reveal any information regarding the secret @sec@,
169 -- because two 'Proof's using the same 'Commitment'
170 -- can be used to deduce @sec@ (using the special-soundness).
171 prove ::
172 Monad m => RandomGen r => SubGroup q => Functor list =>
173 E q -> list (G q) -> Oracle list q -> S.StateT r m (Proof q)
174 prove sec commitBases oracle = do
175 nonce <- random
176 let commitments = (^ nonce) <$> commitBases
177 let proof_challenge = oracle commitments
178 return Proof
179 { proof_challenge
180 , proof_response = nonce - sec*proof_challenge
181 }
182
183 -- | @('fakeProof')@ returns a 'Proof'
184 -- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,
185 -- instead of @('proof_challenge' '==' 'hash' statement commitments)@
186 -- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@
187 -- as a 'Proof' returned by 'prove'.
188 --
189 -- Used in 'proveEncryption' to fill the returned 'DisjProof'
190 -- with fake 'Proof's for all 'Disjunction's but the encrypted one.
191 fakeProof :: Monad m => RandomGen r => SubGroup q => S.StateT r m (Proof q)
192 fakeProof = do
193 proof_challenge <- random
194 proof_response <- random
195 return Proof{..}
196
197 -- ** Type 'Commitment'
198 -- | A commitment from the prover to the verifier.
199 -- It's a power of 'groupGen' chosen randomly by the prover
200 -- when making a 'Proof' with 'prove'.
201 type Commitment = G
202
203 -- | @('commit' proof base basePowSec)@ returns a 'Commitment'
204 -- from the given 'Proof' with the knowledge of the verifier.
205 commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q
206 commit Proof{..} base basePowSec =
207 base^proof_response *
208 basePowSec^proof_challenge
209 -- NOTE: Contrary to some textbook presentations,
210 -- @('*')@ is used instead of @('/')@ to avoid the performance cost
211 -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@,
212 -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'.
213 {-# INLINE commit #-}
214
215 -- * Type 'Disjunction'
216 -- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@
217 -- it's used in 'proveEncryption' to generate a 'Proof'
218 -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,
219 type Disjunction = G
220
221 booleanDisjunctions :: SubGroup q => [Disjunction q]
222 booleanDisjunctions = List.take 2 groupGenInverses
223
224 intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q]
225 intervalDisjunctions mini maxi =
226 List.genericTake (fromMaybe 0 $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $
227 List.genericDrop (nat mini) $
228 groupGenInverses
229
230 -- ** Type 'Opinion'
231 -- | Index of a 'Disjunction' within a list of them.
232 -- It is encrypted as an 'E'xponent by 'encrypt'.
233 type Opinion = E
234
235 -- ** Type 'DisjProof'
236 -- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption'
237 -- is indexing a 'Disjunction' within a list of them,
238 -- without revealing which 'Opinion' it is.
239 newtype DisjProof q = DisjProof [Proof q]
240 deriving (Eq,Show,Generic,NFData)
241
242 -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@
243 -- returns a 'DisjProof' that 'enc' 'encrypt's
244 -- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.
245 --
246 -- The prover proves that it knows an 'encNonce', such that:
247 -- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@
248 --
249 -- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.
250 --
251 -- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.
252 proveEncryption ::
253 Monad m => RandomGen r => SubGroup q =>
254 PublicKey q -> ZKP ->
255 ([Disjunction q],[Disjunction q]) ->
256 (EncryptionNonce q, Encryption q) ->
257 S.StateT r m (DisjProof q)
258 proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do
259 -- Fake proofs for all 'Disjunction's except the genuine one.
260 prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof
261 nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof
262 let fakeChallengeSum =
263 sum (proof_challenge <$> prevFakeProofs) +
264 sum (proof_challenge <$> nextFakeProofs)
265 let statement = encryptionStatement voterZKP enc
266 genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->
267 let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in
268 let prevCommitments = validCommitments prevDisjs prevFakeProofs in
269 let nextCommitments = validCommitments nextDisjs nextFakeProofs in
270 let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in
271 let challenge = hash statement commitments in
272 let genuineChallenge = challenge - fakeChallengeSum in
273 genuineChallenge
274 -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)
275 -- thus (sum (proof_challenge <$> proofs) == challenge)
276 -- as checked in 'verifyEncryption'.
277 let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
278 return (DisjProof proofs)
279
280 verifyEncryption ::
281 Monad m => SubGroup q =>
282 PublicKey q -> ZKP ->
283 [Disjunction q] -> (Encryption q, DisjProof q) ->
284 ExceptT ErrorVerifyEncryption m Bool
285 verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =
286 case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of
287 Nothing ->
288 throwE $ ErrorVerifyEncryption_InvalidProofLength
289 (fromIntegral $ List.length proofs)
290 (fromIntegral $ List.length disjs)
291 Just commitments ->
292 return $ challengeSum ==
293 hash (encryptionStatement voterZKP enc) (join commitments)
294 where
295 challengeSum = sum (proof_challenge <$> proofs)
296
297 -- ** Hashing
298 encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString
299 encryptionStatement (ZKP voterZKP) Encryption{..} =
300 "prove|"<>voterZKP<>"|"
301 <> bytesNat encryption_nonce<>","
302 <> bytesNat encryption_vault<>"|"
303
304 -- | @('encryptionCommitments' elecPubKey enc disj proof)@
305 -- returns the 'Commitment's with only the knowledge of the verifier.
306 --
307 -- For the prover the 'Proof' comes from @fakeProof@,
308 -- and for the verifier the 'Proof' comes from the prover.
309 encryptionCommitments ::
310 SubGroup q =>
311 PublicKey q -> Encryption q ->
312 Disjunction q -> Proof q -> [G q]
313 encryptionCommitments elecPubKey Encryption{..} disj proof =
314 [ commit proof groupGen encryption_nonce
315 -- == groupGen ^ nonce if 'Proof' comes from 'prove'.
316 -- base==groupGen, basePowSec==groupGen^encNonce.
317 , commit proof elecPubKey (encryption_vault*disj)
318 -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'
319 -- and 'encryption_vault' encrypts (- logBase groupGen disj).
320 -- base==elecPubKey, basePowSec==elecPubKey^encNonce.
321 ]
322
323 -- ** Type 'ErrorVerifyEncryption'
324 -- | Error raised by 'verifyEncryption'.
325 data ErrorVerifyEncryption
326 = ErrorVerifyEncryption_InvalidProofLength Natural Natural
327 -- ^ When the number of proofs is different than
328 -- the number of 'Disjunction's.
329 deriving (Eq,Show)
330
331 -- * Type 'Question'
332 data Question q = Question
333 { question_text :: Text
334 , question_choices :: [Text]
335 , question_mini :: Opinion q
336 , question_maxi :: Opinion q
337 -- , question_blank :: Maybe Bool
338 } deriving (Eq,Show,Generic,NFData)
339
340 -- * Type 'Answer'
341 data Answer q = Answer
342 { answer_opinions :: [(Encryption q, DisjProof q)]
343 -- ^ Encrypted 'Opinion' for each 'question_choices'
344 -- with a 'DisjProof' that they belong to [0,1].
345 , answer_sumProof :: DisjProof q
346 -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
347 -- is an element of @[mini..maxi]@.
348 -- , answer_blankProof ::
349 } deriving (Eq,Show,Generic,NFData)
350
351 -- | @('encryptAnswer' elecPubKey zkp quest opinions)@
352 -- returns an 'Answer' validable by 'verifyAnswer',
353 -- unless an 'ErrorAnswer' is returned.
354 encryptAnswer ::
355 Monad m => RandomGen r => SubGroup q =>
356 PublicKey q -> ZKP ->
357 Question q -> [Bool] ->
358 S.StateT r (ExceptT ErrorAnswer m) (Answer q)
359 encryptAnswer elecPubKey zkp Question{..} opinionByChoice
360 | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
361 lift $ throwE $
362 ErrorAnswer_WrongSumOfOpinions
363 (nat opinionsSum)
364 (nat question_mini)
365 (nat question_maxi)
366 | List.length opinions /= List.length question_choices =
367 lift $ throwE $
368 ErrorAnswer_WrongNumberOfOpinions
369 (fromIntegral $ List.length opinions)
370 (fromIntegral $ List.length question_choices)
371 | otherwise = do
372 encryptions <- encrypt elecPubKey `mapM` opinions
373 individualProofs <- zipWithM
374 (\opinion -> proveEncryption elecPubKey zkp $
375 if opinion
376 then ([booleanDisjunctions List.!!0],[])
377 else ([],[booleanDisjunctions List.!!1]))
378 opinionByChoice encryptions
379 sumProof <- proveEncryption elecPubKey zkp
380 (List.tail <$> List.genericSplitAt
381 (nat (opinionsSum - question_mini))
382 (intervalDisjunctions question_mini question_maxi))
383 ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's
384 , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's
385 )
386 return $ Answer
387 { answer_opinions = List.zip
388 (snd <$> encryptions) -- NOTE: drop encNonce
389 individualProofs
390 , answer_sumProof = sumProof
391 }
392 where
393 opinionsSum = sum opinions
394 opinions = (\o -> if o then one else zero) <$> opinionByChoice
395
396 verifyAnswer ::
397 SubGroup q =>
398 PublicKey q -> ZKP ->
399 Question q -> Answer q -> Bool
400 verifyAnswer elecPubKey zkp Question{..} Answer{..}
401 | List.length question_choices /= List.length answer_opinions = False
402 | otherwise = either (const False) id $ runExcept $ do
403 validOpinions <-
404 verifyEncryption elecPubKey zkp booleanDisjunctions
405 `traverse` answer_opinions
406 validSum <- verifyEncryption elecPubKey zkp
407 (intervalDisjunctions question_mini question_maxi)
408 ( sum (fst <$> answer_opinions)
409 , answer_sumProof )
410 return (and validOpinions && validSum)
411
412 -- ** Type 'ErrorAnswer'
413 -- | Error raised by 'encryptAnswer'.
414 data ErrorAnswer
415 = ErrorAnswer_WrongNumberOfOpinions Natural Natural
416 -- ^ When the number of opinions is different than
417 -- the number of choices ('question_choices').
418 | ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
419 -- ^ When the sum of opinions is not within the bounds
420 -- of 'question_mini' and 'question_maxi'.
421 deriving (Eq,Show,Generic,NFData)
422
423 -- * Type 'Election'
424 data Election q = Election
425 { election_name :: Text
426 , election_description :: Text
427 , election_publicKey :: PublicKey q
428 , election_questions :: [Question q]
429 , election_uuid :: UUID
430 , election_hash :: Hash -- TODO: serialize to JSON to calculate this
431 } deriving (Eq,Show,Generic,NFData)
432
433 -- ** Type 'Hash'
434 newtype Hash = Hash Text
435 deriving (Eq,Ord,Show,Generic,NFData)
436
437 -- * Type 'Ballot'
438 data Ballot q = Ballot
439 { ballot_answers :: [Answer q]
440 , ballot_signature :: Maybe (Signature q)
441 , ballot_election_uuid :: UUID
442 , ballot_election_hash :: Hash
443 } deriving (Generic,NFData)
444
445 -- | @('encryptBallot' elec ('Just' ballotSecKey) opinionsByQuest)@
446 -- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
447 -- where 'opinionsByQuest' is a list of 'Opinion's
448 -- on each 'question_choices' of each 'election_questions'.
449 encryptBallot ::
450 Monad m => RandomGen r => SubGroup q =>
451 Election q -> Maybe (SecretKey q) -> [[Bool]] ->
452 S.StateT r (ExceptT ErrorBallot m) (Ballot q)
453 encryptBallot Election{..} ballotSecKeyMay opinionsByQuest
454 | List.length election_questions /= List.length opinionsByQuest =
455 lift $ throwE $
456 ErrorBallot_WrongNumberOfAnswers
457 (fromIntegral $ List.length opinionsByQuest)
458 (fromIntegral $ List.length election_questions)
459 | otherwise = do
460 let (voterKeys, voterZKP) =
461 case ballotSecKeyMay of
462 Nothing -> (Nothing, ZKP "")
463 Just ballotSecKey ->
464 ( Just (ballotSecKey, ballotPubKey)
465 , ZKP (bytesNat ballotPubKey) )
466 where ballotPubKey = publicKey ballotSecKey
467 ballot_answers <-
468 S.mapStateT (withExceptT ErrorBallot_Answer) $
469 zipWithM (encryptAnswer election_publicKey voterZKP)
470 election_questions opinionsByQuest
471 ballot_signature <- case voterKeys of
472 Nothing -> return Nothing
473 Just (ballotSecKey, signature_publicKey) -> do
474 signature_proof <-
475 prove ballotSecKey (Identity groupGen) $
476 \(Identity commitment) ->
477 hash
478 -- NOTE: the order is unusual, the commitments are first
479 -- then comes the statement. Best guess is that
480 -- this is easier to code due to their respective types.
481 (signatureCommitments voterZKP commitment)
482 (signatureStatement ballot_answers)
483 return $ Just Signature{..}
484 return Ballot
485 { ballot_answers
486 , ballot_election_hash = election_hash
487 , ballot_election_uuid = election_uuid
488 , ballot_signature
489 }
490
491 verifyBallot :: SubGroup q => Election q -> Ballot q -> Bool
492 verifyBallot Election{..} Ballot{..} =
493 ballot_election_uuid == election_uuid &&
494 ballot_election_hash == election_hash &&
495 List.length election_questions == List.length ballot_answers &&
496 let (isValidSign, zkpSign) =
497 case ballot_signature of
498 Nothing -> (True, ZKP "")
499 Just Signature{..} ->
500 let zkp = ZKP (bytesNat signature_publicKey) in
501 (, zkp) $
502 proof_challenge signature_proof == hash
503 (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey))
504 (signatureStatement ballot_answers)
505 in
506 and $ isValidSign :
507 List.zipWith (verifyAnswer election_publicKey zkpSign)
508 election_questions ballot_answers
509
510 -- ** Type 'Signature'
511 -- | Schnorr-like signature.
512 --
513 -- Used by each voter to sign his/her encrypted 'Ballot'
514 -- using his/her 'Credential',
515 -- in order to avoid ballot stuffing.
516 data Signature q = Signature
517 { signature_publicKey :: PublicKey q
518 -- ^ Verification key.
519 , signature_proof :: Proof q
520 } deriving (Generic,NFData)
521
522 -- *** Hashing
523
524 -- | @('signatureStatement' answers)@
525 -- returns the encrypted material to be signed:
526 -- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@.
527 signatureStatement :: Foldable f => SubGroup q => f (Answer q) -> [G q]
528 signatureStatement =
529 foldMap $ \Answer{..} ->
530 (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
531 [encryption_nonce, encryption_vault]
532
533 -- | @('signatureCommitments' voterZKP commitment)@
534 signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString
535 signatureCommitments (ZKP voterZKP) commitment =
536 "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
537 <> bytesNat commitment<>"|"
538
539 -- ** Type 'ErrorBallot'
540 -- | Error raised by 'encryptBallot'.
541 data ErrorBallot
542 = ErrorBallot_WrongNumberOfAnswers Natural Natural
543 -- ^ When the number of answers
544 -- is different than the number of questions.
545 | ErrorBallot_Answer ErrorAnswer
546 -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
547 deriving (Eq,Show,Generic,NFData)
548
549 -- * Type 'DecryptionShare'
550 -- | A decryption share. It is computed by a trustee from his/her
551 -- private key share and the encrypted tally,
552 -- and contains a cryptographic 'Proof' that it didn't cheat.
553 data DecryptionShare q = DecryptionShare
554 { decryptionShare_factors :: [[DecryptionFactor q]]
555 -- ^ 'DecryptionFactor' by voter, by 'Question'.
556 , decryptionShare_proofs :: [[Proof q]]
557 -- ^ 'Proof's that 'decryptionShare_factors' were correctly computed.
558 } deriving (Eq,Show,Generic,NFData)
559
560 -- BELENIOS: compute_factor
561 -- @('proveDecryptionShare' trusteeSecKey encByQuestByBallot)@
562 proveDecryptionShare ::
563 Monad m => SubGroup q => RandomGen r =>
564 SecretKey q -> [[Encryption q]] -> S.StateT r m (DecryptionShare q)
565 proveDecryptionShare secKey encs = do
566 res <- (proveDecryptionFactor secKey `mapM`) `mapM` encs
567 return $ uncurry DecryptionShare $ List.unzip (List.unzip <$> res)
568
569 -- BELENIOS: eg_factor
570 proveDecryptionFactor ::
571 Monad m => SubGroup q => RandomGen r =>
572 SecretKey q -> Encryption q -> S.StateT r m (DecryptionFactor q, Proof q)
573 proveDecryptionFactor secKey Encryption{..} = do
574 proof <- prove secKey [groupGen, encryption_nonce] (hash zkp)
575 return (encryption_nonce^secKey, proof)
576 where zkp = decryptionShareStatement (publicKey secKey)
577
578 decryptionShareStatement :: SubGroup q => PublicKey q -> BS.ByteString
579 decryptionShareStatement pubKey =
580 "decrypt|"<>bytesNat pubKey<>"|"
581
582 -- ** Type 'DecryptionFactor'
583 type DecryptionFactor = G
584
585 -- ** Type 'ErrorDecryptionShare'
586 data ErrorDecryptionShare
587 = ErrorDecryptionShare_Invalid
588 -- ^ The number of 'DecryptionFactor's or
589 -- the number of 'Proof's is not the same
590 -- or not the expected number.
591 | ErrorDecryptionShare_Wrong
592 -- ^ The 'Proof' of a 'DecryptionFactor' is wrong.
593 deriving (Eq,Show,Generic,NFData)
594
595 -- BELENIOS: check_factor
596 -- | @('verifyDecryptionShare' encByQuestByBallot pubKey decShare)@
597 -- checks that 'decShare'
598 -- (supposedly submitted by a trustee whose public key is 'pubKey')
599 -- is valid with respect to the encrypted tally 'encByQuestByBallot'.
600 verifyDecryptionShare ::
601 Monad m => SubGroup q =>
602 [[Encryption q]] ->
603 PublicKey q -> DecryptionShare q -> ExceptT ErrorDecryptionShare m ()
604 verifyDecryptionShare encByQuestByBallot pubKey DecryptionShare{..} =
605 let zkp = decryptionShareStatement pubKey in
606 isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)
607 (isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid) $
608 \Encryption{..} decFactor proof ->
609 unless (proof_challenge proof == hash zkp
610 [ commit proof groupGen pubKey
611 , commit proof encryption_nonce decFactor
612 ]) $
613 throwE ErrorDecryptionShare_Wrong)
614 encByQuestByBallot
615 decryptionShare_factors
616 decryptionShare_proofs
617
618 -- * Type 'Tally'
619 data Tally q = Tally
620 { tally_numBallots :: Natural
621 , tally_encByQuestByBallot :: [[Encryption q]]
622 -- ^ 'Encryption' by 'Question' by 'Ballot'.
623 , tally_decShareByTrustee :: [DecryptionShare q]
624 -- ^ 'DecryptionShare' by trustee.
625 , tally_countByQuestByBallot :: [[Natural]]
626 } deriving (Eq,Show,Generic,NFData)
627
628 -- ** Type 'DecryptionShareCombinator'
629 type DecryptionShareCombinator q =
630 [DecryptionShare q] -> Except ErrorDecryptionShare [[DecryptionFactor q]]
631
632 -- BELENIOS: compute_result
633 proveTally ::
634 Monad m => SubGroup q =>
635 [[Encryption q]] -> [DecryptionShare q] ->
636 DecryptionShareCombinator q ->
637 Except ErrorDecryptionShare (Tally q)
638 proveTally tally_encByQuestByBallot tally_decShareByTrustee decShareCombinator = do
639 decFactorByQuestByBallot <- decShareCombinator tally_decShareByTrustee
640 dec <- isoZipWithM err
641 (\encByQuest decFactorByQuest ->
642 maybe err return $
643 isoZipWith (\Encryption{..} decFactor -> encryption_vault / decFactor)
644 encByQuest
645 decFactorByQuest
646 )
647 tally_encByQuestByBallot
648 decFactorByQuestByBallot
649 let tally_numBallots = fromIntegral $ List.length tally_encByQuestByBallot
650 let logMap = Map.fromDistinctAscList $ List.zip groupGenPowers [0..tally_numBallots]
651 let log x = maybe err return $ Map.lookup x logMap
652 tally_countByQuestByBallot <- (log `mapM`)`mapM`dec
653 return Tally{..}
654 where err = throwE ErrorDecryptionShare_Invalid
655
656 verifyTally ::
657 Monad m => SubGroup q =>
658 DecryptionShareCombinator q -> Tally q ->
659 Except ErrorDecryptionShare ()
660 verifyTally decShareCombinator Tally{..} = do
661 decFactorByQuestByBallot <- decShareCombinator tally_decShareByTrustee
662 isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)
663 (isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)
664 (\Encryption{..} decFactor count -> do
665 let dec = encryption_vault / decFactor
666 unless (dec == groupGen ^ fromNatural count) $
667 throwE ErrorDecryptionShare_Wrong
668 )
669 )
670 tally_encByQuestByBallot
671 decFactorByQuestByBallot
672 tally_countByQuestByBallot