crypto.ml 6.71 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
45
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

(** 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)
    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;
    }

77
  let combine_ciphertexts = Array.mmap2 eg_combine
Stephane Glondu's avatar
Stephane Glondu committed
78
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

  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
122
      commitments.(2*i+1) <- y **~ response / (beta *~ d.(i)) **~ challenge;
Stephane Glondu's avatar
Stephane Glondu committed
123
124
125
126
127
128
      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
129
    proofs.(x) <- fs_prove [| g; y |] r (fun commitx ->
Stephane Glondu's avatar
Stephane Glondu committed
130
131
132
133
134
135
      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
136
    G.check alpha && G.check beta &&
Stephane Glondu's avatar
Stephane Glondu committed
137
    let n = Array.length d in
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
138
    n = Array.length proofs &&
Stephane Glondu's avatar
Stephane Glondu committed
139
140
    let commitments = Array.create (2*n) g
    and total_challenges = ref Z.zero in
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
141
142
143
144
145
146
147
148
149
150
151
152
    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
153
154
155
156
157
158

  (** Ballot creation *)

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

Stephane Glondu's avatar
Debug    
Stephane Glondu committed
159
160
161
162
163
164
165
166
  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
167
  let create_answer q r m =
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
168
169
    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
170
171
172
173
174
175
    (* 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
176
177
    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
178
179
    {choices; individual_proofs; overall_proof}

180
181
182
183
184
  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
185
186
  let create_ballot r m =
    {
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
187
      answers = Array.map3 create_answer params.e_questions r m;
Stephane Glondu's avatar
Stephane Glondu committed
188
189
190
191
192
193
194
195
196
      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
197
    let d = make_d q.q_min q.q_max in
Stephane Glondu's avatar
Stephane Glondu committed
198
199
200
    eg_disj_verify d a.overall_proof sumc

  let check_ballot b =
Stephane Glondu's avatar
Debug    
Stephane Glondu committed
201
202
    b.election_uuid = params.e_uuid &&
    b.election_hash = P.fingerprint &&
Stephane Glondu's avatar
Stephane Glondu committed
203
204
205
206
207
208
    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

209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
  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
227
228
229

  type result = public_key Serializable_t.result

Stephane Glondu's avatar
Debug    
Stephane Glondu committed
230
  let combine_factors nb_tallied c fs = assert false
Stephane Glondu's avatar
Stephane Glondu committed
231

Stephane Glondu's avatar
Debug    
Stephane Glondu committed
232
  let check_result r = assert false
Stephane Glondu's avatar
Stephane Glondu committed
233

Stephane Glondu's avatar
Debug    
Stephane Glondu committed
234
  let extract_tally r = assert false
Stephane Glondu's avatar
Stephane Glondu committed
235
end