]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/Protocol/Election.hs
protocol: polish randomUUID
[majurity.git] / hjugement-protocol / Protocol / Election.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Protocol.Election where
5
6 import Control.Monad (Monad(..), mapM, zipWithM)
7 import Control.Monad.Morph (MFunctor(..))
8 import Control.Monad.Trans.Class (MonadTrans(..))
9 import Data.Bool
10 import Data.Either (either)
11 import Data.Eq (Eq(..))
12 import Data.Foldable (Foldable, foldMap, and)
13 import Data.Function (($), id, const)
14 import Data.Functor (Functor, (<$>))
15 import Data.Functor.Identity (Identity(..))
16 import Data.Maybe (Maybe(..), fromMaybe)
17 import Data.Ord (Ord(..))
18 import Data.Semigroup (Semigroup(..))
19 import Data.String (IsString(..))
20 import Data.Text (Text)
21 import Data.Traversable (Traversable(..))
22 import Data.Tuple (fst, snd)
23 import GHC.Natural (minusNaturalMaybe)
24 import Numeric.Natural (Natural)
25 import Prelude (error, fromIntegral)
26 import Text.Show (Show(..))
27 import qualified Control.Monad.Trans.Except as Exn
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
32 import Protocol.Arithmetic
33 import Protocol.Credential
34
35 -- * Type 'Encryption'
36 -- | ElGamal-like encryption.
37 -- Its security relies on the /Discrete Logarithm problem/.
38 --
39 -- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),
40 -- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@
41 -- to decipher @('groupGen' '^'clear)@, then @clear@ must be small to be decryptable,
42 -- because it is encrypted as a power of 'groupGen' to enable the additive homomorphism.
43 data Encryption q = Encryption
44 { encryption_nonce :: G q
45 -- ^ Public part of the random 'encNonce': @('groupGen' '^'encNonce)@
46 , encryption_vault :: G q
47 -- ^ Encrypted clear: @('pubKey' '^'r '*' 'groupGen' '^'clear)@
48 } deriving (Eq,Show)
49
50 -- | Additive homomorphism.
51 -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
52 instance SubGroup q => Additive (Encryption q) where
53 zero = Encryption one one
54 x+y = Encryption
55 (encryption_nonce x * encryption_nonce y)
56 (encryption_vault x * encryption_vault y)
57
58 -- *** Type 'EncryptionNonce'
59 type EncryptionNonce = E
60
61 -- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.
62 --
63 -- WARNING: the secret encryption nonce (@encNonce@)
64 -- is returned alongside the 'Encryption'
65 -- in order to prove the validity of the encrypted clear in 'prove',
66 -- but this secret @encNonce@ MUST be forgotten after that,
67 -- as it may be used to decipher the 'Encryption'
68 -- without the secret key associated with 'pubKey'.
69 encrypt ::
70 Monad m => RandomGen r => SubGroup q =>
71 PublicKey q -> E q ->
72 S.StateT r m (EncryptionNonce q, Encryption q)
73 encrypt pubKey clear = do
74 encNonce <- random
75 -- NOTE: preserve the 'encNonce' for 'prove'.
76 return $ (encNonce,)
77 Encryption
78 { encryption_nonce = groupGen^encNonce
79 , encryption_vault = pubKey ^encNonce * groupGen^clear
80 }
81
82 -- * Type 'Proof'
83 -- | 'Proof' of knowledge of a discrete logarithm:
84 -- @secret == logBase base (base^secret)@.
85 --
86 -- NOTE: Since @(pubKey == 'groupGen' '^'secKey)@, then:
87 -- @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.
88 data Proof q = Proof
89 { proof_challenge :: Challenge q
90 -- ^ 'Challenge' sent by the verifier to the prover
91 -- to ensure that the prover really has knowledge
92 -- of the secret and is not replaying.
93 -- Actually, 'proof_challenge' is not sent in a 'prove',
94 -- but derived from the prover's 'Commitment's and statements
95 -- with a collision resistant hash.
96 , proof_response :: E q
97 -- ^ Response sent by the prover to the verifier.
98 -- Usually: @nonce '+' sec '*' 'proof_challenge'@.
99 --
100 -- To be computed efficiently, it requires @sec@:
101 -- either the @secKey@ (in 'signature_proof')
102 -- or the @encNonce@ (in 'prove').
103 } deriving (Eq,Show)
104
105 -- ** Type 'Challenge'
106 type Challenge = E
107
108 -- ** Type 'Oracle'
109 -- An 'Oracle' returns the 'Challenge' of the 'Commitment's
110 -- by hashing them (eventually with other 'Commitment's).
111 --
112 -- Used in 'prove' it enables a Fiat-Shamir transformation
113 -- of an /interactive zero-knowledge/ (IZK) proof
114 -- into a /non-interactive zero-knowledge/ (NIZK) proof.
115 -- That is to say that the verifier does not have
116 -- to send a 'Challenge' to the prover.
117 -- Indeed, the prover now handles the 'Challenge'
118 -- which becomes a (collision resistant) hash
119 -- of the prover's commitments (and statements to be a stronger proof).
120 type Oracle list q = list (Commitment q) -> Challenge q
121
122 -- | @('prove' sec commitments oracle)@
123 -- returns a 'Proof' that @sec@ is known.
124 --
125 -- The 'Oracle' is given the 'commitments'
126 -- raised to the power of the secret nonce of the 'Proof',
127 -- as those are the 'commitments' that the verifier will obtain
128 -- when composing the 'proof_challenge' and 'proof_response' together
129 -- (in 'encryptionCommitments').
130 --
131 -- NOTE: 'sec' is @secKey@ in 'signature_proof' or @encNonce@ in 'proveEncryption'.
132 --
133 -- NOTE: The 'commitments' are @['groupGen']@ in 'signature_proof',
134 -- @['groupGen', 'pubKey']@ in 'proveEncryption',
135 -- and @['groupGen', 'encryption_nonce']@ in 'decryptionFactor'.
136 --
137 -- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):
138 -- the statement must be included in the hash (not only the commitments).
139 --
140 -- NOTE: a 'random' @nonce@ is used to ensure each 'prove'
141 -- does not reveal any information regarding the secret 'sec'.
142 prove ::
143 Monad m => RandomGen r => SubGroup q => Functor list =>
144 E q -> list (Commitment q) -> Oracle list q -> S.StateT r m (Proof q)
145 prove sec commitments oracle = do
146 nonce <- random
147 let proof_challenge = oracle $ (^ nonce) <$> commitments
148 return Proof
149 { proof_challenge
150 , proof_response = nonce - sec*proof_challenge
151 }
152
153 -- ** Type 'Commitment'
154 type Commitment = G
155
156 -- | @('commit' proof x y)@ returns a 'Commitment'
157 -- from the given 'Proof' with the knowledge of the verifier.
158 --
159 -- NOTE: Contrary to Helios-C specifications,
160 -- @('*')@ is used instead of @('/')@
161 -- to avoid the performance cost of a modular exponentiation
162 -- @('^' ('groupOrder' '-' 'one'))@,
163 -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'.
164 commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q
165 commit Proof{..} x y = x^proof_response * y^proof_challenge
166 {-# INLINE commit #-}
167
168 -- ** Type 'Opinion'
169 -- | Index of a 'Disjunction' within a list of them.
170 -- It is encrypted as an 'E'xponent by 'encrypt'.
171 type Opinion = E
172
173 -- ** Type 'Disjunction'
174 -- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@
175 -- it's used in 'proveEncryption' to generate a 'Proof'
176 -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,
177 type Disjunction = G
178
179 booleanDisjunctions :: SubGroup q => [Disjunction q]
180 booleanDisjunctions = List.take 2 groupGenInverses
181
182 intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q]
183 intervalDisjunctions mini maxi =
184 List.genericTake (fromMaybe 0 $ (natE maxi + 1)`minusNaturalMaybe`natE mini) $
185 List.genericDrop (natE mini) $
186 groupGenInverses
187
188 -- ** Type 'DisjProof'
189 -- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption'
190 -- is indexing a 'Disjunction' within a list of them,
191 -- without knowing which 'Opinion' it is.
192 newtype DisjProof q = DisjProof [Proof q]
193 deriving (Eq,Show)
194
195 -- | @('proveEncryption' pubKey zkp disjs opin (encNonce, enc))@
196 -- returns a 'DisjProof' that 'enc' 'encrypt's
197 -- one of the 'Disjunction's within 'disjs',
198 -- without revealing which one it is.
199 --
200 -- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.
201 proveEncryption ::
202 forall m r q.
203 Monad m => RandomGen r => SubGroup q =>
204 PublicKey q -> ZKP ->
205 [Disjunction q] -> Opinion q ->
206 (EncryptionNonce q, Encryption q) ->
207 S.StateT r (Exn.ExceptT ErrorProove m) (DisjProof q)
208 proveEncryption pubKey zkp disjs opinion (encNonce, enc)
209 | (prevDisjs, _indexedDisj:nextDisjs) <-
210 List.genericSplitAt (natE opinion) disjs = do
211 -- Fake proofs for all values except the correct one.
212 prevFakes <- fakeProof `mapM` prevDisjs
213 nextFakes <- fakeProof `mapM` nextDisjs
214 let prevProofs = fst <$> prevFakes
215 let nextProofs = fst <$> nextFakes
216 let challengeSum =
217 sum (proof_challenge <$> prevProofs) +
218 sum (proof_challenge <$> nextProofs)
219 correctProof <- prove encNonce [groupGen, pubKey] $
220 -- 'Oracle'
221 \correctCommitments ->
222 let commitments =
223 foldMap snd prevFakes <>
224 correctCommitments <>
225 foldMap snd nextFakes in
226 hash (encryptionStatement zkp enc) commitments - challengeSum
227 return $ DisjProof $ prevProofs <> (correctProof : nextProofs)
228 | otherwise = lift $ Exn.throwE $
229 ErrorProove_InvalidOpinion
230 (fromIntegral $ List.length disjs)
231 (natE opinion)
232 where
233 fakeProof :: Disjunction q -> S.StateT r (Exn.ExceptT ErrorProove m) (Proof q, [Commitment q])
234 fakeProof disj = do
235 -- Returns 'Commitment's verifiables by the verifier,
236 -- but computed from random 'proof_challenge' and 'proof_response'
237 -- instead of correct ones.
238 proof_challenge <- random
239 proof_response <- random
240 let proof = Proof{..}
241 return (proof, encryptionCommitments pubKey enc (disj, proof))
242
243 verifyEncryption ::
244 Monad m =>
245 SubGroup q =>
246 PublicKey q -> ZKP ->
247 [Disjunction q] ->
248 (Encryption q, DisjProof q) ->
249 Exn.ExceptT ErrorValidateEncryption m Bool
250 verifyEncryption pubKey zkp disjs (enc, DisjProof proofs)
251 | List.length proofs /= List.length disjs =
252 Exn.throwE $ ErrorValidateEncryption_InvalidProofLength
253 (fromIntegral $ List.length proofs)
254 (fromIntegral $ List.length disjs)
255 | otherwise = return $ challengeSum == hash (encryptionStatement zkp enc) commitments
256 where
257 challengeSum = sum (proof_challenge <$> proofs)
258 commitments = foldMap (encryptionCommitments pubKey enc) (List.zip disjs proofs)
259
260 encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString
261 encryptionStatement (ZKP zkp) Encryption{..} =
262 "prove|"<>zkp<>"|"<>
263 fromString (show (natG encryption_nonce))<>","<>
264 fromString (show (natG encryption_vault))<>"|"
265
266 -- | @('encryptionCommitments' pubKey enc (disj,proof))@
267 -- returns the 'Commitment's with only the knowledge of the verifier.
268 --
269 -- The 'Proof' comes from 'prove' of @fakeProof@ in 'proveEncryption'.
270 encryptionCommitments ::
271 SubGroup q =>
272 PublicKey q -> Encryption q ->
273 (Disjunction q, Proof q) -> [G q]
274 encryptionCommitments pubKey Encryption{..} (disj, proof) =
275 [ commit proof groupGen encryption_nonce
276 -- == groupGen ^ nonce if 'Proof' comes from 'prove'
277 , commit proof pubKey (encryption_vault*disj)
278 -- == pubKey ^ nonce if 'Proof' comes from 'prove'
279 -- and 'encryption_vault' encrypts (- logBase groupGen disj).
280 ]
281
282 -- ** Type 'ZKP'
283 -- | Zero-knowledge proof
284 newtype ZKP = ZKP BS.ByteString
285
286 -- ** Type 'ErrorProove'
287 -- | Error raised by 'proveEncryption'.
288 data ErrorProove
289 = ErrorProove_InvalidOpinion Natural Natural
290 -- ^ When the opinion is not within the number of 'Disjunction's.
291 deriving (Eq,Show)
292
293 -- ** Type 'ErrorValidateEncryption'
294 -- | Error raised by 'verifyEncryption'.
295 data ErrorValidateEncryption
296 = ErrorValidateEncryption_InvalidProofLength Natural Natural
297 -- ^ When the number of proofs is different than
298 -- the number of 'Disjunction's.
299 deriving (Eq,Show)
300
301 -- * Type 'Question'
302 data Question q = Question
303 { question_text :: Text
304 , question_choices :: [Text]
305 , question_mini :: Opinion q
306 , question_maxi :: Opinion q
307 -- , question_blank :: Maybe Bool
308 } deriving (Eq, Show)
309
310 -- * Type 'Answer'
311 data Answer q = Answer
312 { answer_opinions :: [(Encryption q, DisjProof q)]
313 -- ^ Encrypted 'Opinion' for each 'question_choices'
314 -- with a 'DisjProof' that they belong to [0,1].
315 , answer_sumProof :: DisjProof q
316 -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
317 -- is an element of @[mini..maxi]@.
318 -- , answer_blankProof ::
319 } deriving (Eq,Show)
320
321 -- ** Type 'ErrorAnswer'
322 -- | Error raised by 'encryptAnswer'.
323 data ErrorAnswer
324 = ErrorAnswer_WrongNumberOfOpinions Natural Natural
325 -- ^ When the number of opinions is different than
326 -- the number of choices ('question_choices').
327 | ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
328 -- ^ When the sum of opinions is not within the bounds
329 -- of 'question_mini' and 'question_maxi'.
330 deriving (Eq,Show)
331
332 -- | @('encryptAnswer' pubKey zkp quest opinions)@
333 -- returns an 'Answer' validable by 'verifyAnswer',
334 -- unless an 'ErrorAnswer' is returned.
335 encryptAnswer ::
336 Monad m => RandomGen r => SubGroup q =>
337 PublicKey q -> ZKP ->
338 Question q -> [Bool] ->
339 S.StateT r (Exn.ExceptT ErrorAnswer m) (Answer q)
340 encryptAnswer pubKey zkp Question{..} opinionsBools
341 | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
342 lift $ Exn.throwE $
343 ErrorAnswer_WrongSumOfOpinions
344 (natE opinionsSum)
345 (natE question_mini)
346 (natE question_maxi)
347 | List.length opinions /= List.length question_choices =
348 lift $ Exn.throwE $
349 ErrorAnswer_WrongNumberOfOpinions
350 (fromIntegral $ List.length opinions)
351 (fromIntegral $ List.length question_choices)
352 | otherwise = do
353 encryptions <- encrypt pubKey `mapM` opinions
354 hoist (Exn.withExceptT (\case
355 ErrorProove_InvalidOpinion{} -> error "encryptAnswer: impossible happened"
356 )) $ do
357 individualProofs <- zipWithM
358 (proveEncryption pubKey zkp booleanDisjunctions)
359 opinions encryptions
360 sumProof <- proveEncryption pubKey zkp
361 (intervalDisjunctions question_mini question_maxi)
362 (opinionsSum - question_mini)
363 ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's
364 , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's
365 )
366 return $ Answer
367 { answer_opinions = List.zip
368 (snd <$> encryptions) -- NOTE: drop encNonce
369 individualProofs
370 , answer_sumProof = sumProof
371 }
372 where
373 opinionsSum = sum opinions
374 opinions = (\o -> if o then one else zero) <$> opinionsBools
375
376 verifyAnswer ::
377 SubGroup q =>
378 PublicKey q -> ZKP ->
379 Question q -> Answer q -> Bool
380 verifyAnswer pubKey zkp Question{..} Answer{..}
381 | List.length question_choices /= List.length answer_opinions = False
382 | otherwise = either (const False) id $ Exn.runExcept $ do
383 validOpinions <-
384 verifyEncryption pubKey zkp booleanDisjunctions
385 `traverse` answer_opinions
386 validSum <- verifyEncryption pubKey zkp
387 (intervalDisjunctions question_mini question_maxi)
388 ( sum (fst <$> answer_opinions)
389 , answer_sumProof )
390 return (and validOpinions && validSum)
391
392 -- * Type 'Election'
393 data Election q = Election
394 { election_name :: Text
395 , election_description :: Text
396 , election_publicKey :: PublicKey q
397 , election_questions :: [Question q]
398 , election_uuid :: UUID
399 , election_hash :: Hash -- TODO: serialize to JSON to calculate this
400 } deriving (Eq,Show)
401
402 -- ** Type 'Hash'
403 newtype Hash = Hash Text
404 deriving (Eq,Ord,Show)
405
406 -- * Type 'Ballot'
407 data Ballot q = Ballot
408 { ballot_answers :: [Answer q]
409 , ballot_signature :: Maybe (Signature q)
410 , ballot_election_uuid :: UUID
411 , ballot_election_hash :: Hash
412 }
413
414 -- | @('encryptBallot' elec ('Just' secKey) opinionsByQuest)@
415 -- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
416 -- where 'opinionsByQuest' is a list of 'Opinion's
417 -- on each 'question_choices' of each 'election_questions'.
418 encryptBallot ::
419 Monad m => RandomGen r => SubGroup q =>
420 Election q -> Maybe (SecretKey q) -> [[Bool]] ->
421 S.StateT r (Exn.ExceptT ErrorBallot m) (Ballot q)
422 encryptBallot Election{..} secKeyMay opinionsByQuest
423 | List.length election_questions /= List.length opinionsByQuest =
424 lift $ Exn.throwE $
425 ErrorBallot_WrongNumberOfAnswers
426 (fromIntegral $ List.length opinionsByQuest)
427 (fromIntegral $ List.length election_questions)
428 | otherwise = do
429 let (keysMay, zkp) =
430 case secKeyMay of
431 Nothing -> (Nothing, ZKP "")
432 Just secKey ->
433 ( Just (secKey, pubKey)
434 , ZKP (fromString (show (natG pubKey))) )
435 where pubKey = groupGen ^ secKey
436 ballot_answers <-
437 hoist (Exn.withExceptT ErrorBallot_Answer) $
438 zipWithM (encryptAnswer election_publicKey zkp)
439 election_questions opinionsByQuest
440 ballot_signature <- case keysMay of
441 Nothing -> return Nothing
442 Just (secKey, signature_publicKey) -> do
443 signature_proof <-
444 prove secKey (Identity groupGen) $
445 \(Identity commitment) ->
446 hash
447 (signatureCommitments zkp commitment)
448 (signatureStatement ballot_answers)
449 return $ Just Signature{..}
450 return Ballot
451 { ballot_answers
452 , ballot_election_hash = election_hash
453 , ballot_election_uuid = election_uuid
454 , ballot_signature
455 }
456
457 verifyBallot :: SubGroup q => Election q -> Ballot q -> Bool
458 verifyBallot Election{..} Ballot{..} =
459 ballot_election_uuid == election_uuid &&
460 ballot_election_hash == election_hash &&
461 List.length election_questions == List.length ballot_answers &&
462 let (isValidSign, zkpSign) =
463 case ballot_signature of
464 Nothing -> (True, ZKP "")
465 Just Signature{..} ->
466 let zkp = ZKP (fromString (show (natG signature_publicKey))) in
467 (, zkp) $
468 proof_challenge signature_proof == hash
469 (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey))
470 (signatureStatement ballot_answers)
471 in
472 and $ isValidSign :
473 List.zipWith (verifyAnswer election_publicKey zkpSign)
474 election_questions ballot_answers
475
476 -- ** Type 'Signature'
477 -- | Schnorr-like signature.
478 --
479 -- Used to avoid 'Ballot' stuffing.
480 data Signature q = Signature
481 { signature_publicKey :: PublicKey q
482 , signature_proof :: Proof q
483 }
484
485 -- | @('signatureStatement' answers)@
486 -- returns all the 'encryption_nonce's and 'encryption_vault's
487 -- of the given @answers@.
488 signatureStatement :: Foldable f => SubGroup q => f (Answer q) -> [G q]
489 signatureStatement =
490 foldMap $ \Answer{..} ->
491 (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
492 [encryption_nonce, encryption_vault]
493
494 -- | @('signatureCommitments' zkp commitment)@
495 -- returns the hashable content from the knowledge of the verifier.
496 signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString
497 signatureCommitments (ZKP zkp) commitment =
498 "sig|"<>zkp<>"|"<>fromString (show (natG commitment))<>"|"
499
500 -- ** Type 'ErrorBallot'
501 -- | Error raised by 'encryptBallot'.
502 data ErrorBallot
503 = ErrorBallot_WrongNumberOfAnswers Natural Natural
504 -- ^ When the number of answers
505 -- is different than the number of questions.
506 | ErrorBallot_Answer ErrorAnswer
507 -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
508 deriving (Eq,Show)