election.ml 22 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1
2
3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2016 Inria                                           *)
Stephane Glondu's avatar
Stephane Glondu committed
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

22
open Platform
Stephane Glondu's avatar
Stephane Glondu committed
23
open Serializable_t
24
open Signatures
25
open Common
Stephane Glondu's avatar
Stephane Glondu committed
26
27
28
29
30

(** Helper functions *)

let check_modulo p x = Z.(geq x zero && lt x p)

31
32
33
34
35
let question_length q =
  Array.length q.q_answers + match q.q_blank with
                             | Some true -> 1
                             | _ -> 0

Stephane Glondu's avatar
Stephane Glondu committed
36
(** Simple monad *)
Stephane Glondu's avatar
Stephane Glondu committed
37

Stephane Glondu's avatar
Stephane Glondu committed
38
module MakeSimpleMonad (G : GROUP) = struct
Stephane Glondu's avatar
Stephane Glondu committed
39
  type 'a t = unit -> 'a
Stephane Glondu's avatar
Stephane Glondu committed
40
  let ballots = ref []
Stephane Glondu's avatar
Stephane Glondu committed
41
42
  let return x () = x
  let bind x f = f (x ())
43
  let fail e = raise e
Stephane Glondu's avatar
Stephane Glondu committed
44

45
46
  let prng = lazy (pseudo_rng (random_string secure_rng 16))

Stephane Glondu's avatar
Stephane Glondu committed
47
  let random q =
48
    let size = Z.bit_length q / 8 + 1 in
Stephane Glondu's avatar
Stephane Glondu committed
49
    fun () ->
50
      let r = random_string (Lazy.force prng) size in
Stephane Glondu's avatar
Stephane Glondu committed
51
      Z.(of_bits r mod q)
Stephane Glondu's avatar
Stephane Glondu committed
52

53
  type elt = G.t ballot
54
  let cast x () = ballots := x :: !ballots
55
56
  let fold f x () = List.fold_left (fun accu b -> f () b accu ()) x !ballots
  let cardinal () = List.length !ballots
Stephane Glondu's avatar
Stephane Glondu committed
57
58
end

Stephane Glondu's avatar
Stephane Glondu committed
59
60
(** Homomorphic elections *)

Stephane Glondu's avatar
Stephane Glondu committed
61
module MakeElection (G : GROUP) (M : RANDOM) = struct
Stephane Glondu's avatar
Stephane Glondu committed
62
  open G
Stephane Glondu's avatar
Stephane Glondu committed
63

Stephane Glondu's avatar
Stephane Glondu committed
64
65
66
  type 'a m = 'a M.t
  open M
  let ( >>= ) = bind
Stephane Glondu's avatar
Stephane Glondu committed
67

Stephane Glondu's avatar
Stephane Glondu committed
68
  type elt = G.t
Stephane Glondu's avatar
Stephane Glondu committed
69
70

  type t = elt election
Stephane Glondu's avatar
Stephane Glondu committed
71
  type private_key = Z.t
Stephane Glondu's avatar
Stephane Glondu committed
72
  type public_key = elt
Stephane Glondu's avatar
Stephane Glondu committed
73
74
75

  let ( / ) x y = x *~ invert y

Stephane Glondu's avatar
Stephane Glondu committed
76
  type ciphertext = elt Serializable_t.ciphertext array array
Stephane Glondu's avatar
Stephane Glondu committed
77
78
79
80
81
82
83
84
85
86
87
88
89
90

  let dummy_ciphertext =
    {
      alpha = G.one;
      beta = G.one;
    }

  (** Multiply two ElGamal ciphertexts. *)
  let eg_combine c1 c2 =
    {
      alpha = c1.alpha *~ c2.alpha;
      beta = c1.beta *~ c2.beta;
    }

Stephane Glondu's avatar
Stephane Glondu committed
91
  let neutral_ciphertext e = Array.map (fun q ->
92
    Array.make (question_length q) dummy_ciphertext
Stephane Glondu's avatar
Stephane Glondu committed
93
  ) e.e_params.e_questions
94

95
  let combine_ciphertexts = Array.mmap2 eg_combine
Stephane Glondu's avatar
Stephane Glondu committed
96
97

  type plaintext = int array array
Stephane Glondu's avatar
Stephane Glondu committed
98
  type ballot = elt Serializable_t.ballot
Stephane Glondu's avatar
Stephane Glondu committed
99
100
101
  type randomness = Z.t array array

  (** ElGamal encryption. *)
Stephane Glondu's avatar
Stephane Glondu committed
102
  let eg_encrypt y r x =
Stephane Glondu's avatar
Stephane Glondu committed
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
    {
      alpha = g **~ r;
      beta = y **~ r *~ g **~ Z.of_int x;
    }

  let dummy_proof =
    {
      challenge = Z.zero;
      response = Z.zero;
    }

  (** Fiat-Shamir non-interactive zero-knowledge proofs of
      knowledge *)

  let fs_prove gs x oracle =
Stephane Glondu's avatar
Stephane Glondu committed
118
    random q >>= fun w ->
Stephane Glondu's avatar
Stephane Glondu committed
119
120
121
    let commitments = Array.map (fun g -> g **~ w) gs in
    let challenge = oracle commitments in
    let response = Z.((w + x * challenge) mod q) in
Stephane Glondu's avatar
Stephane Glondu committed
122
    return {challenge; response}
Stephane Glondu's avatar
Stephane Glondu committed
123
124
125

  (** ZKPs for disjunctions *)

Stephane Glondu's avatar
Stephane Glondu committed
126
  let eg_disj_prove y d zkp x r {alpha; beta} =
Stephane Glondu's avatar
Stephane Glondu committed
127
128
129
130
    (* prove that alpha = g^r and beta = y^r/d_x *)
    (* the size of d is the number of disjuncts *)
    let n = Array.length d in
    assert (0 <= x && x < n);
131
132
    let proofs = Array.make n dummy_proof
    and commitments = Array.make (2*n) g
Stephane Glondu's avatar
Stephane Glondu committed
133
134
135
136
137
    and total_challenges = ref Z.zero in
    (* compute fake proofs *)
    let f i =
      let challenge = random q
      and response = random q in
Stephane Glondu's avatar
Stephane Glondu committed
138
139
      challenge >>= fun challenge ->
      response >>= fun response ->
Stephane Glondu's avatar
Stephane Glondu committed
140
141
      proofs.(i) <- {challenge; response};
      commitments.(2*i) <- g **~ response / alpha **~ challenge;
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
142
      commitments.(2*i+1) <- y **~ response / (beta *~ d.(i)) **~ challenge;
Stephane Glondu's avatar
Stephane Glondu committed
143
      total_challenges := Z.(!total_challenges + challenge);
Stephane Glondu's avatar
Stephane Glondu committed
144
      return ()
Stephane Glondu's avatar
Stephane Glondu committed
145
    in
Stephane Glondu's avatar
Stephane Glondu committed
146
147
148
149
150
151
    let rec loop i =
      if i < x then f i >>= fun () -> loop (succ i)
      else if i = x then loop (succ i)
      else if i < n then f i >>= fun () -> loop (succ i)
      else return ()
    in loop 0 >>= fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
152
153
    total_challenges := Z.(q - !total_challenges mod q);
    (* compute genuine proof *)
Stephane Glondu's avatar
Stephane Glondu committed
154
    fs_prove [| g; y |] r (fun commitx ->
Stephane Glondu's avatar
Stephane Glondu committed
155
      Array.blit commitx 0 commitments (2*x) 2;
156
      let prefix = Printf.sprintf "prove|%s|%s,%s|"
157
        zkp (G.to_string alpha) (G.to_string beta)
158
159
      in
      Z.((G.hash prefix commitments + !total_challenges) mod q)
Stephane Glondu's avatar
Stephane Glondu committed
160
161
162
    ) >>= fun p ->
    proofs.(x) <- p;
    return proofs
Stephane Glondu's avatar
Stephane Glondu committed
163

Stephane Glondu's avatar
Stephane Glondu committed
164
  let eg_disj_verify y d zkp proofs {alpha; beta} =
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
165
    G.check alpha && G.check beta &&
Stephane Glondu's avatar
Stephane Glondu committed
166
    let n = Array.length d in
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
167
    n = Array.length proofs &&
168
    let commitments = Array.make (2*n) g
Stephane Glondu's avatar
Stephane Glondu committed
169
    and total_challenges = ref Z.zero in
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
170
171
172
173
174
175
176
177
178
179
    try
      for i = 0 to n-1 do
        let {challenge; response} = proofs.(i) in
        if check_modulo q challenge && check_modulo q response then (
          commitments.(2*i) <- g **~ response / alpha **~ challenge;
          commitments.(2*i+1) <- y **~ response / (beta *~ d.(i)) **~ challenge;
          total_challenges := Z.(!total_challenges + challenge);
        ) else raise Exit
      done;
      total_challenges := Z.(!total_challenges mod q);
180
      let prefix = Printf.sprintf "prove|%s|%s,%s|"
181
        zkp (G.to_string alpha) (G.to_string beta)
182
      in
183
      Z.(hash prefix commitments =% !total_challenges)
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
184
    with Exit -> false
Stephane Glondu's avatar
Stephane Glondu committed
185

186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
  (** ZKPs for blank ballots *)

  let make_blank_proof y zkp min max m0 c0 r0 mS cS rS =
    let zkp = Printf.sprintf "%s|%s,%s,%s,%s,%s,%s" zkp
                (G.to_string g) (G.to_string y)
                (G.to_string c0.alpha) (G.to_string c0.beta)
                (G.to_string cS.alpha) (G.to_string cS.beta)
    in
    if m0 = 0 then (
      let blank_proof =
        (* proof of m0 = 0 \/ mS = 0 (first is true) *)
        random q >>= fun challenge1 ->
        random q >>= fun response1 ->
        let commitmentA1 = g **~ response1 *~ cS.alpha **~ challenge1 in
        let commitmentB1 = y **~ response1 *~ cS.beta **~ challenge1 in
        random q >>= fun w ->
        let commitmentA0 = g **~ w and commitmentB0 = y **~ w in
        let prefix = Printf.sprintf "bproof0|%s|" zkp in
        let h = G.hash prefix [|commitmentA0; commitmentB0; commitmentA1; commitmentB1|] in
        let challenge0 = Z.(erem (h - challenge1) q) in
        let response0 = Z.(erem (w - r0 * challenge0) q) in
        return [|
            {challenge=challenge0; response=response0};
            {challenge=challenge1; response=response1};
          |]
      in
      let overall_proof =
        (* proof of m0 = 1 \/ min <= mS <= max (second is true) *)
        assert (min <= mS && mS <= max);
        random q >>= fun challenge0 ->
        random q >>= fun response0 ->
        let proof0 = {challenge=challenge0; response=response0} in
        let overall_proof = Array.make (max-min+2) proof0 in
        let commitments = Array.make (2*(max-min+2)) g in
        let total_challenges = ref challenge0 in
        commitments.(0) <- g **~ response0 *~ c0.alpha **~ challenge0;
        commitments.(1) <- y **~ response0 *~ (c0.beta / g) **~ challenge0;
        let index_true = mS-min+1 in
        let rec loop i =
          if i < max-min+2 then (
            if i <> index_true then (
              random q >>= fun challenge ->
              random q >>= fun response ->
              let nbeta = cS.beta / (g **~ Z.of_int (min+i-1)) in
              let j = 2*i in
              overall_proof.(i) <- {challenge; response};
              commitments.(j) <- g **~ response *~ cS.alpha **~ challenge;
              commitments.(j+1) <- y **~ response *~ nbeta **~ challenge;
              total_challenges := Z.(!total_challenges + challenge);
              loop (i+1)
            ) else loop (i+1)
          ) else return ()
        in
        loop 1 >>= fun () ->
        random q >>= fun w ->
        let j = 2 * index_true in
        commitments.(j) <- g **~ w;
        commitments.(j+1) <- y **~ w;
        let prefix = Printf.sprintf "bproof1|%s|" zkp in
        let h = G.hash prefix commitments in
        let challenge = Z.(erem (h - !total_challenges) q) in
        let response = Z.(erem (w - rS * challenge) q) in
        overall_proof.(index_true) <- {challenge; response};
        return overall_proof
      in
      blank_proof >>= fun blank_proof ->
      overall_proof >>= fun overall_proof ->
      return (overall_proof, blank_proof)
    ) else (
      let blank_proof =
        (* proof of m0 = 0 \/ mS = 0 (second is true) *)
        assert (mS = 0);
        random q >>= fun challenge0 ->
        random q >>= fun response0 ->
        let commitmentA0 = g **~ response0 *~ c0.alpha **~ challenge0 in
        let commitmentB0 = y **~ response0 *~ c0.beta **~ challenge0 in
        random q >>= fun w ->
        let commitmentA1 = g **~ w and commitmentB1 = y **~ w in
        let prefix = Printf.sprintf "bproof0|%s|" zkp in
        let h = G.hash prefix [|commitmentA0; commitmentB0; commitmentA1; commitmentB1|] in
        let challenge1 = Z.(erem (h - challenge0) q) in
        let response1 = Z.(erem (w - rS * challenge1) q) in
        return [|
            {challenge=challenge0; response=response0};
            {challenge=challenge1; response=response1}
          |]
      in
      let overall_proof =
        (* proof of m0 = 1 \/ min <= mS <= max (first is true) *)
        assert (m0 = 1);
        let nil_proof = {challenge=Z.zero; response=Z.zero} in
        let overall_proof = Array.make (max-min+2) nil_proof in
        let commitments = Array.make (2*(max-min+2)) g in
        let total_challenges = ref Z.zero in
        let rec loop i =
          if i < max-min+2 then (
            random q >>= fun challenge ->
            random q >>= fun response ->
            let nbeta = cS.beta / (g **~ Z.of_int (min+i-1)) in
            let j = 2*i in
            overall_proof.(i) <- {challenge; response};
            commitments.(j) <- g **~ response *~ cS.alpha **~ challenge;
            commitments.(j+1) <- y **~ response *~ nbeta **~ challenge;
            total_challenges := Z.(!total_challenges + challenge);
            loop (i+1)
          ) else return ()
        in
        loop 1 >>= fun () ->
        random q >>= fun w ->
        commitments.(0) <- g **~ w;
        commitments.(1) <- y **~ w;
        let prefix = Printf.sprintf "bproof1|%s|" zkp in
        let h = G.hash prefix commitments in
        let challenge = Z.(erem (h - !total_challenges) q) in
        let response = Z.(erem (w - r0 * challenge) q) in
        overall_proof.(0) <- {challenge; response};
        return overall_proof
      in
      blank_proof >>= fun blank_proof ->
      overall_proof >>= fun overall_proof ->
      return (overall_proof, blank_proof)
    )

  let verify_blank_proof y zkp min max c0 cS overall_proof blank_proof =
    G.check c0.alpha && G.check c0.beta &&
    G.check cS.alpha && G.check cS.beta &&
    let zkp = Printf.sprintf "%s|%s,%s,%s,%s,%s,%s" zkp
                (G.to_string g) (G.to_string y)
                (G.to_string c0.alpha) (G.to_string c0.beta)
                (G.to_string cS.alpha) (G.to_string cS.beta)
    in
    (* check blank_proof, proof of m0 = 0 \/ mS = 0 *)
    Array.length blank_proof = 2 &&
    (
      try
        let commitments = Array.make 4 g in
        let total_challenges = ref Z.zero in
        let {challenge; response} = blank_proof.(0) in
        if not (check_modulo q challenge && check_modulo q response) then
          raise Exit;
        commitments.(0) <- g **~ response *~ c0.alpha **~ challenge;
        commitments.(1) <- y **~ response *~ c0.beta **~ challenge;
        total_challenges := Z.(!total_challenges + challenge);
        let {challenge; response} = blank_proof.(1) in
        if not (check_modulo q challenge && check_modulo q response) then
          raise Exit;
        commitments.(2) <- g **~ response *~ cS.alpha **~ challenge;
        commitments.(3) <- y **~ response *~ cS.beta **~ challenge;
        total_challenges := Z.(!total_challenges + challenge);
        let prefix = Printf.sprintf "bproof0|%s|" zkp in
        let h = G.hash prefix commitments in
        let total_challenges = Z.(!total_challenges mod q) in
        Z.(h =% total_challenges)
      with Exit -> false
    ) &&
    (* check overall_proof, proof of m0 = 1 \/ min <= mS <= max *)
    Array.length overall_proof = max-min+2 &&
    (
      try
        let commitments = Array.make (2*(max-min+2)) g in
        let total_challenges = ref Z.zero in
        let {challenge; response} = overall_proof.(0) in
        if not (check_modulo q challenge && check_modulo q response) then
          raise Exit;
        commitments.(0) <- g **~ response *~ c0.alpha **~ challenge;
        commitments.(1) <- y **~ response *~ (c0.beta / g) **~ challenge;
        total_challenges := Z.(!total_challenges + challenge);
        let rec loop i =
          if i < max-min+2 then (
            let {challenge; response} = overall_proof.(i) in
            if not (check_modulo q challenge && check_modulo q response) then
              raise Exit;
            let nbeta = cS.beta / (g **~ Z.of_int (min+i-1)) in
            let j = 2*i in
            commitments.(j) <- g **~ response *~ cS.alpha **~ challenge;
            commitments.(j+1) <- y **~ response *~ nbeta **~ challenge;
            total_challenges := Z.(!total_challenges + challenge);
            loop (i+1)
          ) else ()
        in
        loop 1;
        let prefix = Printf.sprintf "bproof1|%s|" zkp in
        let h = G.hash prefix commitments in
        let total_challenges = Z.(!total_challenges mod q) in
        Z.(h =% total_challenges)
      with Exit -> false
    )

Stephane Glondu's avatar
Stephane Glondu committed
374
375
376
377
378
  (** Ballot creation *)

  let invg = invert g
  let d01 = [| G.one; invg |]

Stephane Glondu's avatar
Debug    
Stephane Glondu committed
379
380
  let make_d min max =
    let n = max - min + 1 in
381
    let d = Array.make n (invert (g **~ Z.of_int min)) in
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
382
383
384
385
386
    for i = 1 to n-1 do
      d.(i) <- d.(i-1) *~ invg
    done;
    d

Stephane Glondu's avatar
Stephane Glondu committed
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
  let swap xs =
    let rec loop i accu =
      if i >= 0
      then xs.(i) >>= fun x -> loop (pred i) (x::accu)
      else return (Array.of_list accu)
    in loop (pred (Array.length xs)) []

  let sswap xs =
    let rec loop_outer i accu =
      if i >= 0 then (
        let x = xs.(i) in
        let rec loop_inner j accu =
          if j >= 0
          then x.(j) >>= fun r -> loop_inner (pred j) (r::accu)
          else return (Array.of_list accu)
        in
        loop_inner (Array.length x - 1) [] >>= fun ys ->
        loop_outer (pred i) (ys::accu)
      ) else return (Array.of_list accu)
    in loop_outer (Array.length xs - 1) []

Stephane Glondu's avatar
Stephane Glondu committed
408
  let create_answer y zkp q r m =
409
410
    let n = Array.length r in
    assert (n = Array.length m);
Stephane Glondu's avatar
Stephane Glondu committed
411
412
    let choices = Array.map2 (eg_encrypt y) r m in
    let individual_proofs = Array.map3 (eg_disj_prove y d01 zkp) m r choices in
Stephane Glondu's avatar
Stephane Glondu committed
413
    swap individual_proofs >>= fun individual_proofs ->
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
    match q.q_blank with
    | Some true ->
       (* index 0 is whether the ballot is blank or not,
          indexes 1..n-1 are the actual choices *)
       assert (n = Array.length q.q_answers + 1);
       let choices' = Array.sub choices 1 (n - 1) in
       let r' = Array.sub r 1 (n - 1) in
       let m' = Array.sub m 1 (n - 1) in
       let sumr = Array.fold_left Z.(+) Z.zero r' in
       let summ = Array.fold_left (+) 0 m' in
       let sumc = Array.fold_left eg_combine dummy_ciphertext choices' in
       let bproofs =
         make_blank_proof y zkp q.q_min q.q_max
           m.(0) choices.(0) r.(0) summ sumc sumr
       in
       bproofs >>= fun (overall_proof, blank_proof) ->
       let blank_proof = Some blank_proof in
       return {choices; individual_proofs; overall_proof; blank_proof}
    | _ ->
       (* indexes 0..n-1 are the actual choices *)
       assert (n = Array.length q.q_answers);
       let sumr = Array.fold_left Z.(+) Z.zero r in
       let summ = Array.fold_left (+) 0 m in
       let sumc = Array.fold_left eg_combine dummy_ciphertext choices in
       assert (q.q_min <= summ && summ <= q.q_max);
       let d = make_d q.q_min q.q_max in
       let overall_proof = eg_disj_prove y d zkp (summ - q.q_min) sumr sumc in
       overall_proof >>= fun overall_proof ->
       let blank_proof = None in
       return {choices; individual_proofs; overall_proof; blank_proof}
Stephane Glondu's avatar
Stephane Glondu committed
444

Stephane Glondu's avatar
Stephane Glondu committed
445
  let make_randomness e =
Stephane Glondu's avatar
Stephane Glondu committed
446
    sswap (Array.map (fun q ->
447
      Array.init (question_length q) (fun _ -> random G.q)
Stephane Glondu's avatar
Stephane Glondu committed
448
    ) e.e_params.e_questions)
449

450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
  let make_sig_prefix zkp commitment =
    "sig|" ^ zkp ^ "|" ^ G.to_string commitment ^ "|"

  let make_sig_contents answers =
    List.flatten (
      List.map (fun a ->
        List.flatten (
          List.map (fun {alpha; beta} ->
            [alpha; beta]
          ) (Array.to_list a.choices)
        )
      ) (Array.to_list answers)
    ) |> Array.of_list

  let create_ballot e ?sk r m =
Stephane Glondu's avatar
Stephane Glondu committed
465
    let p = e.e_params in
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
    let sk, zkp =
      match sk with
      | None -> None, ""
      | Some x -> let y = G.(g **~ x) in Some (x, y), G.to_string y
    in
    swap (Array.map3 (create_answer p.e_public_key zkp) p.e_questions r m) >>= fun answers ->
    (
      match sk with
      | None -> return None
      | Some (x, y) ->
        random q >>= fun w ->
        let commitment = g **~ w in
        let prefix = make_sig_prefix zkp commitment in
        let contents = make_sig_contents answers in
        let s_challenge = G.hash prefix contents in
        let s_response = Z.(erem (w - x * s_challenge) q) in
        return (Some {s_public_key = y; s_challenge; s_response})
    ) >>= fun signature ->
Stephane Glondu's avatar
Stephane Glondu committed
484
485
    return {
      answers;
Stephane Glondu's avatar
Stephane Glondu committed
486
487
      election_hash = e.e_fingerprint;
      election_uuid = p.e_uuid;
488
      signature;
Stephane Glondu's avatar
Stephane Glondu committed
489
490
491
492
    }

  (** Ballot verification *)

Stephane Glondu's avatar
Stephane Glondu committed
493
  let verify_answer y zkp q a =
494
495
    let n = Array.length a.choices in
    n = Array.length a.individual_proofs &&
Stephane Glondu's avatar
Stephane Glondu committed
496
    Array.forall2 (eg_disj_verify y d01 zkp) a.individual_proofs a.choices &&
497
498
499
500
501
502
503
504
505
506
507
508
    match q.q_blank, a.blank_proof with
    | Some true, Some blank_proof ->
       n = Array.length q.q_answers + 1 &&
       let c = Array.sub a.choices 1 (n - 1) in
       let sumc = Array.fold_left eg_combine dummy_ciphertext c in
       verify_blank_proof y zkp q.q_min q.q_max a.choices.(0) sumc a.overall_proof blank_proof
    | _, None ->
       n = Array.length q.q_answers &&
       let sumc = Array.fold_left eg_combine dummy_ciphertext a.choices in
       let d = make_d q.q_min q.q_max in
       eg_disj_verify y d zkp a.overall_proof sumc
    | _, _ -> false
Stephane Glondu's avatar
Stephane Glondu committed
509

Stephane Glondu's avatar
Stephane Glondu committed
510
511
512
513
  let check_ballot e b =
    let p = e.e_params in
    b.election_uuid = p.e_uuid &&
    b.election_hash = e.e_fingerprint &&
514
    let ok, zkp = match b.signature with
Stephane Glondu's avatar
Stephane Glondu committed
515
      | Some {s_public_key = y; s_challenge; s_response} ->
516
        let zkp = G.to_string y in
517
518
519
520
        let ok =
          check_modulo q s_challenge &&
          check_modulo q s_response &&
          let commitment = g **~ s_response *~ y **~ s_challenge in
521
522
          let prefix = make_sig_prefix zkp commitment in
          let contents = make_sig_contents b.answers in
523
          Z.(s_challenge =% G.hash prefix contents)
524
        in ok, zkp
525
      | None -> true, ""
526
    in ok &&
Stephane Glondu's avatar
Stephane Glondu committed
527
    Array.forall2 (verify_answer p.e_public_key zkp) p.e_questions b.answers
Stephane Glondu's avatar
Stephane Glondu committed
528
529
530

  let extract_ciphertext b = Array.map (fun x -> x.choices) b.answers

531
  type factor = elt partial_decryption
Stephane Glondu's avatar
Stephane Glondu committed
532

Stephane Glondu's avatar
Stephane Glondu committed
533
  let eg_factor x {alpha; _} =
534
    let zkp = "decrypt|" ^ G.to_string (g **~ x) ^ "|" in
535
    alpha **~ x,
536
    fs_prove [| g; alpha |] x (hash zkp)
537

Stephane Glondu's avatar
Stephane Glondu committed
538
539
540
  let check_ciphertext c =
    Array.fforall (fun {alpha; beta} -> G.check alpha && G.check beta) c

541
  let compute_factor c x =
Stephane Glondu's avatar
Stephane Glondu committed
542
543
544
    if check_ciphertext c then (
      let res = Array.mmap (eg_factor x) c in
      let decryption_factors, decryption_proofs = Array.ssplit res in
Stephane Glondu's avatar
Stephane Glondu committed
545
546
      sswap decryption_proofs >>= fun decryption_proofs ->
      return {decryption_factors; decryption_proofs}
Stephane Glondu's avatar
Stephane Glondu committed
547
    ) else (
548
      fail (Invalid_argument "Invalid ciphertext")
Stephane Glondu's avatar
Stephane Glondu committed
549
    )
550
551

  let check_factor c y f =
552
    let zkp = "decrypt|" ^ G.to_string y ^ "|" in
553
    Array.fforall3 (fun {alpha; _} f {challenge; response} ->
Stephane Glondu's avatar
Stephane Glondu committed
554
555
      check_modulo q challenge &&
      check_modulo q response &&
556
557
558
559
560
      let commitments =
        [|
          g **~ response / (y **~ challenge);
          alpha **~ response / (f **~ challenge);
        |]
561
      in Z.(hash zkp commitments =% challenge)
562
    ) c f.decryption_factors f.decryption_proofs
Stephane Glondu's avatar
Stephane Glondu committed
563

Stephane Glondu's avatar
Stephane Glondu committed
564
  type result = elt Serializable_t.result
Stephane Glondu's avatar
Stephane Glondu committed
565

566
567
  type combinator = factor array -> elt array array

568
  let compute_result num_tallied encrypted_tally partial_decryptions combinator =
569
    let factors = combinator partial_decryptions in
Stephane Glondu's avatar
Stephane Glondu committed
570
    let results = Array.mmap2 (fun {beta; _} f ->
Stephane Glondu's avatar
Stephane Glondu committed
571
572
573
574
575
      beta / f
    ) encrypted_tally factors in
    let log =
      let module GMap = Map.Make(G) in
      let rec loop i cur accu =
Stephane Glondu's avatar
Stephane Glondu committed
576
        if i <= num_tallied
Stephane Glondu's avatar
Stephane Glondu committed
577
578
579
580
581
582
583
584
585
586
        then loop (succ i) (cur *~ g) (GMap.add cur i accu)
        else accu
      in
      let map = loop 0 G.one GMap.empty in
      fun x ->
        try
          GMap.find x map
        with Not_found ->
          invalid_arg "Cannot compute result"
    in
Stephane Glondu's avatar
Stephane Glondu committed
587
    let result = Array.mmap log results in
Stephane Glondu's avatar
Stephane Glondu committed
588
    {num_tallied; encrypted_tally; partial_decryptions; result}
Stephane Glondu's avatar
Stephane Glondu committed
589

590
  let check_result combinator pks r =
Stephane Glondu's avatar
Stephane Glondu committed
591
    let {encrypted_tally; partial_decryptions; result; _} = r in
Stephane Glondu's avatar
Stephane Glondu committed
592
    check_ciphertext encrypted_tally &&
593
    (* decryption factors may be not in the same order as pks! *)
594
595
596
597
    Array.forall (fun pd ->
        Array.exists (fun pk -> check_factor encrypted_tally pk pd) pks
    ) partial_decryptions &&
    let factors = combinator partial_decryptions in
Stephane Glondu's avatar
Stephane Glondu committed
598
599
600
    let results = Array.mmap2 (fun {beta; _} f ->
      beta / f
    ) encrypted_tally factors in
Stephane Glondu's avatar
Stephane Glondu committed
601
    Array.fforall2 (fun r1 r2 -> r1 =~ g **~ Z.of_int r2) results result
Stephane Glondu's avatar
Stephane Glondu committed
602

Stephane Glondu's avatar
Stephane Glondu committed
603
  let extract_tally r = r.result
Stephane Glondu's avatar
Stephane Glondu committed
604
end