web_templates.ml 48.8 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2014 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
(*                                                                        *)
(*  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/>.                                       *)
(**************************************************************************)

22
open Lwt
23
open Serializable_j
Stephane Glondu's avatar
Stephane Glondu committed
24
open Signatures
Stephane Glondu's avatar
Stephane Glondu committed
25
open Common
26
open Web_serializable_j
27
open Web_signatures
28
open Web_common
29
open Web_services
Stephane Glondu's avatar
Stephane Glondu committed
30 31
open Eliom_content.Html5.F

Stephane Glondu's avatar
Stephane Glondu committed
32
(* TODO: these pages should be redesigned *)
Stephane Glondu's avatar
Stephane Glondu committed
33

Stephane Glondu's avatar
Stephane Glondu committed
34
let site_title = "Election Server"
Stephane Glondu's avatar
Stephane Glondu committed
35
let welcome_message = "Welcome to the Belenios system!"
36
let admin_background = " background: #FF9999;"
Stephane Glondu's avatar
Stephane Glondu committed
37

38 39
let format_user ~site u =
  em [pcdata (if site then string_of_user u else u.user_name)]
40

41 42
let make_login_box ~site auth links =
  let style = if site then admin_background else "" in
43
  let style = "float: right; text-align: right;" ^ style in
44
  let module S = (val auth : AUTH_SERVICES) in
45
  let module L = (val links : AUTH_LINKS) in
46
  lwt user = S.get_user () in
47
  lwt auth_systems = S.get_auth_systems () in
48
  return @@ div ~a:[a_style style] (
49 50 51 52 53
    match user with
    | Some user ->
      [
        div [
          pcdata "Logged in as ";
54
          format_user ~site user;
55 56 57
          pcdata ".";
        ];
        div [
Stephane Glondu's avatar
Stephane Glondu committed
58
          a ~a:[a_id "logout"] ~service:L.logout [pcdata "Log out"] ();
59 60 61 62
          pcdata ".";
        ];
      ]
    | None ->
63
       if site then
64 65 66 67
      [
        div [
          pcdata "Not logged in.";
        ];
68
        let auth_systems =
69
          auth_systems |>
70
          List.map (fun name ->
Stephane Glondu's avatar
Stephane Glondu committed
71 72
            a ~a:[a_id ("login_" ^ name)]
              ~service:(L.login (Some name)) [pcdata name] ()
73 74
          ) |> list_join (pcdata ", ")
        in
75
        div (
76
          [pcdata "Log in: ["] @ auth_systems @ [pcdata "]"]
77 78
        );
      ]
79
        else []
80 81
  )

82 83
module Site_links = struct
  let login x = Eliom_service.preapply site_login x
Stephane Glondu's avatar
Stephane Glondu committed
84
  let logout = Eliom_service.preapply logout ()
85 86
end

87
module Site_auth = struct
Stephane Glondu's avatar
Stephane Glondu committed
88 89 90 91
  let get_user () = Web_auth_state.get_site_user ()
  let get_auth_systems () =
    lwt l = Web_auth_state.get_config None in
    return (List.map fst l)
92 93
end

94
let site_links = (module Site_links : AUTH_LINKS)
95
let site_auth = (module Site_auth : AUTH_SERVICES)
96

97
let site_login_box () =
98
  make_login_box ~site:true site_auth site_links
99

100 101 102 103 104 105
let belenios_url = Eliom_service.Http.external_service
  ~prefix:"http://belenios.gforge.inria.fr"
  ~path:[]
  ~get_params:Eliom_parameter.unit
  ()

106 107 108 109 110 111 112 113
let base ~title ~login_box ~content ?(footer = div []) ?uuid () =
  let administer =
    match uuid with
    | None ->
       a ~service:admin [pcdata "Administer elections"] ()
    | Some uuid ->
       a ~service:election_admin [pcdata "Administer this election"] (uuid, ())
  in
114 115 116 117 118 119 120 121 122 123 124
  Lwt.return (html ~a:[a_dir `Ltr; a_xml_lang "en"]
    (head (Eliom_content.Html5.F.title (pcdata title)) [
      script (pcdata "window.onbeforeunload = function () {};");
      link ~rel:[`Stylesheet] ~href:(uri_of_string (fun () -> "/static/site.css")) ();
    ])
    (body [
      div ~a:[a_id "wrapper"] [
      div ~a:[a_id "header"] [
        div [
          div ~a:[a_style "float: left;"] [
            a ~service:home [pcdata site_title] ();
Stephane Glondu's avatar
Stephane Glondu committed
125
          ];
126 127
          login_box;
          div ~a:[a_style "clear: both;"] [];
Stephane Glondu's avatar
Stephane Glondu committed
128
        ];
129
        h1 ~a:[a_style "text-align: center;"] [pcdata title];
Stephane Glondu's avatar
Stephane Glondu committed
130
      ];
131 132 133 134 135
      div ~a:[a_id "main"] content;
      div ~a:[a_id "footer"; a_style "text-align: center;" ] [
        div ~a:[a_id "bottom"] [
          footer;
          pcdata "Powered by ";
136 137 138
          a ~service:belenios_url [pcdata "Belenios"] ();
          pcdata ". ";
          a ~service:source_code [pcdata "Get the source code"] ();
139
          pcdata ". ";
140
          administer;
141
          pcdata ".";
142
        ]
143 144 145 146
      ]]
     ]))

let format_election kind election =
147
  let module W = (val election : ELECTION_DATA) in
148 149 150 151 152 153 154 155 156 157 158 159 160
  let e = W.election.e_params in
  let service =
    match kind with
    | `Home -> election_home
    | `Admin -> election_admin
  in
  li [
    h3 [
      a ~service [pcdata e.e_name] (e.e_uuid, ());
    ];
    p [pcdata e.e_description];
  ]

161
let home () =
162 163 164 165 166 167
  let loria = Eliom_service.Http.external_service
    ~prefix:"http://www.loria.fr"
    ~path:[]
    ~get_params:Eliom_parameter.unit
    ()
  in
168 169
  let content = [
    div [
Stephane Glondu's avatar
Stephane Glondu committed
170 171
      h2 ~a:[a_style "text-align:center;"] [pcdata welcome_message];
      h3 [a ~service:admin [pcdata "Administer elections"] ()];
172 173 174 175 176 177 178 179 180 181 182 183
      div [br ()];
      div [
        pcdata "Belenios is an electronic voting system developed at ";
        a ~service:loria [pcdata "LORIA"] ();
        pcdata ". It provides both confidentiality of the votes and ";
        pcdata "end-to-end verifiability of the result. Verifiability ";
        pcdata "relies in particular on the fact that the ballots are ";
        pcdata "stored on a public ballot box (on a webpage), so that ";
        pcdata "voters can check the presence of their ballots. Similarly, ";
        pcdata "anyone can check that the published result corresponds to ";
        pcdata "the contents of the ballot box. More information and ";
        pcdata "discussion can be found on the ";
184
        a ~service:belenios_url [pcdata "Belenios web page"] ();
185 186
        pcdata ".";
      ];
187 188 189 190 191
    ];
  ] in
  let login_box = pcdata "" in
  base ~title:site_title ~login_box ~content ()

192
let admin ~elections () =
193
  let title = site_title ^ " — Administration" in
194 195 196 197 198 199 200 201 202 203 204 205
  match elections with
  | None ->
     let content = [
       div [
         pcdata "To administer an election, you need to ";
         a ~service:site_login [pcdata "log in"] None;
         pcdata ". If you do not have an account, ";
         pcdata "please send an email to contact@belenios.org.";
       ]
     ] in
     lwt login_box = site_login_box () in
     base ~title ~login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
206
  | Some (elections, tallied, archived, setup_elections) ->
207 208 209 210 211
    let elections =
      match elections with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@ List.map (format_election `Admin) elections
    in
212 213 214 215 216
    let tallied =
      match tallied with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@ List.map (format_election `Admin) tallied
    in
Stephane Glondu's avatar
Stephane Glondu committed
217 218 219 220 221
    let archived =
      match archived with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@ List.map (format_election `Admin) archived
    in
222 223 224 225
    let setup_elections =
      match setup_elections with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@
226 227
         List.map (fun (k, title) ->
           li [a ~service:election_setup [pcdata title] k]
228 229 230 231
         ) setup_elections
    in
    let content = [
      div [
Stephane Glondu's avatar
Stephane Glondu committed
232 233 234 235 236
        div [
          a ~service:election_setup_pre [
            pcdata "Prepare a new election";
          ] ();
        ];
Stephane Glondu's avatar
Stephane Glondu committed
237
        div [br ()];
238 239
        h2 [pcdata "Elections being prepared"];
        setup_elections;
Stephane Glondu's avatar
Stephane Glondu committed
240
        div [br ()];
241 242
        h2 [pcdata "Elections you can administer"];
        elections;
243 244 245
        div [br ()];
        h2 [pcdata "Tallied elections"];
        tallied;
Stephane Glondu's avatar
Stephane Glondu committed
246 247
        h2 [pcdata "Archived elections"];
        archived;
248 249 250 251
      ];
    ] in
    lwt login_box = site_login_box () in
    base ~title ~login_box ~content ()
252

253 254 255 256 257 258 259
let make_button ~service contents =
  let uri = Eliom_uri.make_string_uri ~service () in
  Printf.ksprintf Unsafe.data (* FIXME: unsafe *)
    "<button onclick=\"location.href='%s';\" style=\"font-size:35px;\">%s</button>"
    uri
    contents

260 261 262 263 264 265 266
let a_mailto ~dest ~body contents =
  let uri = Printf.sprintf "mailto:%s?body=%s" dest
    (Netencoding.Url.encode ~plus:false body)
  in
  Printf.ksprintf Unsafe.data "<a href=\"%s\">%s</a>"
    uri contents

267
let new_election_failure reason () =
268 269 270 271 272 273 274 275 276 277 278 279
  let title = "Create new election" in
  let reason =
    match reason with
    | `Exists -> pcdata "An election with the same UUID already exists."
    | `Exception e -> pcdata @@ Printexc.to_string e
  in
  let content = [
    div [
      p [pcdata "The creation failed."];
      p [reason];
    ]
  ] in
280
  lwt login_box = site_login_box () in
281
  base ~title ~login_box ~content ()
282

283
let generic_page ~title message () =
284 285 286 287 288 289
  let content = [
    p [pcdata message];
  ] in
  let login_box = pcdata "" in
  base ~title ~login_box ~content ()

Stephane Glondu's avatar
Stephane Glondu committed
290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318
let election_setup_pre () =
  let title = "Prepare a new election" in
  let form =
    post_form ~service:election_setup_new
      (fun (credmgmt, (auth, cas_server)) ->
        [
          fieldset
            ~legend:(legend [pcdata "Credential management"])
            [
              div [
                string_radio ~checked:true ~name:credmgmt ~value:"auto" ();
                pcdata " Automatic (degraded mode)";
              ];
              div [
                string_radio ~name:credmgmt ~value:"manual" ();
                pcdata " Manual (safe mode)";
              ];
            ];
          fieldset
            ~legend:(legend [pcdata "Authentication"])
            [
              div [
                string_radio ~checked:true ~name:auth ~value:"password" ();
                pcdata " Password (passwords will be emailed to voters)";
              ];
              div [
                string_radio ~name:auth ~value:"cas" ();
                pcdata " CAS (external authentication server), server address: ";
                string_input ~input_type:`Text ~name:cas_server ();
319
                pcdata " (for example: https://cas.inria.fr/cas)";
Stephane Glondu's avatar
Stephane Glondu committed
320 321 322 323 324 325 326 327 328 329 330 331 332 333
              ];
            ];
          div [
            string_input ~input_type:`Submit ~value:"Proceed" ();
          ];
        ]
      ) ()
  in
  let content = [
    form
  ] in
  lwt login_box = site_login_box () in
  base ~title ~login_box ~content ()

334
let election_setup uuid se () =
335
  let title = "Preparation of election " ^ se.se_questions.t_name in
336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352
  let form_description =
    post_form ~service:election_setup_description
      (fun (name, description) ->
        [
          div [
            pcdata "Name of the election: ";
            string_input ~name:name
              ~input_type:`Text ~value:se.se_questions.t_name ();
          ];
          div [
            div [pcdata "Description of the election: "];
            div [
              textarea ~name:description ~a:[a_cols 80]
                ~value:se.se_questions.t_description ();
            ];
          ];
          div [
353
            string_input ~input_type:`Submit ~value:"Save changes" ();
354 355 356 357 358 359 360 361 362 363
          ];
        ]
      ) uuid
  in
  let div_description =
    div [
      h2 [pcdata "Name and description of the election"];
      form_description;
    ]
  in
Stephane Glondu's avatar
Stephane Glondu committed
364 365 366
  let has_credentials = match se.se_metadata.e_cred_authority with
    | None -> false
    | Some _ -> true
367
  in
Stephane Glondu's avatar
Stephane Glondu committed
368 369 370 371 372
  let auth = match se.se_metadata.e_auth_config with
    | Some [{auth_system = "password"; _}] -> `Password
    | Some [{auth_system = "dummy"; _}] -> `Dummy
    | Some [{auth_system = "cas"; auth_config = ["server", server]; _}] -> `CAS server
    | _ -> failwith "unknown authentication scheme in election_setup"
373
  in
Stephane Glondu's avatar
Stephane Glondu committed
374 375 376 377 378
  let div_auth =
    div [
      h2 [pcdata "Authentication"];
      match auth with
      | `Password ->
379 380 381
         div [
           pcdata "Authentication scheme: password ";
         ]
Stephane Glondu's avatar
Stephane Glondu committed
382 383 384 385 386 387 388 389 390 391
      | `Dummy ->
         div [
           pcdata "Authentication scheme: dummy"
         ]
      | `CAS server ->
         div [
           pcdata "Authentication scheme: CAS with server ";
           pcdata server;
         ]
    ]
392
  in
393
  let div_questions =
Stephane Glondu's avatar
Stephane Glondu committed
394 395
    div [
      h2 [
Stephane Glondu's avatar
Stephane Glondu committed
396
        a ~a:[a_id "edit_questions"] ~service:election_setup_questions
Stephane Glondu's avatar
Stephane Glondu committed
397 398 399 400
          [pcdata "Edit questions"]
          uuid;
      ]
    ]
401
  in
Stephane Glondu's avatar
Stephane Glondu committed
402 403
  let div_voters =
    div [
Stephane Glondu's avatar
Stephane Glondu committed
404
      h2 [
Stephane Glondu's avatar
Stephane Glondu committed
405
        a ~a:[a_id "edit_voters"] ~service:election_setup_voters
Stephane Glondu's avatar
Stephane Glondu committed
406 407 408
          [pcdata "Edit voters"]
          uuid
      ];
Stephane Glondu's avatar
Stephane Glondu committed
409 410 411 412 413 414
      div [
        pcdata @@ string_of_int @@ List.length se.se_voters;
        pcdata " voter(s) registered";
      ];
    ]
  in
415 416 417
  let div_trustees =
    div [
      h2 [pcdata "Trustees"];
418 419 420 421 422 423
      div [
        pcdata "By default, the election server manages the keys of the ";
        pcdata "election. If you do not wish the server to store any keys, ";
        pcdata "click ";
        a ~service:election_setup_trustees [pcdata "here"] uuid;
        pcdata "."];
424
    ]
425 426
  in
  let div_credentials =
427 428
    div [
      h2 [pcdata "Credentials"];
429
      if se.se_public_creds_received then (
Stephane Glondu's avatar
Stephane Glondu committed
430
        div [
431
          pcdata "Credentials have already been generated!"
Stephane Glondu's avatar
Stephane Glondu committed
432
        ]
433
      ) else (
434 435 436 437 438 439 440 441 442 443 444 445 446
        div [
          pcdata "Warning: this will freeze the voter list!";
          if has_credentials then (
            post_form ~service:election_setup_credentials_server
              (fun () ->
                [string_input ~input_type:`Submit ~value:"Generate on server" ()]
              ) uuid
          ) else (
            div [
              a ~service:election_setup_credential_authority [pcdata "Credential management"] uuid;
            ]
          );
        ]
Stephane Glondu's avatar
Stephane Glondu committed
447
      )
448
    ]
449 450 451 452 453 454 455
  in
  let form_create =
    post_form
      ~service:election_setup_create
      (fun () ->
       [div
          [h2 [pcdata "Finalize creation"];
456 457 458
           string_input ~input_type:`Submit ~value:"Create election" ();
           pcdata " (Warning: this action is irreversible.)";
          ]]
459 460 461
      ) uuid
  in
  let content = [
462 463
    div_description;
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
464 465
    div_questions;
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
466
    div_voters;
Stephane Glondu's avatar
Stephane Glondu committed
467
    hr ();
468
    div_credentials;
Stephane Glondu's avatar
Stephane Glondu committed
469
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
470
    div_auth;
Stephane Glondu's avatar
Stephane Glondu committed
471 472 473
    hr ();
    div_trustees;
    hr ();
474 475
    form_create;
  ] in
476
  lwt login_box = site_login_box () in
477 478 479 480 481 482 483
  base ~title ~login_box ~content ()

let election_setup_trustees uuid se () =
  let title = "Trustees for election " ^ se.se_questions.t_name in
  let form_trustees_add =
    post_form
      ~service:election_setup_trustee_add
484 485 486 487 488 489
      (fun name ->
        [
          string_input ~input_type:`Text ~name ();
          string_input ~input_type:`Submit ~value:"Add" ();
        ]
      ) uuid
490
  in
491
  let mk_form_trustee_del value =
492 493
    post_form
      ~service:election_setup_trustee_del
494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511
      (fun name ->
        [
          int_input ~input_type:`Hidden ~name ~value ();
          string_input ~input_type:`Submit ~value:"Remove" ();
        ]) uuid
  in
  let trustees = match se.se_public_keys with
    | [] -> pcdata ""
    | ts ->
       table (
         tr [
           th [pcdata "Trustee link"];
           th [pcdata "Done?"];
           th [pcdata "Remove"];
         ] ::
           List.mapi (fun i t ->
             tr [
               td [
512 513 514
                 let body = rewrite_prefix @@ Eliom_uri.make_string_uri
                   ~absolute:true ~service:election_setup_trustee t.st_token
                 in a_mailto ~dest:t.st_id ~body t.st_id
515 516 517 518 519 520 521 522
               ];
               td [
                 pcdata (if t.st_public_key = "" then "No" else "Yes");
               ];
               td [mk_form_trustee_del i];
             ]
           ) ts
       )
523 524 525 526 527
  in
  let div_content =
    div [
      div [pcdata "If you do not wish the server to store any keys, you may nominate trustees. In that case, each trustee will create her own secret key. Be careful, once the election is over, you will need the contribution of each trustee to compute the result!"];
      br ();
528
      trustees;
529 530 531 532 533 534 535 536 537 538
      (if se.se_public_keys <> [] then
          div [
            pcdata "There is one link per trustee. Send each trustee her link.";
            br ();
            br ();
          ]
       else pcdata "");
      form_trustees_add;
    ]
  in
539 540 541 542 543 544 545 546
  let back_link = div [
    a ~service:Web_services.election_setup
      [pcdata "Go back to election setup"] uuid;
  ] in
  let content = [
    div_content;
    back_link;
  ] in
547
  lwt login_box = site_login_box () in
548 549
  base ~title ~login_box ~content ()

Stephane Glondu's avatar
Stephane Glondu committed
550
let election_setup_credential_authority _ se () =
551 552 553
  let title = "Credentials for election " ^ se.se_questions.t_name in
  let content = [
    div [
Stephane Glondu's avatar
Stephane Glondu committed
554
      pcdata "Please send the credential authority the following link:";
555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573
    ];
    ul [
      li [
        a
          ~service:election_setup_credentials
          [
            pcdata @@ rewrite_prefix @@ Eliom_uri.make_string_uri
              ~absolute:true
              ~service:election_setup_credentials
              se.se_public_creds
          ]
          se.se_public_creds;
      ];
    ];
    div [
      pcdata "Note that this authority will have to send each credential to each voter herself.";
    ];
  ] in
  lwt login_box = site_login_box () in
574 575
  base ~title ~login_box ~content ()

576
let election_setup_questions uuid se () =
577
  let title = "Questions for election " ^ se.se_questions.t_name in
578 579 580 581 582 583 584 585
  let form =
    let value = string_of_template se.se_questions in
    post_form
      ~service:election_setup_questions_post
      (fun name ->
       [
         div [pcdata "Questions:"];
         div [textarea ~a:[a_id "questions"; a_rows 5; a_cols 80] ~name ~value ()];
586
         div [string_input ~input_type:`Submit ~value:"Save changes" ()]])
587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608
      uuid
  in
  let link =
    let service = Web_services.election_setup in
    div [a ~service [pcdata "Go back to election preparation"] uuid]
  in
  let interactivity =
    div
      ~a:[a_id "interactivity"]
      [
        script ~a:[a_src (uri_of_string (fun () -> "../static/sjcl.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/jsbn.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/jsbn2.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/random.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/tool_js_questions.js"))] (pcdata "");
      ]
  in
  let content = [
    interactivity;
    form;
    link;
  ] in
609
  lwt login_box = site_login_box () in
610 611
  base ~title ~login_box ~content ()

612
let election_setup_voters uuid se () =
613
  let title = "Voters for election " ^ se.se_questions.t_name in
Stephane Glondu's avatar
Stephane Glondu committed
614 615
  let form =
    post_form
616
      ~service:election_setup_voters_add
Stephane Glondu's avatar
Stephane Glondu committed
617 618
      (fun name ->
        [
619 620
          div [textarea ~a:[a_rows 20; a_cols 50] ~name ()];
          div [string_input ~input_type:`Submit ~value:"Add" ()]])
Stephane Glondu's avatar
Stephane Glondu committed
621 622
      uuid
  in
623 624 625 626 627 628 629 630 631 632
  let mk_remove_button id =
    post_form
      ~service:election_setup_voters_remove
      (fun name ->
        [
          string_input ~input_type:`Hidden ~name ~value:id ();
          string_input ~input_type:`Submit ~value:"Remove" ();
        ]
      ) uuid
  in
633 634 635 636
  let has_passwords = match se.se_metadata.e_auth_config with
    | Some [{auth_system = "password"; _}] -> true
    | _ -> false
  in
637 638 639 640 641 642 643 644 645 646 647 648 649
  let mk_regen_passwd value =
    post_form ~service:election_setup_voters_passwd
      ~a:[a_style "display: inline;"]
      (fun name ->
        [
          string_input ~input_type:`Hidden ~name ~value ();
          string_input ~input_type:`Submit ~value:"Send again" ();
        ]
      ) uuid
  in
  let format_password_cell x = match x.sv_password with
    | Some _ -> [pcdata "Yes "; mk_regen_passwd x.sv_id]
    | None -> [pcdata "No"]
650
  in
651 652
  let voters =
    List.map (fun v ->
653 654
      tr (
        [td [pcdata v.sv_id]] @
655
        (if has_passwords then [td (format_password_cell v)] else []) @
656
        (if se.se_public_creds_received then [] else [td [mk_remove_button v.sv_id]])
657
      )
658 659
    ) se.se_voters
  in
660 661 662 663
  let form_passwords =
    if has_passwords then
      post_form ~service:election_setup_auth_genpwd
        (fun () ->
664
          [string_input ~input_type:`Submit ~value:"Generate and mail missing passwords" ()]
665 666 667
        ) uuid
    else pcdata ""
  in
668 669 670 671
  let voters =
    match voters with
    | [] -> div [pcdata "No voters"]
    | _ :: _ ->
672 673 674 675 676
       div [
         form_passwords;
         table
           (tr (
             [th [pcdata "Identity"]] @
677
               (if has_passwords then [th [pcdata "Password sent?"]] else []) @
678 679 680
               (if se.se_public_creds_received then [] else [th [pcdata "Remove"]])
            ) :: voters)
       ]
681 682 683 684
  in
  let back = div [
    a ~service:Web_services.election_setup [pcdata "Return to setup page"] uuid;
  ] in
685 686 687 688 689 690 691 692 693 694 695 696 697 698 699
  let div_add =
    if se.se_public_creds_received then
      pcdata ""
    else
      div [
        div [pcdata "Please enter the identities of voters to add, one per line:"];
        form;
        div [
          b [pcdata "Note:"];
          pcdata " An identity is either an e-mail address, or \"address,login\",";
          pcdata " where \"address\" is an e-mail address and \"login\" the";
          pcdata " associated login for authentication.";
        ];
      ]
  in
700 701 702 703 704
  let div_import = div [
    a ~service:election_setup_import
      [pcdata "Import voters from another election"]
      uuid
  ] in
Stephane Glondu's avatar
Stephane Glondu committed
705
  let content = [
706
    back;
707
    div_import;
708
    voters;
709
    div_add;
Stephane Glondu's avatar
Stephane Glondu committed
710
  ] in
711
  lwt login_box = site_login_box () in
Stephane Glondu's avatar
Stephane Glondu committed
712 713
  base ~title ~login_box ~content ()

714
let election_setup_credentials token uuid se () =
715
  let title = "Credentials for election " ^ se.se_questions.t_name in
716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760
  let form_textarea =
    post_form
      ~service:election_setup_credentials_post
      (fun name ->
       [div
          [div [pcdata "Public credentials:"];
           div [textarea ~a:[a_id "pks"; a_rows 5; a_cols 40] ~name ()];
           div [string_input ~input_type:`Submit ~value:"Submit" ()]]])
      token
  in
  let disclaimer =
    p
      [
        b [pcdata "Note:"];
        pcdata " submitting a large (> 200) number of credentials using the above form may fail; in this case, you have to use the command-line tool and the form below.";
      ]
  in
  let form_file =
    post_form
      ~service:election_setup_credentials_post_file
      (fun name ->
       [div
          [h2 [pcdata "Submit by file"];
           div [pcdata "Use this form to upload public credentials generated with the command-line tool."];
           div [file_input ~name ()];
           div [string_input ~input_type:`Submit ~value:"Submit" ()]]])
      token
  in
  let div_download =
    p [a ~service:election_setup_credentials_download
           [pcdata "Download current file"]
           token]
  in
  let group =
    let name : 'a Eliom_parameter.param_name = Obj.magic "group" in
    let value = se.se_group in
    div
      ~a:[a_style "display:none;"]
      [
        div [pcdata "UUID:"];
        div [textarea ~a:[a_id "uuid"; a_rows 1; a_cols 40; a_readonly `ReadOnly] ~name ~value:uuid ()];
        div [pcdata "Group parameters:"];
        div [textarea ~a:[a_id "group"; a_rows 5; a_cols 40; a_readonly `ReadOnly] ~name ~value ()];
      ]
  in
761 762
  let voters =
    let name : 'a Eliom_parameter.param_name = Obj.magic "voters" in
763
    let value = String.concat "\n" (List.map (fun x -> x.sv_id) se.se_voters) in
764 765 766 767 768
    div [
      div [pcdata "List of voters:"];
      div [textarea ~a:[a_id "voters"; a_rows 5; a_cols 40; a_readonly `ReadOnly] ~name ~value ()];
    ]
  in
769 770 771 772 773 774 775 776 777 778 779
  let interactivity =
    div
      ~a:[a_id "interactivity"]
      [
        script ~a:[a_src (uri_of_string (fun () -> "../static/sjcl.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/jsbn.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/jsbn2.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/random.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/tool_js_credgen.js"))] (pcdata "");
      ]
  in
780
  let div_textarea = div [group; voters; interactivity; form_textarea; disclaimer] in
781 782 783 784 785 786 787 788 789 790 791 792
  let content =
    if se.se_public_creds_received then (
      [
        div [pcdata "Credentials have already been generated!"];
      ]
    ) else (
      [
        div_download;
        div_textarea;
        form_file;
      ]
    ) in
793 794 795
  let login_box = pcdata "" in
  base ~title ~login_box ~content ()

Stephane Glondu's avatar
Stephane Glondu committed
796
let election_setup_trustee token se () =
797
  let title = "Trustee for election " ^ se.se_questions.t_name in
798
  let form =
799 800
    let trustee = List.find (fun x -> x.st_token = token) se.se_public_keys in
    let value = trustee.st_public_key in
801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842
    let service = Eliom_service.preapply election_setup_trustee_post token in
    post_form
      ~service
      (fun name ->
       [
         div [
           div [pcdata "Public key:"];
           div [textarea ~a:[a_rows 5; a_cols 40; a_id "pk"] ~name ~value ()];
           div [string_input ~input_type:`Submit ~value:"Submit" ()];
         ]
       ]
      ) ()
  in
  let group =
    let name : 'a Eliom_parameter.param_name = Obj.magic "group" in
    let value = se.se_group in
    div
      ~a:[a_style "display:none;"]
      [
        div [pcdata "Group parameters:"];
        div [textarea ~a:[a_id "group"; a_rows 5; a_cols 40; a_readonly `ReadOnly] ~name ~value ()];
      ]
  in
  let interactivity =
    div
      ~a:[a_id "interactivity"]
      [
        script ~a:[a_src (uri_of_string (fun () -> "../static/sjcl.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/jsbn.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/jsbn2.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/random.js"))] (pcdata "");
        script ~a:[a_src (uri_of_string (fun () -> "../static/tool_js_tkeygen.js"))] (pcdata "");
      ]
  in
  let content = [
    group;
    interactivity;
    form;
  ] in
  let login_box = pcdata "" in
  base ~title ~login_box ~content ()

Stephane Glondu's avatar
Stephane Glondu committed
843
let election_setup_import uuid se (elections, tallied, archived) () =
844 845
  let title = "Election " ^ se.se_questions.t_name ^ " — Import voters from another election" in
  let format_election election =
846
    let module W = (val election : ELECTION_DATA) in
847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874
    let name = W.election.e_params.e_name in
    let uuid_s = Uuidm.to_string W.election.e_params.e_uuid in
    let form = post_form
      ~service:election_setup_import_post
      (fun from ->
        [
          div [pcdata name; pcdata " ("; pcdata uuid_s; pcdata ")"];
          div [
            user_type_input Uuidm.to_string
              ~input_type:`Hidden
              ~name:from
              ~value:W.election.e_params.e_uuid ();
            string_input ~input_type:`Submit ~value:"Import from this election" ();
          ]
        ]
      ) uuid
    in
    li [form]
  in
  let itemize xs = match xs with
    | [] -> p [pcdata "You own no such elections!"]
    | _ -> ul @@ List.map format_election xs
  in
  let content = [
    h2 [pcdata "Elections you can administer"];
    itemize elections;
    h2 [pcdata "Tallied elections"];
    itemize tallied;
Stephane Glondu's avatar
Stephane Glondu committed
875 876
    h2 [pcdata "Archived elections"];
    itemize archived;
877 878 879
  ] in
  lwt login_box = site_login_box () in
  base ~title ~login_box ~content ()
880 881

let election_login_box w =
882
  let module W = (val w : ELECTION_DATA) in
Stephane Glondu's avatar
Stephane Glondu committed
883 884 885 886 887 888 889 890
  let module A = struct
    let get_user () =
      Web_auth_state.get_election_user W.election.e_params.e_uuid
    let get_auth_systems () =
      lwt l = Web_auth_state.get_config (Some W.election.e_params.e_uuid) in
      return @@ List.map fst l
  end in
  let auth = (module A : AUTH_SERVICES) in
891 892 893 894 895 896
  let module L = struct
    let login x =
      Eliom_service.preapply
        election_login
        ((W.election.e_params.e_uuid, ()), x)
    let logout =
Stephane Glondu's avatar
Stephane Glondu committed
897
      Eliom_service.preapply logout ()
898 899
  end in
  let links = (module L : AUTH_LINKS) in
900
  fun () -> make_login_box ~site:false auth links
901 902

let file w x =
903
  let module W = (val w : ELECTION_DATA) in
904 905 906 907
  Eliom_service.preapply
    election_dir
    (W.election.e_params.e_uuid, x)

908
let audit_footer w =
909
  let module W = (val w : ELECTION_DATA) in
910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937
  div ~a:[a_style "line-height:1.5em;"] [
    div [
      div [
        pcdata "Election fingerprint: ";
        code [ pcdata W.election.e_fingerprint ];
      ];
      div [
        pcdata "Audit data: ";
        a ~service:(file w ESRaw) [
          pcdata "parameters"
        ] ();
        pcdata ", ";
        a ~service:(file w ESCreds) [
          pcdata "public credentials"
        ] ();
        pcdata ", ";
        a ~service:(file w ESKeys) [
          pcdata "trustee public keys"
        ] ();
        pcdata ", ";
        a ~service:(file w ESBallots) [
          pcdata "ballots";
        ] ();
        pcdata ".";
      ];
    ]
  ]

938
let election_home w state () =
939
  let module W = (val w : ELECTION_DATA) in
940
  let params = W.election.e_params in
941
  let state_ =
942 943
    match state with
    | `Closed ->
944 945 946 947
      [
        pcdata " ";
        b [pcdata "This election is currently closed."];
      ]
948
    | `Open -> []
949
    | `EncryptedTally (_, _, hash) ->
950 951 952 953 954 955 956 957 958 959 960 961
       [
         pcdata " ";
         b [pcdata "The election is closed and being tallied."];
         pcdata " The ";
         a
           ~service:election_dir
           [pcdata "encrypted tally"]
           (W.election.e_params.e_uuid, ESETally);
         pcdata " hash is ";
         b [pcdata hash];
         pcdata ".";
       ]
962
    | `Tallied _ ->
963 964 965
       [
         pcdata " ";
         b [pcdata "This election has been tallied."];
Stephane Glondu's avatar
Stephane Glondu committed
966 967 968 969 970
       ]
    | `Archived ->
       [
         pcdata " ";
         b [pcdata "This election is archived."];
971
       ]
972 973 974 975 976 977 978
  in
  let ballots_link =
    p ~a:[a_style "text-align:center;"] [
        a
          ~a:[a_style "font-size:25px;"]
          ~service:election_pretty_ballots [
            pcdata "See accepted ballots"
979
          ] (params.e_uuid, ())
980 981
      ]
  in
982
  let footer = audit_footer w in
983
  let go_to_the_booth =
984 985 986 987
    div ~a:[a_style "text-align:center;"] [
      div [
        make_button
          ~service:(Eliom_service.preapply election_vote (params.e_uuid, ()))
Stephane Glondu's avatar
Stephane Glondu committed
988
          "Start";
989 990 991 992 993 994 995
        ];
      div [
        pcdata "or ";
        a
          ~service:(Eliom_service.preapply election_cast (params.e_uuid, ()))
          [pcdata "submit a raw ballot"] ();
      ];
996 997
    ]
  in
998 999 1000 1001 1002 1003
  lwt middle =
    let uuid = Uuidm.to_string params.e_uuid in
    lwt result = Web_persist.get_election_result uuid in
    match result with
    | Some r ->
       let result = r.result in
1004
       let questions = Array.to_list W.election.e_params.e_questions in
1005 1006 1007 1008 1009 1010 1011 1012 1013
       return @@ div [
         ul (List.mapi (fun i x ->
           let answers = Array.to_list x.q_answers in
           let answers = List.mapi (fun j x ->
             tr [td [pcdata x]; td [pcdata @@ string_of_int result.(i).(j)]]
           ) answers in
           let answers =
             match answers with
             | [] -> pcdata ""
Stephane Glondu's avatar
Stephane Glondu committed
1014
             | x :: xs -> table (x :: xs)
1015 1016 1017 1018 1019 1020 1021 1022 1023 1024
           in
           li [
             pcdata x.q_question;
             answers;
           ]
         ) questions);
         div [
           pcdata "Number of accepted ballots: ";
           pcdata (string_of_int r.num_tallied);
         ];
Stephane Glondu's avatar
Stephane Glondu committed
1025 1026 1027 1028 1029 1030 1031
         div [
           pcdata "You can also download the ";
           a ~service:election_dir
             [pcdata "result with cryptographic proofs"]
             (W.election.e_params.e_uuid, ESResult);
           pcdata ".";
         ];
1032 1033
       ]
    | None -> return go_to_the_booth
1034 1035
  in
  let content = [
1036
    p state_;
1037 1038
    br ();
    middle;
1039 1040 1041 1042
    br ();
    ballots_link;
  ] in
  lwt login_box = election_login_box w () in
1043 1044
  let uuid = params.e_uuid in
  base ~title:params.e_name ~login_box ~content ~footer ~uuid ()
1045

1046 1047
let election_admin w metadata state () =
  let module W = (val w : ELECTION_DATA) in
1048
  let title = W.election.e_params.e_name ^ " — Administration" in
1049
  let uuid_s = Uuidm.to_string W.election.e_params.e_uuid in
1050
  let state_form checked =
1051 1052 1053 1054 1055 1056 1057 1058
    let service, value, msg =
      if checked then
        election_close, "Close election",
        "The election is open. Voters can vote. "
      else
        election_open, "Open election",
        "The election is closed. No one can vote. "
    in
1059
    post_form
1060 1061
      ~service
      (fun () ->
1062
       [
1063 1064
         pcdata msg;
         string_input ~input_type:`Submit ~value ();
1065 1066
       ]) (W.election.e_params.e_uuid, ())
  in
1067
  lwt state_div =
1068 1069
    match state with
    | `Open ->
1070
       return @@ div [
1071 1072 1073
         state_form true;
       ]
    | `Closed ->
1074
       return @@ div [
1075 1076 1077 1078 1079 1080
         state_form false;
         post_form
           ~service:election_compute_encrypted_tally
           (fun () ->
             [string_input
                 ~input_type:`Submit
1081 1082 1083
                 ~value:"Tally the election"
                 ();
              pcdata " (Warning, this action is irreversible.)";
1084 1085
             ]) (W.election.e_params.e_uuid, ());
       ]
1086 1087
    | `EncryptedTally (npks, _, hash) ->
       lwt pds = Web_persist.get_partial_decryptions uuid_s in
1088 1089 1090 1091 1092