Commit d6d8fe47 authored by Stephane Glondu's avatar Stephane Glondu
Browse files

New experimental booth

parent 48f77bf8
......@@ -2,4 +2,5 @@
<src/platform/native/*>: package(zarith), package(calendar), package(cryptokit)
<src/web/*.{ml,mli,byte,native,odoc}>: thread, package(eliom.server), syntax(camlp4o), package(lwt.syntax), package(csv)
<src/tool/tool_cmdline.*>: package(zarith), package(calendar), package(cryptokit), package(cmdliner), use_platform-native
<src/tool/tool_js.*> or <src/platform/js/*>: package(js_of_ocaml), syntax(camlp4o), package(js_of_ocaml.syntax), use_platform-js
<src/tool/tool_js.*> or <src/platform/js/*> or <src/booth/*>: package(js_of_ocaml), syntax(camlp4o), package(js_of_ocaml.syntax), use_platform-js
<src/booth/*>: package(lwt.syntax)
......@@ -2,3 +2,4 @@ minimal.otarget
src/lib/lib.cma
src/web/server.cma
src/tool/belenios-tool.html.otarget
src/booth/vote.html.otarget
......@@ -86,6 +86,7 @@ let () = dispatch & function
Pathname.define_context "src/web" ["src/lib"];
Pathname.define_context "src/tool" ["src/lib"];
Pathname.define_context "src/booth" ["src/lib"];
Pathname.define_context "demo" ["src/lib"];
Pathname.define_context "stuff" ["src/lib"];
Pathname.define_context "." ["src/lib"];
......@@ -112,6 +113,8 @@ let () = dispatch & function
copy_rule "belenios-tool" ("src/tool/tool_cmdline" ^ exe_suffix) "belenios-tool";
List.iter (copy_ext_js_rule "src/tool") ["jsbn.js"; "jsbn2.js"; "sjcl.js"];
List.iter (copy_ext_js_rule "src/booth") ["jsbn.js"; "jsbn2.js"; "sjcl.js"];
copy_platform_js_rule "src/tool" "random.js";
copy_platform_js_rule "src/booth" "random.js";
| _ -> ()
(**************************************************************************)
(* 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)
let encryptBallot params cred plaintext () =
let module P = (val params : ELECTION_PARAMS) in
let module G = P.G in
let module M = Election.MakeSimpleMonad (G) in
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
let b = E.create_ballot e ~sk (E.make_randomness e ()) plaintext () in
let s = string_of_ballot G.write b in
setTextarea "ballot" s;
setNodeById "ballot_tracker" (sha256_b64 s);
setDisplayById "ballot_div" "block";
Dom_html.window##onbeforeunload <- Dom_html.no_handler
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
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 _ ->
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
);
installHandler "encrypt" (encryptBallot params sk all_answers);
setDisplayById "plaintext_div" "block";
Js._false
);
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 =
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
);
addQuestions cred params qs
| None -> ()
);
Js._false
);
Dom.appendChild b t;
b
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
)
<!DOCTYPE html>
<html xmlns="http://www.w3.org/1999/xhtml" dir="ltr" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html;charset=utf-8">
<title>Belenios Booth</title>
<script src="sjcl.js"></script>
<script src="jsbn.js"></script>
<script src="jsbn2.js"></script>
<script src="random.js"></script>
<script src="booth.js"></script>
</head>
<body>
<div id="election_loader" style="display:none;">
<h1>Election loader</h1>
Election parameters:
<div><textarea id="election_params" rows="1" cols="80"></textarea></div>
<div><button id="load_election">Load election</button></div>
</div>
<div id="booth_div" style="display:none;">
<div align="center">
<h1 id="election_name"></h1>
<p id="election_description"></p>
<div>
<div>Election UUID: <span id="election_uuid"></span></div>
<div>Election Fingerprint: <span id="election_fingerprint"></span></div>
</div>
</div>
<div id="intro">
<p>To cast a vote, you will be led through the following steps. If you have not yet logged in, you will be asked to do so at the very end of the process.</p>
<ol>
<li><b>Enter</b> your credential.</li>
<li>
<b>Select</b> your options.
<div>Answer the questions, and review your choices.</div>
</li>
<li>
<b>Encrypt</b> your selection.
<div>Your selection is encrypted safely inside your browser.</div>
<div>A smart ballot tracker is given to let you track your ballot.</div>
</li>
<li>
<b>Submit</b> your encrypted ballot.
<div>Proceed to log in and cast your encrypted ballot for tallying.</div>
</li>
</ol>
</div>
<div id="question_div"></div>
<div id="plaintext_div" style="display:none;">
<h2>Review your ballot</h2>
<div id="pretty_choices"></div>
<div style="display:none;">
Plaintext raw ballot:
<div><textarea id="choices" rows="1" cols="80" readonly="readonly"></textarea></div>
</div>
<div><button id="encrypt">Confirm and encrypt</button></div>
<div id="ballot_div" style="display:none;">
<form id="ballot_form" method="POST">
<div style="display:none;">
Encrypted ballot:
<div>
<textarea id="ballot" rows="1" cols="80" name="encrypted_vote" readonly="readonly"></textarea>
</div>
</div>
<p>
Your ballot has been successfully encrypted!
Your smart ballot tracker is <span id="ballot_tracker"></span>.
Refresh this page to start again from the beginning.
</p>
<input type="submit" value="Submit"/>
</form>
</div>
</div>
</div>
</body>
</html>
sjcl.js
jsbn.js
jsbn2.js
random.js
booth.js
vote.html
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment