Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

web_templates.ml 45.7 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 [
58
          a ~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 ->
71
            a ~service:(L.login (Some name)) [pcdata name] ()
72 73
          ) |> list_join (pcdata ", ")
        in
74
        div (
75
          [pcdata "Log in: ["] @ auth_systems @ [pcdata "]"]
76 77
        );
      ]
78
        else []
79 80
  )

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

86
module Site_auth = struct
Stephane Glondu's avatar
Stephane Glondu committed
87 88 89 90
  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)
91 92
end

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

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

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

105 106 107 108 109 110 111 112
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
113 114 115 116 117 118 119 120 121 122 123
  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
124
          ];
125 126
          login_box;
          div ~a:[a_style "clear: both;"] [];
Stephane Glondu's avatar
Stephane Glondu committed
127
        ];
128
        h1 ~a:[a_style "text-align: center;"] [pcdata title];
Stephane Glondu's avatar
Stephane Glondu committed
129
      ];
130 131 132 133 134
      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 ";
135 136 137
          a ~service:belenios_url [pcdata "Belenios"] ();
          pcdata ". ";
          a ~service:source_code [pcdata "Get the source code"] ();
138
          pcdata ". ";
139
          administer;
140
          pcdata ".";
141
        ]
142 143 144 145
      ]]
     ]))

let format_election kind election =
146
  let module W = (val election : WEB_ELECTION_DATA) in
147 148 149 150 151 152 153 154 155 156 157 158 159
  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];
  ]

160
let home () =
161 162 163 164 165 166
  let loria = Eliom_service.Http.external_service
    ~prefix:"http://www.loria.fr"
    ~path:[]
    ~get_params:Eliom_parameter.unit
    ()
  in
167 168
  let content = [
    div [
Stephane Glondu's avatar
Stephane Glondu committed
169 170
      h2 ~a:[a_style "text-align:center;"] [pcdata welcome_message];
      h3 [a ~service:admin [pcdata "Administer elections"] ()];
171 172 173 174 175 176 177 178 179 180 181 182
      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 ";
183
        a ~service:belenios_url [pcdata "Belenios web page"] ();
184 185
        pcdata ".";
      ];
186 187 188 189 190
    ];
  ] in
  let login_box = pcdata "" in
  base ~title:site_title ~login_box ~content ()

191
let admin ~elections () =
192
  let title = site_title ^ " — Administration" in
193 194 195 196 197 198 199 200 201 202 203 204
  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 ()
205
  | Some (elections, tallied, setup_elections) ->
206 207 208 209 210
    let elections =
      match elections with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@ List.map (format_election `Admin) elections
    in
211 212 213 214 215
    let tallied =
      match tallied with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@ List.map (format_election `Admin) tallied
    in
216 217 218 219
    let setup_elections =
      match setup_elections with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@
220 221
         List.map (fun (k, title) ->
           li [a ~service:election_setup [pcdata title] k]
222 223 224 225
         ) setup_elections
    in
    let content = [
      div [
Stephane Glondu's avatar
Stephane Glondu committed
226 227 228 229 230
        div [
          a ~service:election_setup_pre [
            pcdata "Prepare a new election";
          ] ();
        ];
Stephane Glondu's avatar
Stephane Glondu committed
231
        div [br ()];
232 233
        h2 [pcdata "Elections being prepared"];
        setup_elections;
Stephane Glondu's avatar
Stephane Glondu committed
234
        div [br ()];
235 236
        h2 [pcdata "Elections you can administer"];
        elections;
237 238 239
        div [br ()];
        h2 [pcdata "Tallied elections"];
        tallied;
240 241 242 243
      ];
    ] in
    lwt login_box = site_login_box () in
    base ~title ~login_box ~content ()
244

245 246 247 248 249 250 251
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

252
let new_election_failure reason () =
253 254 255 256 257 258 259 260 261 262 263 264
  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
265
  lwt login_box = site_login_box () in
266
  base ~title ~login_box ~content ()
267

268
let generic_page ~title message () =
269 270 271 272 273 274
  let content = [
    p [pcdata message];
  ] in
  let login_box = pcdata "" in
  base ~title ~login_box ~content ()

Stephane Glondu's avatar
Stephane Glondu committed
275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307
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:"dummy" ();
                pcdata " Dummy (typically for a test election)";
              ];
              div [
                string_radio ~name:auth ~value:"cas" ();
                pcdata " CAS (external authentication server), server address: ";
                string_input ~input_type:`Text ~name:cas_server ();
308
                pcdata " (for example: https://cas.inria.fr/cas)";
Stephane Glondu's avatar
Stephane Glondu committed
309 310 311 312 313 314 315 316 317 318 319 320 321 322
              ];
            ];
          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 ()

323
let election_setup uuid se () =
324
  let title = "Preparation of election " ^ se.se_questions.t_name in
325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
  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 [
342
            string_input ~input_type:`Submit ~value:"Save changes" ();
343 344 345 346 347 348 349 350 351 352
          ];
        ]
      ) uuid
  in
  let div_description =
    div [
      h2 [pcdata "Name and description of the election"];
      form_description;
    ]
  in
Stephane Glondu's avatar
Stephane Glondu committed
353 354 355
  let has_credentials = match se.se_metadata.e_cred_authority with
    | None -> false
    | Some _ -> true
356
  in
Stephane Glondu's avatar
Stephane Glondu committed
357 358 359 360 361
  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"
362
  in
Stephane Glondu's avatar
Stephane Glondu committed
363 364 365 366 367
  let div_auth =
    div [
      h2 [pcdata "Authentication"];
      match auth with
      | `Password ->
368 369 370
         div [
           pcdata "Authentication scheme: password ";
         ]
Stephane Glondu's avatar
Stephane Glondu committed
371 372 373 374 375 376 377 378 379 380
      | `Dummy ->
         div [
           pcdata "Authentication scheme: dummy"
         ]
      | `CAS server ->
         div [
           pcdata "Authentication scheme: CAS with server ";
           pcdata server;
         ]
    ]
381
  in
382
  let div_questions =
Stephane Glondu's avatar
Stephane Glondu committed
383 384 385 386 387 388 389 390
    div [
      h2 [
        a
          ~service:election_setup_questions
          [pcdata "Edit questions"]
          uuid;
      ]
    ]
391
  in
Stephane Glondu's avatar
Stephane Glondu committed
392 393
  let div_voters =
    div [
Stephane Glondu's avatar
Stephane Glondu committed
394 395 396 397 398
      h2 [
        a ~service:election_setup_voters
          [pcdata "Edit voters"]
          uuid
      ];
Stephane Glondu's avatar
Stephane Glondu committed
399 400 401 402 403 404
      div [
        pcdata @@ string_of_int @@ List.length se.se_voters;
        pcdata " voter(s) registered";
      ];
    ]
  in
405 406 407
  let div_trustees =
    div [
      h2 [pcdata "Trustees"];
408 409 410 411 412 413
      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 "."];
414
    ]
415 416
  in
  let div_credentials =
417 418
    div [
      h2 [pcdata "Credentials"];
419
      if se.se_public_creds_received then (
Stephane Glondu's avatar
Stephane Glondu committed
420
        div [
421
          pcdata "Credentials have already been generated!"
Stephane Glondu's avatar
Stephane Glondu committed
422
        ]
423
      ) else (
424 425 426 427 428 429 430 431 432 433 434 435 436
        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
437
      )
438
    ]
439 440 441 442 443 444 445
  in
  let form_create =
    post_form
      ~service:election_setup_create
      (fun () ->
       [div
          [h2 [pcdata "Finalize creation"];
446 447 448
           string_input ~input_type:`Submit ~value:"Create election" ();
           pcdata " (Warning: this action is irreversible.)";
          ]]
449 450 451
      ) uuid
  in
  let content = [
452 453
    div_description;
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
454 455
    div_questions;
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
456
    div_voters;
Stephane Glondu's avatar
Stephane Glondu committed
457
    hr ();
458
    div_credentials;
Stephane Glondu's avatar
Stephane Glondu committed
459
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
460
    div_auth;
Stephane Glondu's avatar
Stephane Glondu committed
461 462 463
    hr ();
    div_trustees;
    hr ();
464 465
    form_create;
  ] in
466
  lwt login_box = site_login_box () in
467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488
  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
      (fun () ->
        [string_input ~input_type:`Submit ~value:"Add" ()]) uuid
  in
  let form_trustees_del =
    post_form
      ~service:election_setup_trustee_del
      (fun () ->
        [string_input ~input_type:`Submit ~value:"Delete" ()]) uuid
  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 ();
      ol
        (List.rev_map
Stephane Glondu's avatar
Stephane Glondu committed
489
           (fun (token, _) ->
490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
             li [
               a ~service:election_setup_trustee [
                 pcdata @@ rewrite_prefix @@ Eliom_uri.make_string_uri
                   ~absolute:true
                   ~service:election_setup_trustee
                   token
               ] token
             ];
           ) se.se_public_keys
        );
      (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;
      form_trustees_del;
    ]
  in
511 512 513 514 515 516 517 518
  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
519
  lwt login_box = site_login_box () in
520 521
  base ~title ~login_box ~content ()

Stephane Glondu's avatar
Stephane Glondu committed
522
let election_setup_credential_authority _ se () =
523 524 525
  let title = "Credentials for election " ^ se.se_questions.t_name in
  let content = [
    div [
Stephane Glondu's avatar
Stephane Glondu committed
526
      pcdata "Please send the credential authority the following link:";
527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545
    ];
    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
546 547
  base ~title ~login_box ~content ()

548
let election_setup_questions uuid se () =
549
  let title = "Questions for election " ^ se.se_questions.t_name in
550 551 552 553 554 555 556 557
  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 ()];
558
         div [string_input ~input_type:`Submit ~value:"Save changes" ()]])
559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580
      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
581
  lwt login_box = site_login_box () in
582 583
  base ~title ~login_box ~content ()

584
let election_setup_voters uuid se () =
585
  let title = "Voters for election " ^ se.se_questions.t_name in
Stephane Glondu's avatar
Stephane Glondu committed
586 587
  let form =
    post_form
588
      ~service:election_setup_voters_add
Stephane Glondu's avatar
Stephane Glondu committed
589 590
      (fun name ->
        [
591 592
          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
593 594
      uuid
  in
595 596 597 598 599 600 601 602 603 604
  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
605 606 607 608
  let has_passwords = match se.se_metadata.e_auth_config with
    | Some [{auth_system = "password"; _}] -> true
    | _ -> false
  in
609 610 611 612 613 614 615 616 617 618 619 620 621
  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"]
622
  in
623 624
  let voters =
    List.map (fun v ->
625 626
      tr (
        [td [pcdata v.sv_id]] @
627
        (if has_passwords then [td (format_password_cell v)] else []) @
628
        (if se.se_public_creds_received then [] else [td [mk_remove_button v.sv_id]])
629
      )
630 631
    ) se.se_voters
  in
632 633 634 635
  let form_passwords =
    if has_passwords then
      post_form ~service:election_setup_auth_genpwd
        (fun () ->
636
          [string_input ~input_type:`Submit ~value:"Generate and mail missing passwords" ()]
637 638 639
        ) uuid
    else pcdata ""
  in
640 641 642 643
  let voters =
    match voters with
    | [] -> div [pcdata "No voters"]
    | _ :: _ ->
644 645 646 647 648
       div [
         form_passwords;
         table
           (tr (
             [th [pcdata "Identity"]] @
649
               (if has_passwords then [th [pcdata "Password sent?"]] else []) @
650 651 652
               (if se.se_public_creds_received then [] else [th [pcdata "Remove"]])
            ) :: voters)
       ]
653 654 655 656
  in
  let back = div [
    a ~service:Web_services.election_setup [pcdata "Return to setup page"] uuid;
  ] in
657 658 659 660 661 662 663 664 665 666 667 668 669 670 671
  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
672 673 674 675 676
  let div_import = div [
    a ~service:election_setup_import
      [pcdata "Import voters from another election"]
      uuid
  ] in
Stephane Glondu's avatar
Stephane Glondu committed
677
  let content = [
678
    back;
679
    div_import;
680
    voters;
681
    div_add;
Stephane Glondu's avatar
Stephane Glondu committed
682
  ] in
683
  lwt login_box = site_login_box () in
Stephane Glondu's avatar
Stephane Glondu committed
684 685
  base ~title ~login_box ~content ()

686
let election_setup_credentials token uuid se () =
687
  let title = "Credentials for election " ^ se.se_questions.t_name in
688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732
  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
733 734
  let voters =
    let name : 'a Eliom_parameter.param_name = Obj.magic "voters" in
735
    let value = String.concat "\n" (List.map (fun x -> x.sv_id) se.se_voters) in
736 737 738 739 740
    div [
      div [pcdata "List of voters:"];
      div [textarea ~a:[a_id "voters"; a_rows 5; a_cols 40; a_readonly `ReadOnly] ~name ~value ()];
    ]
  in
741 742 743 744 745 746 747 748 749 750 751
  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
752
  let div_textarea = div [group; voters; interactivity; form_textarea; disclaimer] in
753 754 755 756 757 758 759 760 761 762 763 764
  let content =
    if se.se_public_creds_received then (
      [
        div [pcdata "Credentials have already been generated!"];
      ]
    ) else (
      [
        div_download;
        div_textarea;
        form_file;
      ]
    ) in
765 766 767
  let login_box = pcdata "" in
  base ~title ~login_box ~content ()

Stephane Glondu's avatar
Stephane Glondu committed
768
let election_setup_trustee token se () =
769
  let title = "Trustee for election " ^ se.se_questions.t_name in
770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813
  let form =
    let value = !(List.assoc token se.se_public_keys) in
    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 ()

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 843 844 845 846 847 848
let election_setup_import uuid se (elections, tallied) () =
  let title = "Election " ^ se.se_questions.t_name ^ " — Import voters from another election" in
  let format_election election =
    let module W = (val election : WEB_ELECTION_DATA) in
    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;
  ] in
  lwt login_box = site_login_box () in
  base ~title ~login_box ~content ()
849 850

let election_login_box w =
851
  let module W = (val w : WEB_ELECTION_DATA) in
Stephane Glondu's avatar
Stephane Glondu committed
852 853 854 855 856 857 858 859
  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
860 861 862 863 864 865
  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
866
      Eliom_service.preapply logout ()
867 868
  end in
  let links = (module L : AUTH_LINKS) in
869
  fun () -> make_login_box ~site:false auth links
870 871

let file w x =
872
  let module W = (val w : WEB_ELECTION_DATA) in
873 874 875 876
  Eliom_service.preapply
    election_dir
    (W.election.e_params.e_uuid, x)

877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906
let audit_footer w =
  let module W = (val w : WEB_ELECTION_DATA) in
  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 ".";
      ];
    ]
  ]

907
let election_home w state () =
908
  let module W = (val w : WEB_ELECTION_DATA) in
909
  let params = W.election.e_params in
910
  let state_ =
911 912
    match state with
    | `Closed ->
913 914 915 916
      [
        pcdata " ";
        b [pcdata "This election is currently closed."];
      ]
917
    | `Open -> []
918
    | `EncryptedTally (_, _, hash) ->
919 920 921 922 923 924 925 926 927 928 929 930
       [
         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 ".";
       ]
931
    | `Tallied _ ->
932 933 934
       [
         pcdata " ";
         b [pcdata "This election has been tallied."];
Stephane Glondu's avatar
Stephane Glondu committed
935
         pcdata " The result with ";
936 937
         a
           ~service:election_dir
Stephane Glondu's avatar
Stephane Glondu committed
938
           [pcdata "cryptographic proofs"]
939 940 941
           (W.election.e_params.e_uuid, ESResult);
         pcdata " is available."
       ]
942 943 944 945 946 947 948
  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"
949
          ] (params.e_uuid, ())
950 951
      ]
  in
952
  let footer = audit_footer w in
953
  let go_to_the_booth =
954 955 956 957
    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
958
          "Start";
959 960 961 962 963 964 965
        ];
      div [
        pcdata "or ";
        a
          ~service:(Eliom_service.preapply election_cast (params.e_uuid, ()))
          [pcdata "submit a raw ballot"] ();
      ];
966 967
    ]
  in
968 969 970 971 972 973
  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
974
       let questions = Array.to_list W.election.e_params.e_questions in
975 976 977 978 979 980 981 982 983
       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
984
             | x :: xs -> table (x :: xs)
985 986 987 988 989 990 991 992 993 994 995 996
           in
           li [
             pcdata x.q_question;
             answers;
           ]
         ) questions);
         div [
           pcdata "Number of accepted ballots: ";
           pcdata (string_of_int r.num_tallied);
         ];
       ]
    | None -> return go_to_the_booth
997 998
  in
  let content = [
999
    p state_;
1000 1001
    br ();
    middle;
1002 1003 1004 1005
    br ();
    ballots_link;
  ] in
  lwt login_box = election_login_box w () in
1006 1007
  let uuid = params.e_uuid in
  base ~title:params.e_name ~login_box ~content ~footer ~uuid ()
1008

1009
let election_admin w state () =
1010
  let module W = (val w : WEB_ELECTION_DATA) in
1011
  let title = W.election.e_params.e_name ^ " — Administration" in
1012
  let uuid_s = Uuidm.to_string W.election.e_params.e_uuid in
1013
  let state_form checked =
1014 1015 1016 1017 1018 1019 1020 1021
    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
1022
    post_form
1023 1024
      ~service
      (fun () ->
1025
       [
1026 1027
         pcdata msg;
         string_input ~input_type:`Submit ~value ();
1028 1029
       ]) (W.election.e_params.e_uuid, ())
  in
1030
  lwt state_div =
1031 1032
    match state with
    | `Open ->
1033
       return @@ div [
1034 1035 1036
         state_form true;
       ]
    | `Closed ->
1037
       return @@ div [
1038 1039 1040 1041 1042 1043
         state_form false;
         post_form
           ~service:election_compute_encrypted_tally
           (fun () ->
             [string_input
                 ~input_type:`Submit
1044 1045 1046
                 ~value:"Tally the election"
                 ();
              pcdata " (Warning, this action is irreversible.)";
1047 1048
             ]) (W.election.e_params.e_uuid, ());
       ]
1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060
    | `EncryptedTally (npks, _, hash) ->
       let rec seq a b =
         if a <= b then a :: (seq (a+1) b) else []
       in
       lwt pds = Web_persist.get_partial_decryptions uuid_s in
       let trustees =
         List.map
           (fun trustee_id ->
             tr [
               td [
                 a
                   ~service:election_tally_trustees
1061 1062 1063 1064 1065 1066
                   [
                     pcdata @@ rewrite_prefix @@ Eliom_uri.make_string_uri
                       ~absolute:true
                       ~service:election_tally_trustees
                       (W.election.e_params.e_uuid, ((), trustee_id))
                   ]
1067 1068 1069 1070 1071 1072 1073 1074
                   (W.election.e_params.e_uuid, ((), trustee_id))
               ];
               td [
                 pcdata (if List.mem_assoc trustee_id pds then "Yes" else "No")
               ];
             ]
           ) (seq 1 npks)
       in
1075 1076 1077 1078 1079 1080
       let release_form =
         post_form
           ~service:election_tally_release
           (fun () ->
             [string_input
                 ~input_type:`Submit
Stephane Glondu's avatar
Stephane Glondu committed
1081
                 ~value:"Compute the result"
1082 1083 1084
                 ()
             ]) (W.election.e_params.e_uuid, ())
       in
1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099
       return @@ div [
         div [
           pcdata "The ";
           a
             ~service:election_dir
             [pcdata "encrypted tally"]
             (W.election.e_params.e_uuid, ESETally);
           pcdata " has been computed. Its hash is ";
           b [pcdata hash];
           pcdata ".";
         ];
         div [
           div [pcdata "We are now waiting for trustees..."];
           table
             (tr [
1100
               td [pcdata "Trustee link"];
1101
               td [pcdata "Done?"];
Stephane Glondu's avatar
Stephane Glondu committed
1102
             ] :: trustees)
1103 1104 1105
         ];
         release_form;
       ]
1106
    | `Tallied _ ->
1107 1108
       return @@ div [
         pcdata "This election has been tallied.";
1109 1110
       ]
  in
1111
  let uuid = W.election.e_params.e_uuid in
1112 1113 1114 1115 1116 1117 1118 1119 1120
  let update_credential =
    match