crypto.ml 7.51 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1
open Util
Stephane Glondu's avatar
Stephane Glondu committed
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

(** Helper functions *)

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

let hashZ x = Cryptokit.(x |>
  hash_string (Hash.sha1 ()) |>
  transform_string (Hexa.encode ()) |>
  Z.of_string_base 16
)

let map_and_concat_with_commas f xs =
  let n = Array.length xs in
  let res = Buffer.create (n * 1024) in
  for i = 0 to n-1 do
    Buffer.add_string res (f xs.(i));
    Buffer.add_char res ',';
  done;
  let size = Buffer.length res - 1 in
  if size > 0 then Buffer.sub res 0 size else ""

(** Finite field arithmetic *)

let finite_field ~p ~q ~g =
  if
    Z.probab_prime p 10 > 0 &&
    Z.probab_prime q 10 > 0 &&
    check_modulo p g &&
    check_modulo p q &&
    Z.(powm g q p =% one)
  then
    let module G = struct
      open Z
      type t = Z.t
      let q = q
      let one = Z.one
      let g = g
      let ( *~ ) a b = a * b mod p
      let ( **~ ) a b = powm a b p
      let invert x = invert x p
      let ( =~ ) = equal
      let check x = check_modulo p x && x **~ q =~ one
      let hash xs = hashZ (map_and_concat_with_commas Z.to_string xs)
Stephane Glondu's avatar
Stephane Glondu committed
45
      let compare = Z.compare
Stephane Glondu's avatar
Stephane Glondu committed
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
    end in (module G : Crypto_sigs.GROUP with type t = Z.t)
  else
    invalid_arg "Invalid parameters for a multiplicative subgroup of finite field"

(** Homomorphic elections *)

module MakeHomomorphicElection (P : Crypto_sigs.ELECTION_PARAMS) = struct
  open Serializable_t
  open P
  open G
  type private_key = Z.t
  type public_key = G.t

  let election_params = params
  let y = params.e_public_key
  let ( / ) x y = x *~ invert y

  type ciphertext = public_key Serializable_t.ciphertext array array

  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;
    }

78
  let combine_ciphertexts = Array.mmap2 eg_combine
Stephane Glondu's avatar
Stephane Glondu committed
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

  type plaintext = int array array
  type ballot = public_key Serializable_t.ballot
  type randomness = Z.t array array

  (** ElGamal encryption. *)
  let eg_encrypt r x =
    {
      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 =
    let w = random q in
    let commitments = Array.map (fun g -> g **~ w) gs in
    let challenge = oracle commitments in
    let response = Z.((w + x * challenge) mod q) in
    {challenge; response}

  (** ZKPs for disjunctions *)

  let eg_disj_prove d x r {alpha; beta} =
    (* 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);
    let proofs = Array.create n dummy_proof
    and commitments = Array.create (2*n) g
    and total_challenges = ref Z.zero in
    (* compute fake proofs *)
    let f i =
      let challenge = random q
      and response = random q in
      proofs.(i) <- {challenge; response};
      commitments.(2*i) <- g **~ response / alpha **~ challenge;
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
123
      commitments.(2*i+1) <- y **~ response / (beta *~ d.(i)) **~ challenge;
Stephane Glondu's avatar
Stephane Glondu committed
124
125
126
127
128
129
      total_challenges := Z.(!total_challenges + challenge);
    in
    for i = 0 to x-1 do f i done;
    for i = x+1 to n-1 do f i done;
    total_challenges := Z.(q - !total_challenges mod q);
    (* compute genuine proof *)
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
130
    proofs.(x) <- fs_prove [| g; y |] r (fun commitx ->
Stephane Glondu's avatar
Stephane Glondu committed
131
132
133
134
135
136
      Array.blit commitx 0 commitments (2*x) 2;
      Z.((G.hash commitments + !total_challenges) mod q)
    );
    proofs

  let eg_disj_verify d proofs {alpha; beta} =
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
137
    G.check alpha && G.check beta &&
Stephane Glondu's avatar
Stephane Glondu committed
138
    let n = Array.length d in
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
139
    n = Array.length proofs &&
Stephane Glondu's avatar
Stephane Glondu committed
140
141
    let commitments = Array.create (2*n) g
    and total_challenges = ref Z.zero in
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
142
143
144
145
146
147
148
149
150
151
152
153
    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);
      hash commitments =% !total_challenges
    with Exit -> false
Stephane Glondu's avatar
Stephane Glondu committed
154
155
156
157
158
159

  (** Ballot creation *)

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

Stephane Glondu's avatar
Debug    
Stephane Glondu committed
160
161
162
163
164
165
166
167
  let make_d min max =
    let n = max - min + 1 in
    let d = Array.create n (invert (g **~ Z.of_int min)) in
    for i = 1 to n-1 do
      d.(i) <- d.(i-1) *~ invg
    done;
    d

Stephane Glondu's avatar
Stephane Glondu committed
168
  let create_answer q r m =
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
169
170
    let choices = Array.map2 eg_encrypt r m in
    let individual_proofs = Array.map3 (eg_disj_prove d01) m r choices in
Stephane Glondu's avatar
Stephane Glondu committed
171
172
173
174
175
176
    (* create overall_proof from homomorphic combination of individual
       weights *)
    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);
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
177
178
    let d = make_d q.q_min q.q_max in
    let overall_proof = eg_disj_prove d (summ - q.q_min) sumr sumc in
Stephane Glondu's avatar
Stephane Glondu committed
179
180
    {choices; individual_proofs; overall_proof}

181
182
183
184
185
  let create_randomness () =
    Array.map (fun q ->
      Array.init (Array.length q.q_answers) (fun _ -> random G.q)
    ) params.e_questions

Stephane Glondu's avatar
Stephane Glondu committed
186
187
  let create_ballot r m =
    {
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
188
      answers = Array.map3 create_answer params.e_questions r m;
Stephane Glondu's avatar
Stephane Glondu committed
189
190
191
192
193
194
195
196
197
      election_hash = fingerprint;
      election_uuid = params.e_uuid
    }

  (** Ballot verification *)

  let verify_answer q a =
    Array.forall2 (eg_disj_verify d01) a.individual_proofs a.choices &&
    let sumc = Array.fold_left eg_combine dummy_ciphertext a.choices in
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
198
    let d = make_d q.q_min q.q_max in
Stephane Glondu's avatar
Stephane Glondu committed
199
200
201
    eg_disj_verify d a.overall_proof sumc

  let check_ballot b =
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
202
203
    b.election_uuid = params.e_uuid &&
    b.election_hash = P.fingerprint &&
Stephane Glondu's avatar
Stephane Glondu committed
204
205
206
207
208
209
    Array.forall2 verify_answer params.e_questions b.answers

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

  type factor = public_key Serializable_t.partial_decryption

210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
  let eg_factor x {alpha; beta} =
    alpha **~ x,
    fs_prove [| g; alpha |] x hash

  let compute_factor c x =
    let res = Array.mmap (eg_factor x) c in
    let decryption_factors, decryption_proofs = Array.ssplit res in
    {decryption_factors; decryption_proofs}

  let check_factor c y f =
    Array.fforall3 (fun {alpha; _} f {challenge; response} ->
      let commitments =
        [|
          g **~ response / (y **~ challenge);
          alpha **~ response / (f **~ challenge);
        |]
      in hash commitments =% challenge
    ) c f.decryption_factors f.decryption_proofs
Stephane Glondu's avatar
Stephane Glondu committed
228
229
230

  type result = public_key Serializable_t.result

Stephane Glondu's avatar
Stephane Glondu committed
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
  let combine_factors nb_tallied encrypted_tally partial_decryptions =
    let dummy = Array.mmap (fun _ -> G.one) encrypted_tally in
    let factors = Array.fold_left (fun a b ->
      Array.mmap2 ( *~ ) a b.decryption_factors
    ) dummy partial_decryptions in
    let exp_results = Array.mmap2 (fun {beta; _} f ->
      beta / f
    ) encrypted_tally factors in
    let log =
      let module GMap = Map.Make(G) in
      let rec loop i cur accu =
        if i < nb_tallied
        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
    let result = Array.mmap log exp_results in
    {nb_tallied; encrypted_tally; partial_decryptions; result}
Stephane Glondu's avatar
Stephane Glondu committed
255

Stephane Glondu's avatar
Debug    
Stephane Glondu committed
256
  let check_result r = assert false
Stephane Glondu's avatar
Stephane Glondu committed
257

Stephane Glondu's avatar
Stephane Glondu committed
258
  let extract_tally r = r.result
Stephane Glondu's avatar
Stephane Glondu committed
259
end