booth.ml 12.3 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1
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
77
78
79
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
(*  Copyright © 2012-2014 Inria                                           *)
(*                                                                        *)
(*  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/>.                                       *)
(**************************************************************************)

open Platform
open Serializable_j
open Signatures
open Common

let document = Dom_html.window##document

let withElementById x f =
  Js.Opt.iter (document##getElementById (Js.string x)) f

let alert s : unit =
  let open Js.Unsafe in
  fun_call (variable "alert") [| s |> Js.string |> inject |]

let prompt s =
  let open Js.Unsafe in
  Js.Opt.map
    (fun_call (variable "prompt") [| s |> Js.string |> inject |])
    Js.to_string |> Js.Opt.to_option

let runHandler handler () =
  (try handler ()
   with e ->
     let msg = "Unexpected error: " ^ Printexc.to_string e in
     alert msg
  ); Js._false

let installHandler id handler =
  let f _ = runHandler handler () in
  withElementById id (fun e -> e##onclick <- Dom_html.handler f)

let getTextarea id =
  let res = ref None in
  withElementById id (fun e ->
    Js.Opt.iter
      (Dom_html.CoerceTo.textarea e)
      (fun x -> res := Some (Js.to_string (x##value)))
  );
  match !res with
  | None -> raise Not_found
  | Some x -> x

let setTextarea id z =
  withElementById id (fun e ->
    Js.Opt.iter
      (Dom_html.CoerceTo.textarea e)
      (fun x -> x##value <- Js.string z)
  )

let setNodeById id x =
  withElementById id (fun e ->
    let t = document##createTextNode (Js.string x) in
    Dom.appendChild e t
  )

let setDisplayById id x =
  withElementById id (fun e -> e##style##display <- Js.string x)

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
let prng = lazy (pseudo_rng (random_string secure_rng 16))

module MakeLwtJsMonad (G : GROUP) = struct
  type 'a t = unit -> 'a Lwt.t
  let return x () = Lwt.return x
  let bind x f () = Lwt.bind (x ()) (fun y -> f y ())
  let fail x () = Lwt.fail x

  let random q =
    let size = Z.bit_length q / 8 + 1 in
    fun () ->
      lwt () = Lwt_js.yield () in
      let r = random_string (Lazy.force prng) size in
      Lwt.return Z.(of_bits r mod q)
end

Stephane Glondu's avatar
Stephane Glondu committed
96
97
98
let encryptBallot params cred plaintext () =
  let module P = (val params : ELECTION_PARAMS) in
  let module G = P.G in
99
  let module M = MakeLwtJsMonad (G) in
Stephane Glondu's avatar
Stephane Glondu committed
100
101
102
103
104
105
106
107
108
109
  let module E = Election.MakeElection (G) (M) in
  let e = {
    e_params = P.params;
    e_pks = None;
    e_fingerprint = P.fingerprint;
  } in
  let sk =
    let hex = derive_cred P.params.e_uuid cred in
    Z.(of_string_base 16 hex mod G.q)
  in
110
111
  lwt randomness = E.make_randomness e () in
  lwt b = E.create_ballot e ~sk randomness plaintext () in
Stephane Glondu's avatar
Stephane Glondu committed
112
113
114
  let s = string_of_ballot G.write b in
  setTextarea "ballot" s;
  setNodeById "ballot_tracker" (sha256_b64 s);
115
  setDisplayById "encrypting_div" "none";
Stephane Glondu's avatar
Stephane Glondu committed
116
  setDisplayById "ballot_div" "block";
117
118
  Dom_html.window##onbeforeunload <- Dom_html.no_handler;
  Lwt.return ()
Stephane Glondu's avatar
Stephane Glondu committed
119

Stephane Glondu's avatar
Stephane Glondu committed
120
121
122
123
124
125
let progress_step n =
  let old_ = Printf.sprintf "progress%d" (n-1) in
  let new_ = Printf.sprintf "progress%d" n in
  withElementById old_ (fun e -> e##setAttribute (Js.string "style", Js.string ""));
  withElementById new_ (fun e -> e##setAttribute (Js.string "style", Js.string "font-weight: bold;"))

Stephane Glondu's avatar
Stephane Glondu committed
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
let rec createQuestionNode sk params question_div num_questions i prev (q, answers) next =
  (* Create div element for the current question. [i] and [(q,
     answers)] point to the current question. [List.rev prev @ [q,
     answers] @ next] is the list of all questions. *)
  let div = document##createElement (Js.string "div") in
  let () =
    let c = document##createElement (Js.string "h2") in
    let t = document##createTextNode (Js.string q.q_question) in
    Dom.appendChild c t;
    Dom.appendChild div c
  in
  let () =
    let c = document##createElement (Js.string "div") in
    let s = Printf.sprintf
      "Question #%d of %d — select between %d and %d answer(s)"
      (i + 1) num_questions q.q_min q.q_max
    in
    let t = document##createTextNode (Js.string s) in
    Dom.appendChild c t;
    Dom.appendChild div c
  in
  let () =
    let choices = document##createElement (Js.string "div") in
    Array.iteri (fun i a ->
      let div = document##createElement (Js.string "div") in
      let checkbox = document##createElement (Js.string "input") in
      let cb =
        match Js.Opt.to_option (Dom_html.CoerceTo.input checkbox) with
        | Some x -> x
        | None -> failwith "error while casting checkbox"
      in
      if answers.(i) > 0 then cb##checked <- Js.bool true;
      checkbox##setAttribute (Js.string "type", Js.string "checkbox");
      Dom.appendChild div checkbox;
      let t = document##createTextNode (Js.string a) in
      checkbox##onclick <- Dom_html.handler (fun _ ->
        answers.(i) <- if Js.to_bool cb##checked then 1 else 0;
        Js._true
      );
      Dom.appendChild div t;
      Dom.appendChild choices div
    ) q.q_answers;
    Dom.appendChild div choices
  in
  let check_constraints () =
    let total = Array.fold_left (+) 0 answers in
    if total < q.q_min then (
      Printf.ksprintf alert "You must select at least %d answer(s)" q.q_min;
      false
    ) else if total > q.q_max then (
      Printf.ksprintf alert "You must select at most %d answer(s)" q.q_max;
      false
    ) else true
  in
  let () =
    (* previous button *)
    let btns = document##createElement (Js.string "div") in
Stephane Glondu's avatar
Stephane Glondu committed
183
    btns##setAttribute (Js.string "style", Js.string "text-align: center;");
Stephane Glondu's avatar
Stephane Glondu committed
184
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
    let () =
      match prev with
      | [] ->
        (* first question, no "Previous" button *)
        ()
      | r :: prev ->
        let b = document##createElement (Js.string "button") in
        let t = document##createTextNode (Js.string "Previous") in
        b##onclick <- Dom_html.handler (fun _ ->
          if check_constraints () then (
            let ndiv = createQuestionNode sk params
              question_div num_questions (i - 1) prev r ((q, answers) :: next)
            in
            Dom.replaceChild question_div ndiv div;
            Js._false
          ) else Js._false
        );
        Dom.appendChild b t;
        Dom.appendChild btns b;
    in
    let () =
      (* next button *)
      match next with
      | [] ->
        (* last question, create a "Proceed" button instead of "Next" *)
        let b = document##createElement (Js.string "button") in
        let t = document##createTextNode (Js.string "Proceed") in
        b##onclick <- Dom_html.handler (fun _ ->
212
         if check_constraints () then (
Stephane Glondu's avatar
Stephane Glondu committed
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
          let all = (q, answers) :: prev in
          let all_answers = List.rev_map snd all |> Array.of_list in
          let all_questions = List.rev_map fst all |> Array.of_list in
          setTextarea "choices" (string_of_plaintext all_answers);
          question_div##style##display <- Js.string "none";
          withElementById "pretty_choices" (fun e ->
            Array.iteri (fun i a ->
              let q = all_questions.(i) in
              let h = document##createElement (Js.string "h3") in
              let t = document##createTextNode (Js.string q.q_question) in
              Dom.appendChild h t;
              Dom.appendChild e h;
              let ul = document##createElement (Js.string "ul") in
              Array.iteri (fun i a ->
                if a > 0 then (
                  let li = document##createElement (Js.string "li") in
                  let t = document##createTextNode (Js.string q.q_answers.(i)) in
                  Dom.appendChild li t;
                  Dom.appendChild ul li;
                )
              ) a;
              Dom.appendChild e ul;
            ) all_answers
          );
237
          Lwt_js_events.async (encryptBallot params sk all_answers);
Stephane Glondu's avatar
Stephane Glondu committed
238
          setDisplayById "plaintext_div" "block";
Stephane Glondu's avatar
Stephane Glondu committed
239
          progress_step 3;
Stephane Glondu's avatar
Stephane Glondu committed
240
          Js._false
241
         ) else Js._false
Stephane Glondu's avatar
Stephane Glondu committed
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
        );
        Dom.appendChild b t;
        Dom.appendChild btns b
      | r :: next ->
        let b = document##createElement (Js.string "button") in
        let t = document##createTextNode (Js.string "Next") in
        b##onclick <- Dom_html.handler (fun _ ->
          if check_constraints () then (
            let ndiv = createQuestionNode sk params
              question_div num_questions (i + 1) ((q, answers) :: prev) r next
            in
            Dom.replaceChild question_div ndiv div;
            Js._false
          ) else Js._false
        );
        Dom.appendChild b t;
        Dom.appendChild btns b;
    in
    Dom.appendChild div btns
  in
  div

let addQuestions sk params qs =
  withElementById "question_div" (fun e ->
    let n = Array.length qs in
    let qs =
      Array.to_list qs |>
      List.map (fun q -> q, Array.create (Array.length q.q_answers) 0)
    in
    match qs with
    | [] -> failwith "no questions"
    | q :: next ->
      let div = createQuestionNode sk params e n 0 [] q next in
      Dom.appendChild e div
  )

let createStartButton params intro_div qs =
Stephane Glondu's avatar
Stephane Glondu committed
279
280
  let div = Dom_html.createDiv document in
  div##setAttribute (Js.string "style", Js.string "text-align:center;");
Stephane Glondu's avatar
Stephane Glondu committed
281
282
283
284
285
286
287
288
289
  let b = document##createElement (Js.string "button") in
  let t = document##createTextNode (Js.string "Start") in
  b##onclick <- Dom_html.handler (fun _ ->
    (match prompt "Please enter your credential:" with
    | Some cred ->
      intro_div##style##display <- Js.string "none";
      Dom_html.window##onbeforeunload <- Dom_html.handler (fun _ ->
        Js._false
      );
Stephane Glondu's avatar
Stephane Glondu committed
290
      progress_step 2;
Stephane Glondu's avatar
Stephane Glondu committed
291
292
293
294
295
296
      addQuestions cred params qs
    | None -> ()
    );
    Js._false
  );
  Dom.appendChild b t;
Stephane Glondu's avatar
Stephane Glondu committed
297
298
  Dom.appendChild div b;
  div
Stephane Glondu's avatar
Stephane Glondu committed
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

let drop_trailing_newline s =
  let n = String.length s in
  if n > 0 && s.[n-1] = '\n' then String.sub s 0 (n-1) else s

let loadElection () =
  setDisplayById "election_loader" "none";
  setDisplayById "booth_div" "block";
  let election_raw = getTextarea "election_params" |> drop_trailing_newline in
  let election_params = Group.election_params_of_string election_raw in
  let module P = (val election_params : ELECTION_PARAMS) in
  setNodeById "election_name" P.params.e_name;
  setNodeById "election_description" P.params.e_description;
  setNodeById "election_uuid" (Uuidm.to_string P.params.e_uuid);
  setNodeById "election_fingerprint" P.fingerprint;
  withElementById "intro" (fun e ->
    let b = createStartButton election_params e P.params.e_questions in
    Dom.appendChild e b
  )

let split str prefix =
  let n = String.length str in
  let p = String.length prefix in
  if p <= n && String.sub str 0 p = prefix then
    Some (String.sub str p (n-p))
  else None

let () =
  Dom_html.window##onload <- Dom_html.handler (fun _ ->
    let s = Js.to_string Dom_html.window##location##search in
    (match split s "?election_url=" with
    | Some url ->
      let url = Url.urldecode url in
      withElementById "ballot_form" (fun e ->
        Js.Opt.iter
          (Dom_html.CoerceTo.form e)
          (fun e -> e##action <- Js.string (url ^ "cast"))
      );
      let open XmlHttpRequest in
      Lwt.async (fun () ->
        lwt raw = get (url ^ "election.json") in
        let () = setTextarea "election_params" raw.content in
        Lwt.return (runHandler loadElection ())
      )
    | None ->
      setDisplayById "election_loader" "block";
      installHandler "load_election" loadElection;
    );
    Js._false
  )