1 {-# LANGUAGE DeriveAnyClass #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE DerivingStrategies #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 module Voting.Protocol.Election where
7 import Control.DeepSeq (NFData)
8 import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM)
9 import Control.Monad.Trans.Class (MonadTrans(..))
10 import Control.Monad.Trans.Except (ExceptT, runExcept, throwE, withExceptT)
12 import Data.Either (either)
13 import Data.Eq (Eq(..))
14 import Data.Foldable (Foldable, foldMap, and)
15 import Data.Function (($), id, const)
16 import Data.Functor (Functor, (<$>))
17 import Data.Functor.Identity (Identity(..))
18 import Data.Maybe (Maybe(..), fromMaybe)
19 import Data.Ord (Ord(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.Text (Text)
22 import Data.Traversable (Traversable(..))
23 import Data.Tuple (fst, snd)
24 import GHC.Natural (minusNaturalMaybe)
25 import GHC.Generics (Generic)
26 import Numeric.Natural (Natural)
27 import Prelude (fromIntegral)
28 import Text.Show (Show(..))
29 import qualified Control.Monad.Trans.State.Strict as S
30 import qualified Data.ByteString as BS
31 import qualified Data.List as List
33 import Voting.Protocol.Utils
34 import Voting.Protocol.Arithmetic
35 import Voting.Protocol.Credential
37 -- * Type 'Encryption'
38 -- | ElGamal-like encryption.
39 -- Its security relies on the /Discrete Logarithm problem/.
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.
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)
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
63 (encryption_nonce x * encryption_nonce y)
64 (encryption_vault x * encryption_vault y)
66 -- *** Type 'EncryptionNonce'
67 type EncryptionNonce = E
69 -- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.
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'.
78 Monad m => RandomGen r => SubGroup q =>
80 S.StateT r m (EncryptionNonce q, Encryption q)
81 encrypt pubKey clear = do
83 -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.
86 { encryption_nonce = groupGen^encNonce
87 , encryption_vault = pubKey ^encNonce * groupGen^clear
91 -- | Non-Interactive Zero-Knowledge 'Proof'
92 -- of knowledge of a discrete logarithm:
93 -- @(secret == logBase base (base^secret))@.
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'.
107 -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:
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@,
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'.
121 -- The prover choses 'commitment' to be a random power of @base@,
122 -- to ensure that each 'prove' does not reveal any information
124 } deriving (Eq,Show,Generic,NFData)
127 -- | Zero-knowledge proof.
129 -- A protocol is /zero-knowledge/ if the verifier
130 -- learns nothing from the protocol except that the prover
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
137 -- ** Type 'Challenge'
141 -- An 'Oracle' returns the 'Challenge' of the 'Commitment's
142 -- by 'hash'ing them (eventually with other 'Commitment's).
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
154 -- | @('prove' sec commitBases oracle)@
155 -- returns a 'Proof' that @sec@ is known
156 -- (by proving the knowledge of its discrete logarithm).
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
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).
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).
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
176 let commitments = (^ nonce) <$> commitBases
177 let proof_challenge = oracle commitments
180 , proof_response = nonce - sec*proof_challenge
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'.
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)
193 proof_challenge <- random
194 proof_response <- random
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'.
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 #-}
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)@,
221 booleanDisjunctions :: SubGroup q => [Disjunction q]
222 booleanDisjunctions = List.take 2 groupGenInverses
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) $
231 -- | Index of a 'Disjunction' within a list of them.
232 -- It is encrypted as an 'E'xponent by 'encrypt'.
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)
241 deriving newtype NFData
243 -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@
244 -- returns a 'DisjProof' that 'enc' 'encrypt's
245 -- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.
247 -- The prover proves that it knows an 'encNonce', such that:
248 -- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@
250 -- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.
252 -- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.
254 Monad m => RandomGen r => SubGroup q =>
255 PublicKey q -> ZKP ->
256 ([Disjunction q],[Disjunction q]) ->
257 (EncryptionNonce q, Encryption q) ->
258 S.StateT r m (DisjProof q)
259 proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do
260 -- Fake proofs for all 'Disjunction's except the genuine one.
261 prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof
262 nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof
263 let fakeChallengeSum =
264 sum (proof_challenge <$> prevFakeProofs) +
265 sum (proof_challenge <$> nextFakeProofs)
266 let statement = encryptionStatement voterZKP enc
267 genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->
268 let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in
269 let prevCommitments = validCommitments prevDisjs prevFakeProofs in
270 let nextCommitments = validCommitments nextDisjs nextFakeProofs in
271 let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in
272 let challenge = hash statement commitments in
273 let genuineChallenge = challenge - fakeChallengeSum in
275 -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)
276 -- thus (sum (proof_challenge <$> proofs) == challenge)
277 -- as checked in 'verifyEncryption'.
278 let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
279 return (DisjProof proofs)
282 Monad m => SubGroup q =>
283 PublicKey q -> ZKP ->
284 [Disjunction q] -> (Encryption q, DisjProof q) ->
285 ExceptT ErrorVerifyEncryption m Bool
286 verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =
287 case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of
289 throwE $ ErrorVerifyEncryption_InvalidProofLength
290 (fromIntegral $ List.length proofs)
291 (fromIntegral $ List.length disjs)
293 return $ challengeSum ==
294 hash (encryptionStatement voterZKP enc) (join commitments)
296 challengeSum = sum (proof_challenge <$> proofs)
299 encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString
300 encryptionStatement (ZKP voterZKP) Encryption{..} =
301 "prove|"<>voterZKP<>"|"
302 <> bytesNat encryption_nonce<>","
303 <> bytesNat encryption_vault<>"|"
305 -- | @('encryptionCommitments' elecPubKey enc disj proof)@
306 -- returns the 'Commitment's with only the knowledge of the verifier.
308 -- For the prover the 'Proof' comes from @fakeProof@,
309 -- and for the verifier the 'Proof' comes from the prover.
310 encryptionCommitments ::
312 PublicKey q -> Encryption q ->
313 Disjunction q -> Proof q -> [G q]
314 encryptionCommitments elecPubKey Encryption{..} disj proof =
315 [ commit proof groupGen encryption_nonce
316 -- == groupGen ^ nonce if 'Proof' comes from 'prove'.
317 -- base==groupGen, basePowSec==groupGen^encNonce.
318 , commit proof elecPubKey (encryption_vault*disj)
319 -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'
320 -- and 'encryption_vault' encrypts (- logBase groupGen disj).
321 -- base==elecPubKey, basePowSec==elecPubKey^encNonce.
324 -- ** Type 'ErrorVerifyEncryption'
325 -- | Error raised by 'verifyEncryption'.
326 data ErrorVerifyEncryption
327 = ErrorVerifyEncryption_InvalidProofLength Natural Natural
328 -- ^ When the number of proofs is different than
329 -- the number of 'Disjunction's.
333 data Question q = Question
334 { question_text :: Text
335 , question_choices :: [Text]
336 , question_mini :: Opinion q
337 , question_maxi :: Opinion q
338 -- , question_blank :: Maybe Bool
339 } deriving (Eq,Show,Generic,NFData)
342 data Answer q = Answer
343 { answer_opinions :: [(Encryption q, DisjProof q)]
344 -- ^ Encrypted 'Opinion' for each 'question_choices'
345 -- with a 'DisjProof' that they belong to [0,1].
346 , answer_sumProof :: DisjProof q
347 -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
348 -- is an element of @[mini..maxi]@.
349 -- , answer_blankProof ::
350 } deriving (Eq,Show,Generic,NFData)
352 -- | @('encryptAnswer' elecPubKey zkp quest opinions)@
353 -- returns an 'Answer' validable by 'verifyAnswer',
354 -- unless an 'ErrorAnswer' is returned.
356 Monad m => RandomGen r => SubGroup q =>
357 PublicKey q -> ZKP ->
358 Question q -> [Bool] ->
359 S.StateT r (ExceptT ErrorAnswer m) (Answer q)
360 encryptAnswer elecPubKey zkp Question{..} opinionByChoice
361 | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
363 ErrorAnswer_WrongSumOfOpinions
367 | List.length opinions /= List.length question_choices =
369 ErrorAnswer_WrongNumberOfOpinions
370 (fromIntegral $ List.length opinions)
371 (fromIntegral $ List.length question_choices)
373 encryptions <- encrypt elecPubKey `mapM` opinions
374 individualProofs <- zipWithM
375 (\opinion -> proveEncryption elecPubKey zkp $
377 then ([booleanDisjunctions List.!!0],[])
378 else ([],[booleanDisjunctions List.!!1]))
379 opinionByChoice encryptions
380 sumProof <- proveEncryption elecPubKey zkp
381 (List.tail <$> List.genericSplitAt
382 (nat (opinionsSum - question_mini))
383 (intervalDisjunctions question_mini question_maxi))
384 ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's
385 , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's
388 { answer_opinions = List.zip
389 (snd <$> encryptions) -- NOTE: drop encNonce
391 , answer_sumProof = sumProof
394 opinionsSum = sum opinions
395 opinions = (\o -> if o then one else zero) <$> opinionByChoice
399 PublicKey q -> ZKP ->
400 Question q -> Answer q -> Bool
401 verifyAnswer elecPubKey zkp Question{..} Answer{..}
402 | List.length question_choices /= List.length answer_opinions = False
403 | otherwise = either (const False) id $ runExcept $ do
405 verifyEncryption elecPubKey zkp booleanDisjunctions
406 `traverse` answer_opinions
407 validSum <- verifyEncryption elecPubKey zkp
408 (intervalDisjunctions question_mini question_maxi)
409 ( sum (fst <$> answer_opinions)
411 return (and validOpinions && validSum)
413 -- ** Type 'ErrorAnswer'
414 -- | Error raised by 'encryptAnswer'.
416 = ErrorAnswer_WrongNumberOfOpinions Natural Natural
417 -- ^ When the number of opinions is different than
418 -- the number of choices ('question_choices').
419 | ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
420 -- ^ When the sum of opinions is not within the bounds
421 -- of 'question_mini' and 'question_maxi'.
422 deriving (Eq,Show,Generic,NFData)
425 data Election q = Election
426 { election_name :: Text
427 , election_description :: Text
428 , election_PublicKey :: PublicKey q
429 , election_questions :: [Question q]
430 , election_uuid :: UUID
431 , election_hash :: Hash -- TODO: serialize to JSON to calculate this
432 } deriving (Eq,Show,Generic,NFData)
435 newtype Hash = Hash Text
436 deriving (Eq,Ord,Show,Generic)
437 deriving newtype NFData
440 data Ballot q = Ballot
441 { ballot_answers :: [Answer q]
442 , ballot_signature :: Maybe (Signature q)
443 , ballot_election_uuid :: UUID
444 , ballot_election_hash :: Hash
445 } deriving (Generic,NFData)
447 -- | @('encryptBallot' elec ('Just' ballotSecKey) opinionsByQuest)@
448 -- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
449 -- where 'opinionsByQuest' is a list of 'Opinion's
450 -- on each 'question_choices' of each 'election_questions'.
452 Monad m => RandomGen r => SubGroup q =>
453 Election q -> Maybe (SecretKey q) -> [[Bool]] ->
454 S.StateT r (ExceptT ErrorBallot m) (Ballot q)
455 encryptBallot Election{..} ballotSecKeyMay opinionsByQuest
456 | List.length election_questions /= List.length opinionsByQuest =
458 ErrorBallot_WrongNumberOfAnswers
459 (fromIntegral $ List.length opinionsByQuest)
460 (fromIntegral $ List.length election_questions)
462 let (voterKeys, voterZKP) =
463 case ballotSecKeyMay of
464 Nothing -> (Nothing, ZKP "")
466 ( Just (ballotSecKey, ballotPubKey)
467 , ZKP (bytesNat ballotPubKey) )
468 where ballotPubKey = publicKey ballotSecKey
470 S.mapStateT (withExceptT ErrorBallot_Answer) $
471 zipWithM (encryptAnswer election_PublicKey voterZKP)
472 election_questions opinionsByQuest
473 ballot_signature <- case voterKeys of
474 Nothing -> return Nothing
475 Just (ballotSecKey, signature_publicKey) -> do
477 prove ballotSecKey (Identity groupGen) $
478 \(Identity commitment) ->
480 -- NOTE: the order is unusual, the commitments are first
481 -- then comes the statement. Best guess is that
482 -- this is easier to code due to their respective types.
483 (signatureCommitments voterZKP commitment)
484 (signatureStatement ballot_answers)
485 return $ Just Signature{..}
488 , ballot_election_hash = election_hash
489 , ballot_election_uuid = election_uuid
493 verifyBallot :: SubGroup q => Election q -> Ballot q -> Bool
494 verifyBallot Election{..} Ballot{..} =
495 ballot_election_uuid == election_uuid &&
496 ballot_election_hash == election_hash &&
497 List.length election_questions == List.length ballot_answers &&
498 let (isValidSign, zkpSign) =
499 case ballot_signature of
500 Nothing -> (True, ZKP "")
501 Just Signature{..} ->
502 let zkp = ZKP (bytesNat signature_publicKey) in
504 proof_challenge signature_proof == hash
505 (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey))
506 (signatureStatement ballot_answers)
509 List.zipWith (verifyAnswer election_PublicKey zkpSign)
510 election_questions ballot_answers
512 -- ** Type 'Signature'
513 -- | Schnorr-like signature.
515 -- Used by each voter to sign his/her encrypted 'Ballot'
516 -- using his/her 'Credential',
517 -- in order to avoid ballot stuffing.
518 data Signature q = Signature
519 { signature_publicKey :: PublicKey q
520 -- ^ Verification key.
521 , signature_proof :: Proof q
522 } deriving (Generic,NFData)
526 -- | @('signatureStatement' answers)@
527 -- returns the encrypted material to be signed:
528 -- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@.
529 signatureStatement :: Foldable f => SubGroup q => f (Answer q) -> [G q]
531 foldMap $ \Answer{..} ->
532 (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
533 [encryption_nonce, encryption_vault]
535 -- | @('signatureCommitments' voterZKP commitment)@
536 signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString
537 signatureCommitments (ZKP voterZKP) commitment =
538 "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
539 <> bytesNat commitment<>"|"
541 -- ** Type 'ErrorBallot'
542 -- | Error raised by 'encryptBallot'.
544 = ErrorBallot_WrongNumberOfAnswers Natural Natural
545 -- ^ When the number of answers
546 -- is different than the number of questions.
547 | ErrorBallot_Answer ErrorAnswer
548 -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
550 -- ^ TODO: to be more precise.
551 deriving (Eq,Show,Generic,NFData)