]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/src/Voting/Protocol/Election.hs
protocol: use Purescript's algebra hierarchy
[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 instances
7 module Voting.Protocol.Election where
8
9 import Control.Applicative (Applicative(..), Alternative(..))
10 import Control.DeepSeq (NFData)
11 import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM)
12 import Control.Monad.Trans.Class (MonadTrans(..))
13 import Control.Monad.Trans.Except (ExceptT(..), runExcept, throwE, withExceptT)
14 import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))
15 import Data.Bool
16 import Data.Either (either)
17 import Data.Eq (Eq(..))
18 import Data.Foldable (Foldable, foldMap, and)
19 import Data.Function (($), (.), id, const)
20 import Data.Functor (Functor, (<$>), (<$))
21 import Data.Functor.Identity (Identity(..))
22 import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe, listToMaybe)
23 import Data.Monoid (Monoid(..))
24 import Data.Ord (Ord(..))
25 import Data.Proxy (Proxy(..))
26 import Data.Reflection (Reifies(..), reify)
27 import Data.Semigroup (Semigroup(..))
28 import Data.String (String, IsString(..))
29 import Data.Text (Text)
30 import Data.Traversable (Traversable(..))
31 import Data.Tuple (fst, snd)
32 import GHC.Generics (Generic)
33 import GHC.Natural (minusNaturalMaybe)
34 import Numeric.Natural (Natural)
35 import Prelude (fromIntegral)
36 import System.IO (IO, FilePath)
37 import System.Random (RandomGen)
38 import Text.Show (Show(..), showChar, showString)
39 import qualified Control.Monad.Trans.State.Strict as S
40 import qualified Data.Aeson as JSON
41 import qualified Data.Aeson.Encoding as JSON
42 import qualified Data.Aeson.Internal as JSON
43 import qualified Data.Aeson.Parser.Internal as JSON
44 import qualified Data.Aeson.Types as JSON
45 import qualified Data.ByteString as BS
46 import qualified Data.ByteString.Lazy as BSL
47 import qualified Data.Char as Char
48 import qualified Data.List as List
49 import qualified Data.Text as Text
50 import qualified Text.ParserCombinators.ReadP as Read
51 import qualified Text.Read as Read
52
53 import Voting.Protocol.Utils
54 import Voting.Protocol.Arith
55 import Voting.Protocol.Credential
56
57 -- * Type 'Encryption'
58 -- | ElGamal-like encryption.
59 -- Its security relies on the /Discrete Logarithm problem/.
60 --
61 -- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),
62 -- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@
63 -- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable,
64 -- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like")
65 -- to enable the additive homomorphism.
66 --
67 -- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@,
68 -- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.
69 data Encryption crypto v c = Encryption
70 { encryption_nonce :: !(G crypto c)
71 -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text,
72 -- equal to @('groupGen' '^'encNonce)@
73 , encryption_vault :: !(G crypto c)
74 -- ^ Encrypted 'clear' text,
75 -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@
76 } deriving (Generic)
77 deriving instance Eq (G crypto c) => Eq (Encryption crypto v c)
78 deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption crypto v c)
79 deriving instance NFData (G crypto c) => NFData (Encryption crypto v c)
80 instance
81 ( Reifies v Version
82 , GroupParams crypto c
83 ) => ToJSON (Encryption crypto v c) where
84 toJSON Encryption{..} =
85 JSON.object
86 [ "alpha" .= encryption_nonce
87 , "beta" .= encryption_vault
88 ]
89 toEncoding Encryption{..} =
90 JSON.pairs
91 ( "alpha" .= encryption_nonce
92 <> "beta" .= encryption_vault
93 )
94 instance
95 ( Reifies v Version
96 , GroupParams crypto c
97 ) => FromJSON (Encryption crypto v c) where
98 parseJSON = JSON.withObject "Encryption" $ \o -> do
99 encryption_nonce <- o .: "alpha"
100 encryption_vault <- o .: "beta"
101 return Encryption{..}
102
103 -- | Additive homomorphism.
104 -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
105 instance GroupParams crypto c => Additive (Encryption crypto v c) where
106 zero = Encryption one one
107 x+y = Encryption
108 (encryption_nonce x * encryption_nonce y)
109 (encryption_vault x * encryption_vault y)
110
111 -- *** Type 'EncryptionNonce'
112 type EncryptionNonce = E
113
114 -- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.
115 --
116 -- WARNING: the secret encryption nonce (@encNonce@)
117 -- is returned alongside the 'Encryption'
118 -- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption',
119 -- but this secret @encNonce@ MUST be forgotten after that,
120 -- as it may be used to decipher the 'Encryption'
121 -- without the 'SecretKey' associated with 'pubKey'.
122 encrypt ::
123 Reifies v Version =>
124 GroupParams crypto c =>
125 Monad m => RandomGen r =>
126 PublicKey crypto c -> E crypto c ->
127 S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c)
128 encrypt pubKey clear = do
129 encNonce <- random
130 -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.
131 return $ (encNonce,)
132 Encryption
133 { encryption_nonce = groupGen^encNonce
134 , encryption_vault = pubKey ^encNonce * groupGen^clear
135 }
136
137 -- * Type 'Proof'
138 -- | Non-Interactive Zero-Knowledge 'Proof'
139 -- of knowledge of a discrete logarithm:
140 -- @(secret == logBase base (base^secret))@.
141 data Proof crypto v c = Proof
142 { proof_challenge :: !(Challenge crypto c)
143 -- ^ 'Challenge' sent by the verifier to the prover
144 -- to ensure that the prover really has knowledge
145 -- of the secret and is not replaying.
146 -- Actually, 'proof_challenge' is not sent to the prover,
147 -- but derived from the prover's 'Commitment's and statements
148 -- with a collision resistant 'hash'.
149 -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.
150 , proof_response :: !(E crypto c)
151 -- ^ A discrete logarithm sent by the prover to the verifier,
152 -- as a response to 'proof_challenge'.
153 --
154 -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:
155 --
156 -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@,
157 -- * @commitment '==' 'commit' proof base basePowSec '=='
158 -- base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@,
159 -- * and @basePowSec '==' base'^'sec@,
160 --
161 -- then, with overwhelming probability (due to the 'hash' function),
162 -- the prover was not able to choose 'proof_challenge'
163 -- yet was able to compute a 'proof_response' such that
164 -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),
165 -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,
166 -- therefore the prover knows 'sec'.
167 --
168 -- The prover choses 'commitment' to be a random power of @base@,
169 -- to ensure that each 'prove' does not reveal any information
170 -- about its secret.
171 } deriving (Eq,Show,NFData,Generic)
172 instance ToJSON (Proof crypto v c) where
173 toJSON Proof{..} =
174 JSON.object
175 [ "challenge" .= proof_challenge
176 , "response" .= proof_response
177 ]
178 toEncoding Proof{..} =
179 JSON.pairs
180 ( "challenge" .= proof_challenge
181 <> "response" .= proof_response
182 )
183 instance GroupParams crypto c => FromJSON (Proof crypto v c) where
184 parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do
185 proof_challenge <- o .: "challenge"
186 proof_response <- o .: "response"
187 return Proof{..}
188
189 -- ** Type 'ZKP'
190 -- | Zero-knowledge proof.
191 --
192 -- A protocol is /zero-knowledge/ if the verifier
193 -- learns nothing from the protocol except that the prover
194 -- knows the secret.
195 --
196 -- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:
197 -- A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.
198 newtype ZKP = ZKP BS.ByteString
199
200 -- ** Type 'Challenge'
201 type Challenge = E
202
203 -- ** Type 'Oracle'
204 -- An 'Oracle' returns the 'Challenge' of the 'Commitment's
205 -- by 'hash'ing them (eventually with other 'Commitment's).
206 --
207 -- Used in 'prove' it enables a Fiat-Shamir transformation
208 -- of an /interactive zero-knowledge/ (IZK) proof
209 -- into a /non-interactive zero-knowledge/ (NIZK) proof.
210 -- That is to say that the verifier does not have
211 -- to send a 'Challenge' to the prover.
212 -- Indeed, the prover now handles the 'Challenge'
213 -- which becomes a (collision resistant) 'hash'
214 -- of the prover's commitments (and statements to be a stronger proof).
215 type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c
216
217 -- | @('prove' sec commitmentBases oracle)@
218 -- returns a 'Proof' that @sec@ is known
219 -- (by proving the knowledge of its discrete logarithm).
220 --
221 -- The 'Oracle' is given 'Commitment's equal to the 'commitmentBases'
222 -- raised to the power of the secret nonce of the 'Proof',
223 -- as those are the 'Commitment's that the verifier will obtain
224 -- when composing the 'proof_challenge' and 'proof_response' together
225 -- (with 'commit').
226 --
227 -- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):
228 -- the statement must be included in the 'hash' (along with the commitments).
229 --
230 -- NOTE: a 'random' @nonce@ is used to ensure each 'prove'
231 -- does not reveal any information regarding the secret @sec@,
232 -- because two 'Proof's using the same 'Commitment'
233 -- can be used to deduce @sec@ (using the special-soundness).
234 prove ::
235 forall crypto v c list m r.
236 Reifies v Version =>
237 GroupParams crypto c =>
238 Monad m => RandomGen r => Functor list =>
239 E crypto c ->
240 list (G crypto c) ->
241 Oracle list crypto c ->
242 S.StateT r m (Proof crypto v c)
243 prove sec commitmentBases oracle = do
244 nonce <- random
245 let commitments = (^ nonce) <$> commitmentBases
246 let proof_challenge = oracle commitments
247 return Proof
248 { proof_challenge
249 , proof_response = nonce `op` (sec*proof_challenge)
250 }
251 where
252 -- | See comments in 'commit'.
253 op =
254 if reflect (Proxy @v) `hasVersionTag` versionTagQuicker
255 then (-)
256 else (+)
257
258 -- | Like 'prove' but quicker. It chould replace 'prove' entirely
259 -- when Helios-C specifications will be fixed.
260 proveQuicker ::
261 Reifies v Version =>
262 GroupParams crypto c =>
263 Monad m => RandomGen r => Functor list =>
264 E crypto c ->
265 list (G crypto c) ->
266 Oracle list crypto c ->
267 S.StateT r m (Proof crypto v c)
268 proveQuicker sec commitmentBases oracle = do
269 nonce <- random
270 let commitments = (^ nonce) <$> commitmentBases
271 let proof_challenge = oracle commitments
272 return Proof
273 { proof_challenge
274 , proof_response = nonce - sec*proof_challenge
275 }
276
277 -- | @('fakeProof')@ returns a 'Proof'
278 -- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,
279 -- instead of @('proof_challenge' '==' 'hash' statement commitments)@
280 -- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@
281 -- as a 'Proof' returned by 'prove'.
282 --
283 -- Used in 'proveEncryption' to fill the returned 'DisjProof'
284 -- with fake 'Proof's for all 'Disjunction's but the encrypted one.
285 fakeProof ::
286 GroupParams crypto c =>
287 Monad m => RandomGen r =>
288 S.StateT r m (Proof crypto v c)
289 fakeProof = do
290 proof_challenge <- random
291 proof_response <- random
292 return Proof{..}
293
294 -- ** Type 'Commitment'
295 -- | A commitment from the prover to the verifier.
296 -- It's a power of 'groupGen' chosen randomly by the prover
297 -- when making a 'Proof' with 'prove'.
298 type Commitment = G
299
300 -- | @('commit' proof base basePowSec)@ returns a 'Commitment'
301 -- from the given 'Proof' with the knowledge of the verifier.
302 commit ::
303 forall crypto v c.
304 Reifies v Version =>
305 GroupParams crypto c =>
306 Proof crypto v c ->
307 G crypto c ->
308 G crypto c ->
309 Commitment crypto c
310 commit Proof{..} base basePowSec =
311 (base^proof_response) `op`
312 (basePowSec^proof_challenge)
313 where
314 op =
315 if reflect (Proxy @v) `hasVersionTag` versionTagQuicker
316 then (*)
317 else (/)
318 -- TODO: contrary to some textbook presentations,
319 -- @('*')@ should be used instead of @('/')@ to avoid the performance cost
320 -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@,
321 -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'.
322 {-# INLINE commit #-}
323
324 -- | Like 'commit' but quicker. It chould replace 'commit' entirely
325 -- when Helios-C specifications will be fixed.
326 commitQuicker ::
327 GroupParams crypto c =>
328 Proof crypto v c ->
329 G crypto c ->
330 G crypto c ->
331 Commitment crypto c
332 commitQuicker Proof{..} base basePowSec =
333 base^proof_response *
334 basePowSec^proof_challenge
335
336 -- * Type 'Disjunction'
337 -- | A 'Disjunction' is an 'inverse'd @('groupGen' '^'opinion)@
338 -- it's used in 'proveEncryption' to generate a 'Proof'
339 -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,
340 type Disjunction = G
341
342 booleanDisjunctions ::
343 forall crypto c.
344 GroupParams crypto c =>
345 [Disjunction crypto c]
346 booleanDisjunctions = List.take 2 $ groupGenInverses @crypto
347
348 intervalDisjunctions ::
349 forall crypto c.
350 GroupParams crypto c =>
351 Natural -> Natural -> [Disjunction crypto c]
352 intervalDisjunctions mini maxi =
353 List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $
354 List.genericDrop (nat mini) $
355 groupGenInverses @crypto
356
357 -- ** Type 'Opinion'
358 -- | Index of a 'Disjunction' within a list of them.
359 -- It is encrypted as a 'GroupExponent' by 'encrypt'.
360 type Opinion = E
361
362 -- ** Type 'DisjProof'
363 -- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption'
364 -- is indexing a 'Disjunction' within a list of them,
365 -- without revealing which 'Opinion' it is.
366 newtype DisjProof crypto v c = DisjProof [Proof crypto v c]
367 deriving (Eq,Show,Generic)
368 deriving newtype (NFData,ToJSON,FromJSON)
369
370 -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@
371 -- returns a 'DisjProof' that 'enc' 'encrypt's
372 -- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.
373 --
374 -- The prover proves that it knows an 'encNonce', such that:
375 -- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@
376 --
377 -- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.
378 --
379 -- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.
380 proveEncryption ::
381 Reifies v Version =>
382 GroupParams crypto c =>
383 Monad m => RandomGen r =>
384 PublicKey crypto c -> ZKP ->
385 ([Disjunction crypto c],[Disjunction crypto c]) ->
386 (EncryptionNonce crypto c, Encryption crypto v c) ->
387 S.StateT r m (DisjProof crypto v c)
388 proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do
389 -- Fake proofs for all 'Disjunction's except the genuine one.
390 prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof
391 nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof
392 let fakeChallengeSum =
393 sum (proof_challenge <$> prevFakeProofs) +
394 sum (proof_challenge <$> nextFakeProofs)
395 let statement = encryptionStatement voterZKP enc
396 genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->
397 let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in
398 let prevCommitments = validCommitments prevDisjs prevFakeProofs in
399 let nextCommitments = validCommitments nextDisjs nextFakeProofs in
400 let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in
401 let challenge = hash statement commitments in
402 let genuineChallenge = challenge - fakeChallengeSum in
403 genuineChallenge
404 -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)
405 -- thus (sum (proof_challenge <$> proofs) == challenge)
406 -- as checked in 'verifyEncryption'.
407 let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
408 return (DisjProof proofs)
409
410 verifyEncryption ::
411 Reifies v Version =>
412 GroupParams crypto c =>
413 Monad m =>
414 PublicKey crypto c -> ZKP ->
415 [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) ->
416 ExceptT ErrorVerifyEncryption m Bool
417 verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =
418 case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of
419 Nothing ->
420 throwE $ ErrorVerifyEncryption_InvalidProofLength
421 (fromIntegral $ List.length proofs)
422 (fromIntegral $ List.length disjs)
423 Just commitments ->
424 return $ challengeSum ==
425 hash (encryptionStatement voterZKP enc) (join commitments)
426 where
427 challengeSum = sum (proof_challenge <$> proofs)
428
429 -- ** Hashing
430 encryptionStatement ::
431 GroupParams crypto c =>
432 ZKP -> Encryption crypto v c -> BS.ByteString
433 encryptionStatement (ZKP voterZKP) Encryption{..} =
434 "prove|"<>voterZKP<>"|"
435 <> bytesNat encryption_nonce<>","
436 <> bytesNat encryption_vault<>"|"
437
438 -- | @('encryptionCommitments' elecPubKey enc disj proof)@
439 -- returns the 'Commitment's with only the knowledge of the verifier.
440 --
441 -- For the prover the 'Proof' comes from @fakeProof@,
442 -- and for the verifier the 'Proof' comes from the prover.
443 encryptionCommitments ::
444 Reifies v Version =>
445 GroupParams crypto c =>
446 PublicKey crypto c -> Encryption crypto v c ->
447 Disjunction crypto c -> Proof crypto v c -> [G crypto c]
448 encryptionCommitments elecPubKey Encryption{..} disj proof =
449 [ commit proof groupGen encryption_nonce
450 -- == groupGen ^ nonce if 'Proof' comes from 'prove'.
451 -- base==groupGen, basePowSec==groupGen^encNonce.
452 , commit proof elecPubKey (encryption_vault*disj)
453 -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'
454 -- and 'encryption_vault' encrypts (- logBase groupGen disj).
455 -- base==elecPubKey, basePowSec==elecPubKey^encNonce.
456 ]
457
458 -- ** Type 'ErrorVerifyEncryption'
459 -- | Error raised by 'verifyEncryption'.
460 data ErrorVerifyEncryption
461 = ErrorVerifyEncryption_InvalidProofLength Natural Natural
462 -- ^ When the number of proofs is different than
463 -- the number of 'Disjunction's.
464 deriving (Eq,Show)
465
466 -- * Type 'Question'
467 data Question v = Question
468 { question_text :: !Text
469 , question_choices :: ![Text]
470 , question_mini :: !Natural
471 , question_maxi :: !Natural
472 -- , question_blank :: Maybe Bool
473 } deriving (Eq,Show,Generic,NFData)
474 instance Reifies v Version => ToJSON (Question v) where
475 toJSON Question{..} =
476 JSON.object
477 [ "question" .= question_text
478 , "answers" .= question_choices
479 , "min" .= question_mini
480 , "max" .= question_maxi
481 ]
482 toEncoding Question{..} =
483 JSON.pairs
484 ( "question" .= question_text
485 <> "answers" .= question_choices
486 <> "min" .= question_mini
487 <> "max" .= question_maxi
488 )
489 instance Reifies v Version => FromJSON (Question v) where
490 parseJSON = JSON.withObject "Question" $ \o -> do
491 question_text <- o .: "question"
492 question_choices <- o .: "answers"
493 question_mini <- o .: "min"
494 question_maxi <- o .: "max"
495 return Question{..}
496
497 -- * Type 'Answer'
498 data Answer crypto v c = Answer
499 { answer_opinions :: ![(Encryption crypto v c, DisjProof crypto v c)]
500 -- ^ Encrypted 'Opinion' for each 'question_choices'
501 -- with a 'DisjProof' that they belong to [0,1].
502 , answer_sumProof :: !(DisjProof crypto v c)
503 -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
504 -- is an element of @[mini..maxi]@.
505 -- , answer_blankProof ::
506 } deriving (Generic)
507 deriving instance Eq (G crypto c) => Eq (Answer crypto v c)
508 deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Answer crypto v c)
509 deriving instance NFData (G crypto c) => NFData (Answer crypto v c)
510 instance
511 ( Reifies v Version
512 , GroupParams crypto c
513 ) => ToJSON (Answer crypto v c) where
514 toJSON Answer{..} =
515 let (answer_choices, answer_individual_proofs) =
516 List.unzip answer_opinions in
517 JSON.object
518 [ "choices" .= answer_choices
519 , "individual_proofs" .= answer_individual_proofs
520 , "overall_proof" .= answer_sumProof
521 ]
522 toEncoding Answer{..} =
523 let (answer_choices, answer_individual_proofs) =
524 List.unzip answer_opinions in
525 JSON.pairs
526 ( "choices" .= answer_choices
527 <> "individual_proofs" .= answer_individual_proofs
528 <> "overall_proof" .= answer_sumProof
529 )
530 instance
531 ( Reifies v Version
532 , GroupParams crypto c
533 ) => FromJSON (Answer crypto v c) where
534 parseJSON = JSON.withObject "Answer" $ \o -> do
535 answer_choices <- o .: "choices"
536 answer_individual_proofs <- o .: "individual_proofs"
537 let answer_opinions = List.zip answer_choices answer_individual_proofs
538 answer_sumProof <- o .: "overall_proof"
539 return Answer{..}
540
541 -- | @('encryptAnswer' elecPubKey zkp quest opinions)@
542 -- returns an 'Answer' validable by 'verifyAnswer',
543 -- unless an 'ErrorAnswer' is returned.
544 encryptAnswer ::
545 Reifies v Version =>
546 GroupParams crypto c =>
547 Monad m => RandomGen r =>
548 PublicKey crypto c -> ZKP ->
549 Question v -> [Bool] ->
550 S.StateT r (ExceptT ErrorAnswer m) (Answer crypto v c)
551 encryptAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} opinionByChoice
552 | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
553 lift $ throwE $
554 ErrorAnswer_WrongSumOfOpinions opinionsSum question_mini question_maxi
555 | List.length opinions /= List.length question_choices =
556 lift $ throwE $
557 ErrorAnswer_WrongNumberOfOpinions
558 (fromIntegral $ List.length opinions)
559 (fromIntegral $ List.length question_choices)
560 | otherwise = do
561 encryptions <- encrypt elecPubKey `mapM` opinions
562 individualProofs <- zipWithM
563 (\opinion -> proveEncryption elecPubKey zkp $
564 if opinion
565 then (List.init booleanDisjunctions,[])
566 else ([],List.tail booleanDisjunctions))
567 opinionByChoice encryptions
568 sumProof <- proveEncryption elecPubKey zkp
569 (List.tail <$> List.genericSplitAt
570 (fromJust $ opinionsSum`minusNaturalMaybe`question_mini)
571 (intervalDisjunctions question_mini question_maxi))
572 ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's
573 , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's
574 )
575 return $ Answer
576 { answer_opinions = List.zip
577 (snd <$> encryptions) -- NOTE: drop encNonce
578 individualProofs
579 , answer_sumProof = sumProof
580 }
581 where
582 opinionsSum = sum $ nat <$> opinions
583 opinions = (\o -> if o then one else zero) <$> opinionByChoice
584
585 verifyAnswer ::
586 Reifies v Version =>
587 GroupParams crypto c =>
588 PublicKey crypto c -> ZKP ->
589 Question v -> Answer crypto v c -> Bool
590 verifyAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} Answer{..}
591 | List.length question_choices /= List.length answer_opinions = False
592 | otherwise = do
593 either (const False) id $ runExcept $ do
594 validOpinions <-
595 verifyEncryption elecPubKey zkp booleanDisjunctions
596 `traverse` answer_opinions
597 validSum <- verifyEncryption elecPubKey zkp
598 (intervalDisjunctions question_mini question_maxi)
599 ( sum (fst <$> answer_opinions)
600 , answer_sumProof )
601 return (and validOpinions && validSum)
602
603 -- ** Type 'ErrorAnswer'
604 -- | Error raised by 'encryptAnswer'.
605 data ErrorAnswer
606 = ErrorAnswer_WrongNumberOfOpinions Natural Natural
607 -- ^ When the number of opinions is different than
608 -- the number of choices ('question_choices').
609 | ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
610 -- ^ When the sum of opinions is not within the bounds
611 -- of 'question_mini' and 'question_maxi'.
612 deriving (Eq,Show,Generic,NFData)
613
614 -- * Type 'Election'
615 data Election crypto v c = Election
616 { election_name :: !Text
617 , election_description :: !Text
618 , election_questions :: ![Question v]
619 , election_uuid :: !UUID
620 , election_hash :: Base64SHA256
621 , election_crypto :: !crypto
622 , election_version :: !(Maybe Version)
623 , election_public_key :: !(PublicKey crypto c)
624 } deriving (Generic)
625 deriving instance (Eq crypto, Eq (G crypto c)) => Eq (Election crypto v c)
626 deriving instance (Show crypto, Show (G crypto c)) => Show (Election crypto v c)
627 deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Election crypto v c)
628 instance
629 ( Reifies v Version
630 , GroupParams crypto c
631 , ToJSON crypto
632 ) => ToJSON (Election crypto v c) where
633 toJSON Election{..} =
634 JSON.object $
635 [ "name" .= election_name
636 , "description" .= election_description
637 , ("public_key", JSON.object
638 [ "group" .= election_crypto
639 , "y" .= election_public_key
640 ])
641 , "questions" .= election_questions
642 , "uuid" .= election_uuid
643 ] <>
644 maybe [] (\version -> [ "version" .= version ]) election_version
645 toEncoding Election{..} =
646 JSON.pairs $
647 ( "name" .= election_name
648 <> "description" .= election_description
649 <> JSON.pair "public_key" (JSON.pairs $
650 "group" .= election_crypto
651 <> "y" .= election_public_key
652 )
653 <> "questions" .= election_questions
654 <> "uuid" .= election_uuid
655 ) <>
656 maybe mempty ("version" .=) election_version
657
658 hashElection ::
659 Reifies v Version =>
660 GroupParams crypto c =>
661 ToJSON crypto =>
662 Election crypto v c -> Base64SHA256
663 hashElection = base64SHA256 . BSL.toStrict . JSON.encode
664
665 readElection ::
666 forall crypto r.
667 FromJSON crypto =>
668 ReifyCrypto crypto =>
669 FilePath ->
670 (forall v c.
671 Reifies v Version =>
672 GroupParams crypto c =>
673 Election crypto v c -> r) ->
674 ExceptT String IO r
675 readElection filePath k = do
676 fileData <- lift $ BS.readFile filePath
677 ExceptT $ return $
678 jsonEitherFormatError $
679 JSON.eitherDecodeStrictWith JSON.jsonEOF
680 (JSON.iparse (parseElection fileData))
681 fileData
682 where
683 parseElection fileData = JSON.withObject "Election" $ \o -> do
684 election_version <- o .:? "version"
685 reify (fromMaybe stableVersion election_version) $ \(_v::Proxy v) -> do
686 (election_crypto, elecPubKey) <-
687 JSON.explicitParseField
688 (JSON.withObject "public_key" $ \obj -> do
689 crypto <- obj .: "group"
690 pubKey :: JSON.Value <- obj .: "y"
691 return (crypto, pubKey)
692 ) o "public_key"
693 reifyCrypto election_crypto $ \(_c::Proxy c) -> do
694 election_name <- o .: "name"
695 election_description <- o .: "description"
696 election_questions <- o .: "questions" :: JSON.Parser [Question v]
697 election_uuid <- o .: "uuid"
698 election_public_key :: PublicKey crypto c <- parseJSON elecPubKey
699 return $ k $ Election
700 { election_questions = election_questions
701 , election_public_key = election_public_key
702 , election_hash = base64SHA256 fileData
703 , ..
704 }
705
706 -- * Type 'Ballot'
707 data Ballot crypto v c = Ballot
708 { ballot_answers :: ![Answer crypto v c]
709 , ballot_signature :: !(Maybe (Signature crypto v c))
710 , ballot_election_uuid :: !UUID
711 , ballot_election_hash :: !Base64SHA256
712 } deriving (Generic)
713 deriving instance (NFData (G crypto c), NFData crypto) => NFData (Ballot crypto v c)
714 instance
715 ( Reifies v Version
716 , GroupParams crypto c
717 , ToJSON (G crypto c)
718 ) => ToJSON (Ballot crypto v c) where
719 toJSON Ballot{..} =
720 JSON.object $
721 [ "answers" .= ballot_answers
722 , "election_uuid" .= ballot_election_uuid
723 , "election_hash" .= ballot_election_hash
724 ] <>
725 maybe [] (\sig -> [ "signature" .= sig ]) ballot_signature
726 toEncoding Ballot{..} =
727 JSON.pairs $
728 ( "answers" .= ballot_answers
729 <> "election_uuid" .= ballot_election_uuid
730 <> "election_hash" .= ballot_election_hash
731 ) <>
732 maybe mempty ("signature" .=) ballot_signature
733 instance
734 ( Reifies v Version
735 , GroupParams crypto c
736 ) => FromJSON (Ballot crypto v c) where
737 parseJSON = JSON.withObject "Ballot" $ \o -> do
738 ballot_answers <- o .: "answers"
739 ballot_signature <- o .:? "signature"
740 ballot_election_uuid <- o .: "election_uuid"
741 ballot_election_hash <- o .: "election_hash"
742 return Ballot{..}
743
744 -- | @('encryptBallot' c ('Just' ballotSecKey) opinionsByQuest)@
745 -- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
746 -- where 'opinionsByQuest' is a list of 'Opinion's
747 -- on each 'question_choices' of each 'election_questions'.
748 encryptBallot ::
749 Reifies v Version =>
750 GroupParams crypto c => Key crypto =>
751 Monad m => RandomGen r =>
752 Election crypto v c ->
753 Maybe (SecretKey crypto c) -> [[Bool]] ->
754 S.StateT r (ExceptT ErrorBallot m) (Ballot crypto v c)
755 encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQuest
756 | List.length election_questions /= List.length opinionsByQuest =
757 lift $ throwE $
758 ErrorBallot_WrongNumberOfAnswers
759 (fromIntegral $ List.length opinionsByQuest)
760 (fromIntegral $ List.length election_questions)
761 | otherwise = do
762 let (voterKeys, voterZKP) =
763 case ballotSecKeyMay of
764 Nothing -> (Nothing, ZKP "")
765 Just ballotSecKey ->
766 ( Just (ballotSecKey, ballotPubKey)
767 , ZKP (bytesNat ballotPubKey) )
768 where ballotPubKey = publicKey ballotSecKey
769 ballot_answers <-
770 S.mapStateT (withExceptT ErrorBallot_Answer) $
771 zipWithM (encryptAnswer election_public_key voterZKP)
772 election_questions opinionsByQuest
773 ballot_signature <- case voterKeys of
774 Nothing -> return Nothing
775 Just (ballotSecKey, signature_publicKey) -> do
776 signature_proof <-
777 proveQuicker ballotSecKey (Identity groupGen) $
778 \(Identity commitment) ->
779 hash @crypto
780 -- NOTE: the order is unusual, the commitments are first
781 -- then comes the statement. Best guess is that
782 -- this is easier to code due to their respective types.
783 (signatureCommitments @crypto voterZKP commitment)
784 (signatureStatement @crypto ballot_answers)
785 return $ Just Signature{..}
786 return Ballot
787 { ballot_answers
788 , ballot_election_hash = election_hash
789 , ballot_election_uuid = election_uuid
790 , ballot_signature
791 }
792
793 verifyBallot ::
794 Reifies v Version =>
795 GroupParams crypto c =>
796 Election crypto v c ->
797 Ballot crypto v c -> Bool
798 verifyBallot (Election{..}::Election crypto v c) Ballot{..} =
799 ballot_election_uuid == election_uuid &&
800 ballot_election_hash == election_hash &&
801 List.length election_questions == List.length ballot_answers &&
802 let (isValidSign, zkpSign) =
803 case ballot_signature of
804 Nothing -> (True, ZKP "")
805 Just Signature{..} ->
806 let zkp = ZKP (bytesNat signature_publicKey) in
807 (, zkp) $
808 proof_challenge signature_proof == hash
809 (signatureCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey))
810 (signatureStatement @crypto ballot_answers)
811 in
812 and $ isValidSign :
813 List.zipWith (verifyAnswer election_public_key zkpSign)
814 election_questions ballot_answers
815
816 -- ** Type 'Signature'
817 -- | Schnorr-like signature.
818 --
819 -- Used by each voter to sign his/her encrypted 'Ballot'
820 -- using his/her 'Credential',
821 -- in order to avoid ballot stuffing.
822 data Signature crypto v c = Signature
823 { signature_publicKey :: !(PublicKey crypto c)
824 -- ^ Verification key.
825 , signature_proof :: !(Proof crypto v c)
826 } deriving (Generic)
827 deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c)
828 instance
829 ( Reifies v Version
830 , GroupParams crypto c
831 ) => ToJSON (Signature crypto v c) where
832 toJSON (Signature pubKey Proof{..}) =
833 JSON.object
834 [ "public_key" .= pubKey
835 , "challenge" .= proof_challenge
836 , "response" .= proof_response
837 ]
838 toEncoding (Signature pubKey Proof{..}) =
839 JSON.pairs
840 ( "public_key" .= pubKey
841 <> "challenge" .= proof_challenge
842 <> "response" .= proof_response
843 )
844 instance
845 ( Reifies v Version
846 , GroupParams crypto c
847 ) => FromJSON (Signature crypto v c) where
848 parseJSON = JSON.withObject "Signature" $ \o -> do
849 signature_publicKey <- o .: "public_key"
850 proof_challenge <- o .: "challenge"
851 proof_response <- o .: "response"
852 let signature_proof = Proof{..}
853 return Signature{..}
854
855 -- *** Hashing
856
857 -- | @('signatureStatement' answers)@
858 -- returns the encrypted material to be signed:
859 -- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@.
860 signatureStatement :: GroupParams crypto c => Foldable f => f (Answer crypto v c) -> [G crypto c]
861 signatureStatement =
862 foldMap $ \Answer{..} ->
863 (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
864 [encryption_nonce, encryption_vault]
865
866 -- | @('signatureCommitments' voterZKP commitment)@
867 signatureCommitments ::
868 GroupParams crypto c =>
869 ToNatural (G crypto c) =>
870 ZKP -> Commitment crypto c -> BS.ByteString
871 signatureCommitments (ZKP voterZKP) commitment =
872 "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
873 <> bytesNat commitment<>"|"
874
875 -- ** Type 'ErrorBallot'
876 -- | Error raised by 'encryptBallot'.
877 data ErrorBallot
878 = ErrorBallot_WrongNumberOfAnswers Natural Natural
879 -- ^ When the number of answers
880 -- is different than the number of questions.
881 | ErrorBallot_Answer ErrorAnswer
882 -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
883 | ErrorBallot_Wrong
884 -- ^ TODO: to be more precise.
885 deriving (Eq,Show,Generic,NFData)
886
887 -- * Type 'Version'
888 -- | Version of the Helios-C protocol.
889 data Version = Version
890 { version_branch :: [Natural]
891 , version_tags :: [(Text, Natural)]
892 } deriving (Eq,Ord,Generic,NFData)
893 instance IsString Version where
894 fromString = fromJust . readVersion
895 instance Show Version where
896 showsPrec _p Version{..} =
897 List.foldr (.) id
898 (List.intersperse (showChar '.') $
899 showsPrec 0 <$> version_branch) .
900 List.foldr (.) id
901 ((\(t,n) -> showChar '-' . showString (Text.unpack t) .
902 if n > 0 then showsPrec 0 n else id)
903 <$> version_tags)
904 instance ToJSON Version where
905 toJSON = toJSON . show
906 toEncoding = toEncoding . show
907 instance FromJSON Version where
908 parseJSON (JSON.String s)
909 | Just v <- readVersion (Text.unpack s)
910 = return v
911 parseJSON json = JSON.typeMismatch "Version" json
912
913 hasVersionTag :: Version -> Text -> Bool
914 hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v)
915
916 experimentalVersion :: Version
917 experimentalVersion = stableVersion
918 {version_tags = [(versionTagQuicker,0)]}
919
920 stableVersion :: Version
921 stableVersion = "1.6"
922
923 versionTagQuicker :: Text
924 versionTagQuicker = "quicker"
925
926 readVersion :: String -> Maybe Version
927 readVersion = parseReadP $ do
928 version_branch <- Read.sepBy1
929 (Read.read <$> Read.munch1 Char.isDigit)
930 (Read.char '.')
931 version_tags <- Read.many $ (,)
932 <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)
933 <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)
934 return Version{..}
935
936 parseReadP :: Read.ReadP a -> String -> Maybe a
937 parseReadP p s =
938 let p' = Read.readP_to_S p in
939 listToMaybe $ do
940 (x, "") <- p' s
941 return x