booth.ml 13.9 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2018 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 22
(*                                                                        *)
(*  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
23
open Serializable_builtin_t
Stephane Glondu's avatar
Stephane Glondu committed
24 25 26 27 28 29 30 31 32
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

33 34 35
let getHtmlById x =
  let r = ref x in
  withElementById x (fun x ->
36
    Js.Opt.iter (x##textContent) (fun x -> r := Js.to_string x)
37 38
  ); !r

Stephane Glondu's avatar
Stephane Glondu committed
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 80 81 82 83 84 85 86
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)

87 88
let prng = lazy (pseudo_rng (random_string secure_rng 16))

Stephane Glondu's avatar
Stephane Glondu committed
89
module LwtJsRandom = struct
90 91 92 93 94 95 96 97 98 99 100 101 102
  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
103
let encryptBallot params cred plaintext () =
Stephane Glondu's avatar
Stephane Glondu committed
104
  let module P = (val params : ELECTION_DATA) in
Stephane Glondu's avatar
Stephane Glondu committed
105
  let module G = P.G in
106
  let module E = Election.Make (P) (LwtJsRandom) in
107 108
  let module CD = Credential.MakeDerive (G) in
  let sk = CD.derive P.election.e_params.e_uuid cred in
109 110
  lwt randomness = E.make_randomness () () in
  lwt b = E.create_ballot ~sk randomness plaintext () in
Stephane Glondu's avatar
Stephane Glondu committed
111 112 113
  let s = string_of_ballot G.write b in
  setTextarea "ballot" s;
  setNodeById "ballot_tracker" (sha256_b64 s);
114
  setDisplayById "encrypting_div" "none";
Stephane Glondu's avatar
Stephane Glondu committed
115
  setDisplayById "ballot_div" "block";
116 117
  Dom_html.window##onbeforeunload <- Dom_html.no_handler;
  Lwt.return ()
Stephane Glondu's avatar
Stephane Glondu committed
118

Stephane Glondu's avatar
Stephane Glondu committed
119 120 121 122 123 124
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
125 126 127 128 129 130 131 132 133 134 135 136 137
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
138 139 140 141
    let fmt = Scanf.format_from_string
      (getHtmlById "question_header") "%d%d%d%d"
    in
    let s = Printf.sprintf fmt
Stephane Glondu's avatar
Stephane Glondu committed
142 143 144 145 146 147
      (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
148
  let q_answers = match q.q_blank with
149
    | Some true -> Array.append [|getHtmlById "str_blank_vote"|] q.q_answers
150 151
    | _ -> q.q_answers
  in
Stephane Glondu's avatar
Stephane Glondu committed
152 153
  let () =
    let choices = document##createElement (Js.string "div") in
154
    let choices_divs = Array.mapi (fun i a ->
Stephane Glondu's avatar
Stephane Glondu committed
155 156 157 158 159 160 161 162 163
      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");
Stephane Glondu's avatar
Stephane Glondu committed
164
      checkbox##setAttribute (Js.string "style", Js.string "cursor: pointer;");
Stephane Glondu's avatar
Stephane Glondu committed
165 166 167 168 169 170 171
      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;
172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
      div
    ) q_answers
    in
    begin match q.q_blank with
    | Some true ->
       for i = 1 to Array.length choices_divs - 1 do
         Dom.appendChild choices choices_divs.(i)
       done;
       (* Put the blank choice at the end of the list *)
       Dom.appendChild choices (Dom_html.createBr document);
       Dom.appendChild choices choices_divs.(0)
    | _ ->
       for i = 0 to Array.length choices_divs - 1 do
         Dom.appendChild choices choices_divs.(i)
       done
    end;
Stephane Glondu's avatar
Stephane Glondu committed
188 189 190
    Dom.appendChild div choices
  in
  let check_constraints () =
191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
    let check_min_max total =
      if total < q.q_min then (
        let fmt = Scanf.format_from_string (getHtmlById "at_least") "%d" in
        Printf.ksprintf alert fmt q.q_min;
        false
      ) else if total > q.q_max then (
        let fmt = Scanf.format_from_string (getHtmlById "at_most") "%d" in
        Printf.ksprintf alert fmt q.q_max;
        false
      ) else true
    in
    match q.q_blank with
    | Some true ->
       let answers' = Array.sub answers 1 (Array.length answers - 1) in
       let total = Array.fold_left (+) 0 answers' in
       if answers.(0) > 0 then (
         if total <> 0 then
208
           (alert (getHtmlById "no_other_blank"); false)
209 210 211 212 213
         else true
       ) else check_min_max total
    | _ ->
       let total = Array.fold_left (+) 0 answers in
       check_min_max total
Stephane Glondu's avatar
Stephane Glondu committed
214 215 216 217
  in
  let () =
    (* previous button *)
    let btns = document##createElement (Js.string "div") in
Stephane Glondu's avatar
Stephane Glondu committed
218
    btns##setAttribute (Js.string "style", Js.string "text-align: center;");
Stephane Glondu's avatar
Stephane Glondu committed
219 220 221 222 223 224 225
    let () =
      match prev with
      | [] ->
        (* first question, no "Previous" button *)
        ()
      | r :: prev ->
        let b = document##createElement (Js.string "button") in
226
        let t = document##createTextNode (Js.string @@ getHtmlById "str_previous") in
Stephane Glondu's avatar
Stephane Glondu committed
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
        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
      | [] ->
243
        (* last question, the button leads to encryption page *)
Stephane Glondu's avatar
Stephane Glondu committed
244
        let b = document##createElement (Js.string "button") in
245
        let t = document##createTextNode (Js.string @@ getHtmlById "str_next") in
Stephane Glondu's avatar
Stephane Glondu committed
246
        b##onclick <- Dom_html.handler (fun _ ->
247
         if check_constraints () then (
Stephane Glondu's avatar
Stephane Glondu committed
248 249 250 251 252 253 254 255 256 257 258 259 260
          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
261
              let checked = ref 0 in
Stephane Glondu's avatar
Stephane Glondu committed
262 263
              Array.iteri (fun i a ->
                if a > 0 then (
264
                  incr checked;
Stephane Glondu's avatar
Stephane Glondu committed
265
                  let li = document##createElement (Js.string "li") in
266
                  let text = match q.q_blank with
267
                    | Some true -> if i = 0 then getHtmlById "str_blank_vote" else q.q_answers.(i-1)
268 269 270
                    | _ -> q.q_answers.(i)
                  in
                  let t = document##createTextNode (Js.string text) in
Stephane Glondu's avatar
Stephane Glondu committed
271 272 273 274
                  Dom.appendChild li t;
                  Dom.appendChild ul li;
                )
              ) a;
275
              if !checked = 0 then (
276
                let t = document##createTextNode (Js.string @@ getHtmlById "str_nothing") in
277 278
                Dom.appendChild ul t
              );
Stephane Glondu's avatar
Stephane Glondu committed
279 280 281
              Dom.appendChild e ul;
            ) all_answers
          );
282
          Lwt_js_events.async (encryptBallot params sk all_answers);
Stephane Glondu's avatar
Stephane Glondu committed
283
          setDisplayById "plaintext_div" "block";
Stephane Glondu's avatar
Stephane Glondu committed
284
          progress_step 3;
Stephane Glondu's avatar
Stephane Glondu committed
285
          Js._false
286
         ) else Js._false
Stephane Glondu's avatar
Stephane Glondu committed
287 288 289 290 291
        );
        Dom.appendChild b t;
        Dom.appendChild btns b
      | r :: next ->
        let b = document##createElement (Js.string "button") in
292
        let t = document##createTextNode (Js.string @@ getHtmlById "str_next") in
Stephane Glondu's avatar
Stephane Glondu committed
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
        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 |>
314
      List.map (fun q -> q, Array.make (Election.question_length q) 0)
Stephane Glondu's avatar
Stephane Glondu committed
315 316 317 318 319 320 321 322 323 324
    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 =
  let b = document##createElement (Js.string "button") in
325
  b##setAttribute (Js.string "style", Js.string "font-size:20px;");
326
  let t = document##createTextNode (Js.string (getHtmlById "str_here")) in
Stephane Glondu's avatar
Stephane Glondu committed
327
  b##onclick <- Dom_html.handler (fun _ ->
328
    (match prompt (getHtmlById "enter_cred") with
329
    | Some cred when Credential.check cred ->
Stephane Glondu's avatar
Stephane Glondu committed
330
      intro_div##style##display <- Js.string "none";
331
      setDisplayById "question_div" "block";
Stephane Glondu's avatar
Stephane Glondu committed
332 333 334
      Dom_html.window##onbeforeunload <- Dom_html.handler (fun _ ->
        Js._false
      );
Stephane Glondu's avatar
Stephane Glondu committed
335
      progress_step 2;
Stephane Glondu's avatar
Stephane Glondu committed
336
      addQuestions cred params qs
337
    | Some _ ->
338
       alert (getHtmlById "invalid_cred")
Stephane Glondu's avatar
Stephane Glondu committed
339 340 341 342 343
    | None -> ()
    );
    Js._false
  );
  Dom.appendChild b t;
344
  b
Stephane Glondu's avatar
Stephane Glondu committed
345 346 347 348 349 350 351 352 353

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
354
  let election_params = Election.(get_group (of_string election_raw)) in
Stephane Glondu's avatar
Stephane Glondu committed
355 356 357 358
  let module P = (val election_params : ELECTION_DATA) in
  let params = P.election.e_params in
  setNodeById "election_name" params.e_name;
  setNodeById "election_description" params.e_description;
359
  setNodeById "election_uuid" (raw_string_of_uuid params.e_uuid);
Stephane Glondu's avatar
Stephane Glondu committed
360
  setNodeById "election_fingerprint" P.election.e_fingerprint;
Stephane Glondu's avatar
Stephane Glondu committed
361
  withElementById "intro" (fun e ->
Stephane Glondu's avatar
Stephane Glondu committed
362
    let b = createStartButton election_params e params.e_questions in
363
    withElementById "input_code" (fun e -> Dom.appendChild e b)
Stephane Glondu's avatar
Stephane Glondu committed
364 365
  )

366
let get_prefix str =
Stephane Glondu's avatar
Stephane Glondu committed
367
  let n = String.length str in
368
  if n >= 4 then String.sub str 0 (n-4) else str
Stephane Glondu's avatar
Stephane Glondu committed
369 370 371

let () =
  Dom_html.window##onload <- Dom_html.handler (fun _ ->
372 373 374 375 376 377 378 379 380 381 382 383
    let s = Js.to_string Dom_html.window##location##pathname in
    let url = get_prefix s 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 ())
Stephane Glondu's avatar
Stephane Glondu committed
384 385 386
    );
    Js._false
  )