web_templates.ml 30 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 35
let site_title = "Election Server"
let welcome_message = "Welcome!"
36
let admin_background = " background: #FF9999;"
Stephane Glondu's avatar
Stephane Glondu committed
37

Stephane Glondu's avatar
Stephane Glondu committed
38
let format_user u =
39
  em [pcdata (Web_auth.(string_of_user u))]
40

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

Stephane Glondu's avatar
Stephane Glondu committed
77

78
  let site_login_box =
79
    let auth = (module Web_site_auth : AUTH_SERVICES) in
80
    let module L = struct
81 82
      let login x = Eliom_service.preapply site_login x
      let logout = Eliom_service.preapply site_logout ()
83 84 85
    end in
    let links = (module L : AUTH_LINKS) in
    fun () -> make_login_box admin_background auth links
86

87
  let base ~title ~login_box ~content ?(footer = div []) () =
Stephane Glondu's avatar
Stephane Glondu committed
88
    Lwt.return (html ~a:[a_dir `Ltr; a_xml_lang "en"]
89 90
      (head (Eliom_content.Html5.F.title (pcdata title)) [
        script (pcdata "window.onbeforeunload = function () {};");
91
        link ~rel:[`Stylesheet] ~href:(uri_of_string (fun () -> "/static/site.css")) ();
92
      ])
Stephane Glondu's avatar
Stephane Glondu committed
93
      (body [
94
        div ~a:[a_id "wrapper"] [
Stephane Glondu's avatar
Stephane Glondu committed
95 96 97
        div ~a:[a_id "header"] [
          div [
            div ~a:[a_style "float: left;"] [
98
              a ~service:home [pcdata site_title] ();
Stephane Glondu's avatar
Stephane Glondu committed
99
            ];
100
            login_box;
Stephane Glondu's avatar
Stephane Glondu committed
101
            div ~a:[a_style "clear: both;"] [];
Stephane Glondu's avatar
Stephane Glondu committed
102
          ];
103
          h1 ~a:[a_style "text-align: center;"] [pcdata title];
Stephane Glondu's avatar
Stephane Glondu committed
104
        ];
105
        div ~a:[a_id "main"] content;
Stephane Glondu's avatar
Stephane Glondu committed
106
        div ~a:[a_id "footer"; a_style "text-align: center;" ] [
107
          div ~a:[a_id "bottom"] [
108
            footer;
109 110 111 112 113 114 115
            pcdata "Powered by ";
            a ~service:source_code [pcdata "Belenios"] ();
            pcdata ". ";
            a ~service:admin [pcdata "Administer elections"] ();
            pcdata ".";
          ]
        ]]
Stephane Glondu's avatar
Stephane Glondu committed
116
       ]))
117

118
  let format_election kind election =
Stephane Glondu's avatar
Stephane Glondu committed
119
    let module W = (val election : WEB_ELECTION) in
120
    let e = W.election.e_params in
121 122
    let service =
      match kind with
123 124
      | `Home -> election_home
      | `Admin -> election_admin
125
    in
Stephane Glondu's avatar
Stephane Glondu committed
126 127
    li [
      h3 [
128
        a ~service [pcdata e.e_name] (e.e_uuid, ());
Stephane Glondu's avatar
Stephane Glondu committed
129 130 131
      ];
      p [pcdata e.e_description];
    ]
Stephane Glondu's avatar
Stephane Glondu committed
132

133 134 135 136 137
  let home ~featured () =
    let featured_box = match featured with
      | _::_ ->
        div [
          h2 [pcdata "Current featured elections"];
138
          ul (List.map (format_election `Home) featured);
139 140 141 142 143 144 145 146 147 148 149 150
        ]
      | [] ->
        div [
          pcdata "No featured elections at the moment.";
        ]
    in
    let content = [
      div [
        pcdata welcome_message;
        featured_box;
      ];
    ] in
151
    let login_box = pcdata "" in
152
    base ~title:site_title ~login_box ~content ()
153

154 155 156 157 158 159 160 161 162
  let admin ~elections () =
    let title = site_title ^ " — Administration" in
    let elections =
      match elections with
      | [] -> p [pcdata "You cannot administer any elections!"]
      | _ -> ul @@ List.map (format_election `Admin) elections
    in
    let content = [
      div [
163 164
        div [a ~service:new_election [pcdata "Create a new election"] ()];
        div [a ~service:election_setup_index [pcdata "Elections being prepared"] ()];
165 166 167 168 169
        h2 [pcdata "Elections you can administer"];
        elections;
      ];
    ] in
    lwt login_box = site_login_box () in
170
    base ~title ~login_box ~content ()
171

172
  module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES = struct
Stephane Glondu's avatar
Stephane Glondu committed
173

174 175
    let login_box =
      let auth = (module S : AUTH_SERVICES) in
176
      let links = (module L : AUTH_LINKS) in
177 178 179
      let style =
        if S.auth_realm = "site" then admin_background else ""
      in
180
      fun () -> make_login_box style auth links
181 182 183 184 185 186 187 188 189 190 191 192 193

    let dummy ~service () =
      let title, field_name, input_type =
        "Dummy login", "Username:", `Text
      in
      let form = post_form ~service
        (fun name ->
          [
            tablex [tbody [
              tr [
                th [label ~a:[a_for name] [pcdata field_name]];
                td [string_input ~a:[a_maxlength 50] ~input_type ~name ()];
              ]]
194
            ];
195 196 197 198 199 200 201 202 203
            div [
              string_input ~input_type:`Submit ~value:"Login" ();
            ]
          ]) ()
      in
      let content = [
        form;
      ] in
      lwt login_box = login_box () in
204
      base ~title ~login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
205

206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228
    let password ~service () =
      let form = post_form ~service
        (fun (llogin, lpassword) ->
          [
            tablex [tbody [
              tr [
                th [label ~a:[a_for llogin] [pcdata "Username:"]];
                td [string_input ~a:[a_maxlength 50] ~input_type:`Text ~name:llogin ()];
              ];
              tr [
                th [label ~a:[a_for lpassword] [pcdata "Password:"]];
                td [string_input ~a:[a_maxlength 50] ~input_type:`Password ~name:lpassword ()];
              ];
            ]];
            div [
              string_input ~input_type:`Submit ~value:"Login" ();
            ]
          ]) ()
      in
      let content = [
        form;
      ] in
      lwt login_box = login_box () in
229
      base ~title:"Password login" ~login_box ~content ()
230

231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
    let upload_password_db ~service () =
      let title = "Upload password database" in
      let form = post_form ~service
        (fun password_db ->
          [
            div [
              pcdata "Password database (CSV format): ";
              file_input ~name:password_db ();
            ];
            div [string_input ~input_type:`Submit ~value:"Submit" ()];
          ]
        ) ()
      in
      let content = [
        div [form];
      ] in
      lwt login_box = site_login_box () in
248
      base ~title ~login_box ~content ()
249

250
    let choose () =
251 252 253
      let auth_systems =
        S.get_auth_systems () |>
        List.map (fun name ->
254
          a ~service:(L.login (Some name)) [pcdata name] ()
255 256
        ) |> list_join (pcdata ", ")
      in
257
      let content = [
258 259 260
        div [p (
          [pcdata "Please log in: ["] @ auth_systems @ [pcdata "]"]
        )]
261 262
      ] in
      lwt login_box = login_box () in
263
      base ~title:"Log in" ~login_box ~content ()
264 265

  end
Stephane Glondu's avatar
Stephane Glondu committed
266

267
  let format_date = Platform.format_datetime "%a, %d %b %Y %T %z"
Stephane Glondu's avatar
Stephane Glondu committed
268

Stephane Glondu's avatar
Stephane Glondu committed
269 270
  let make_button ~service contents =
    let uri = Eliom_uri.make_string_uri ~service () in
Stephane Glondu's avatar
Stephane Glondu committed
271
    Printf.ksprintf Unsafe.data (* FIXME: unsafe *)
Stephane Glondu's avatar
Stephane Glondu committed
272
      "<button onclick=\"location.href='%s';\" style=\"font-size:30px;\">%s</button>"
Stephane Glondu's avatar
Stephane Glondu committed
273 274
      uri
      contents
275

276 277 278
  let new_election () =
    let title = "Create new election" in
    lwt body =
279
      let form = post_form ~service:new_election_post
280 281
        (fun (election, (metadata, (public_keys, public_creds))) ->
          [
282 283 284
            h2 [pcdata "Import prepared election"];
            p [
              pcdata "This section assumes you have already prepared election files offline using either the command-line tool or its ";
285
              a ~service:tool [pcdata "web version"] ();
286 287
              pcdata ".";
            ];
288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306
            div [
              pcdata "Public election parameters: ";
              file_input ~name:election ();
            ];
            div [
              pcdata "Optional metadata: ";
              file_input ~name:metadata ()
            ];
            div [
              pcdata "Trustee public keys: ";
              file_input ~name:public_keys ()
            ];
            div [
              pcdata "Public credentials: ";
              file_input ~name:public_creds ()
            ];
            div [string_input ~input_type:`Submit ~value:"Submit" ()];
          ]
        ) ()
307
      in
308
      let setup_form = post_form ~service:election_setup_new
309 310 311 312 313 314 315 316
        (fun () ->
         [
           h2 [pcdata "Prepare a new election"];
           div [string_input ~input_type:`Submit ~value:"Prepare a new election" ()]
         ]
        ) ()
      in
      return [form; setup_form]
317 318 319 320 321
    in
    let content = [
      div body;
    ] in
    lwt login_box = site_login_box () in
322
    base ~title ~login_box ~content ()
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337

  let new_election_failure reason () =
    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
    lwt login_box = site_login_box () in
338
    base ~title ~login_box ~content ()
339

340
  let election_setup_index uuids () =
341
    let service = election_setup in
342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
    let title = "Elections being prepared" in
    let uuids =
      List.map (fun k ->
        li [a ~service [pcdata (Uuidm.to_string k)] k]
      ) uuids
    in
    let list =
      match uuids with
      | [] -> div [pcdata "You own no such elections."]
      | us -> ul us
    in
    let content = [
      div [list];
    ] in
    lwt login_box = site_login_box () in
357
    base ~title ~login_box ~content ()
358 359 360 361 362 363 364

  let generic_error_page message () =
    let title = "Error" in
    let content = [
      p [pcdata message];
    ] in
    let login_box = pcdata "" in
365
    base ~title ~login_box ~content ()
366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382

  let election_setup uuid se () =
    let title = "Preparation of election " ^ Uuidm.to_string uuid in
    let make_form service value title =
      post_form ~service
        (fun name ->
         [
           div [
             h2 [pcdata title];
             div [textarea ~a:[a_rows 5; a_cols 80] ~name ~value ()];
             div [string_input ~input_type:`Submit ~value:"Submit" ()];
           ]
         ]
        ) ()
    in
    let form_group =
      make_form
383
        (Eliom_service.preapply election_setup_group uuid)
384 385 386 387 388
        se.se_group "Group parameters"
    in
    let form_metadata =
      let value = string_of_metadata se.se_metadata in
      make_form
389
        (Eliom_service.preapply election_setup_metadata uuid)
390 391
        value "Election metadata"
    in
392 393 394 395 396 397 398
    let div_questions =
      div
        [h2 [pcdata "Questions"];
         a
           ~service:election_setup_questions
           [pcdata "Manage questions"]
           uuid]
399 400 401
    in
    let form_trustees =
      post_form
402
        ~service:election_setup_trustee_add
403 404 405 406 407 408 409
        (fun () ->
         [div
            [h2 [pcdata "Trustees"];
             ol
               (List.rev_map
                  (fun (token, pk) ->
                   li
410
                     [a ~service:election_setup_trustee [pcdata token] token]
411 412 413 414 415 416 417 418
                  ) se.se_public_keys
               );
             string_input ~input_type:`Submit ~value:"Add" ()]]) uuid
    in
    let div_credentials =
      div
        [h2 [pcdata "Credentials"];
         a
419
           ~service:election_setup_credentials
420 421 422 423 424
           [pcdata "Manage credentials"]
           se.se_public_creds]
    in
    let form_create =
      post_form
425
        ~service:election_setup_create
426 427 428 429 430 431 432 433 434 435 436
        (fun () ->
         [div
            [h2 [pcdata "Finalize creation"];
             string_input ~input_type:`Submit ~value:"Create election" ()]]
        ) uuid
    in
    let content = [
      form_trustees;
      div_credentials;
      form_group;
      form_metadata;
437
      div_questions;
438 439 440
      form_create;
    ] in
    lwt login_box = site_login_box () in
441
    base ~title ~login_box ~content ()
442

443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459
  let election_setup_questions uuid se () =
    let title = "Questions for election " ^ Uuidm.to_string uuid in
    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 ()];
           div [string_input ~input_type:`Submit ~value:"Submit" ()]])
        uuid
    in
    let content = [
      form;
    ] in
    lwt login_box = site_login_box () in
460
    base ~title ~login_box ~content ()
461

462 463 464 465
  let election_setup_credentials token uuid se () =
    let title = "Credentials for election " ^ uuid in
    let form_textarea =
      post_form
466
        ~service:election_setup_credentials_post
467 468
        (fun name ->
         [div
Stephane Glondu's avatar
Stephane Glondu committed
469 470
            [div [pcdata "Public credentials:"];
             div [textarea ~a:[a_id "pks"; a_rows 5; a_cols 40] ~name ()];
471 472 473
             div [string_input ~input_type:`Submit ~value:"Submit" ()]]])
        token
    in
474 475 476 477 478 479 480
    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
481 482
    let form_file =
      post_form
483
        ~service:election_setup_credentials_post_file
484 485 486
        (fun name ->
         [div
            [h2 [pcdata "Submit by file"];
487
             div [pcdata "Use this form to upload public credentials generated with the command-line tool."];
488 489 490 491 492
             div [file_input ~name ()];
             div [string_input ~input_type:`Submit ~value:"Submit" ()]]])
        token
    in
    let div_download =
Stephane Glondu's avatar
Stephane Glondu committed
493
      p [a ~service:election_setup_credentials_download
494 495 496
             [pcdata "Download current file"]
             token]
    in
Stephane Glondu's avatar
Stephane Glondu committed
497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519
    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
    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
520
    let div_textarea = div [group; interactivity; form_textarea; disclaimer] in
521 522
    let content = [
      div_download;
Stephane Glondu's avatar
Stephane Glondu committed
523
      div_textarea;
524 525 526
      form_file;
    ] in
    let login_box = pcdata "" in
527
    base ~title ~login_box ~content ()
528 529 530 531 532

  let election_setup_trustee token uuid se () =
    let title = "Trustee for election " ^ uuid in
    let form =
      let value = !(List.assoc token se.se_public_keys) in
533
      let service = Eliom_service.preapply election_setup_trustee_post token in
534 535 536 537 538 539
      post_form
        ~service
        (fun name ->
         [
           div [
             div [pcdata "Public key:"];
Stephane Glondu's avatar
Stephane Glondu committed
540
             div [textarea ~a:[a_rows 5; a_cols 40; a_id "pk"] ~name ~value ()];
541 542 543 544 545
             div [string_input ~input_type:`Submit ~value:"Submit" ()];
           ]
         ]
        ) ()
    in
Stephane Glondu's avatar
Stephane Glondu committed
546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566
    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
567
    let content = [
Stephane Glondu's avatar
Stephane Glondu committed
568 569
      group;
      interactivity;
570 571 572
      form;
    ] in
    let login_box = pcdata "" in
573
    base ~title ~login_box ~content ()
574

575

576 577
    let election_login_box w =
      let module W = (val w : WEB_ELECTION_) in
578
      let auth = (module W.S : AUTH_SERVICES) in
579 580 581
      let module L = struct
        let login x =
          Eliom_service.preapply
582
            election_login
583 584 585
            ((W.election.e_params.e_uuid, ()), x)
        let logout =
          Eliom_service.preapply
586
            election_logout
587 588 589 590
            (W.election.e_params.e_uuid, ())
      end in
      let links = (module L : AUTH_LINKS) in
      fun () -> make_login_box "" auth links
591

592 593
    let file w x =
      let module W = (val w : WEB_ELECTION_) in
594
      Eliom_service.preapply
595
        election_dir
596
        (W.election.e_params.e_uuid, x)
Stephane Glondu's avatar
Stephane Glondu committed
597

598 599
    let election_home w () =
      let module W = (val w : WEB_ELECTION_) in
600
      lwt user = W.S.get_user () in
601
      let params = W.election.e_params and m = W.metadata in
Stephane Glondu's avatar
Stephane Glondu committed
602 603 604
      lwt permissions =
        match user with
        | None ->
605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620
          (match m.e_voters with
          | Some `Any ->
            return [
              pcdata "Anybody can vote in this election.";
            ]
          | Some _ ->
            return [
              pcdata "Log in to check if you can vote. ";
              pcdata "Alternatively, you can try to vote and ";
              pcdata "log in at the last moment.";
            ]
          | None ->
            return [
              pcdata "Currently, nobody can vote in this election.";
            ]
          )
Stephane Glondu's avatar
Stephane Glondu committed
621
        | Some u ->
622
          let can = if check_acl m.e_voters u then "can" else "cannot" in
Stephane Glondu's avatar
Stephane Glondu committed
623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655
          Lwt.return [
            pcdata "You ";
            pcdata can;
            pcdata " vote in this election.";
          ]
      in
      let voting_period =
        match m.e_voting_starts_at, m.e_voting_ends_at with
        | None, None ->
          [
            pcdata "This election starts and ends at the administrator's discretion."
          ]
        | Some s, None ->
          [
            pcdata "This election starts on ";
            em [pcdata (format_date s)];
            pcdata " and ends at the administrator's discretion.";
          ]
        | None, Some s ->
          [
            pcdata "This election starts at the administrator's discretion and ends on ";
            em [pcdata (format_date s)];
            pcdata ".";
          ]
        | Some s, Some e ->
          [
            pcdata "This election starts on ";
            em [pcdata (format_date s)];
            pcdata " and ends on ";
            em [pcdata (format_date e)];
            pcdata ".";
          ]
      in
Stephane Glondu's avatar
Stephane Glondu committed
656 657 658 659 660 661 662 663
      let state =
        if !W.state = `Closed then
          [
            pcdata " ";
            b [pcdata "This election is currently closed."];
          ]
        else []
      in
664
      let ballots_link =
Stephane Glondu's avatar
Stephane Glondu committed
665 666 667 668 669
        p ~a:[a_style "text-align:center;"] [
            a
              ~a:[a_style "font-size:25px;"]
              ~service:election_pretty_ballots [
                pcdata "See accepted ballots"
670 671 672
              ] ((params.e_uuid, ()), 1)
          ]
      in
Stephane Glondu's avatar
Stephane Glondu committed
673
      let footer = div ~a:[a_style "line-height:1.5em;"] [
Stephane Glondu's avatar
Stephane Glondu committed
674
        div [
Stephane Glondu's avatar
Stephane Glondu committed
675
          div [
Stephane Glondu's avatar
Stephane Glondu committed
676
            pcdata "Election fingerprint: ";
677
            code [ pcdata W.election.e_fingerprint ];
Stephane Glondu's avatar
Stephane Glondu committed
678 679
          ];
          div [
Stephane Glondu's avatar
Stephane Glondu committed
680
            pcdata "Audit data: ";
681
            a ~service:(file w ESRaw) [
682 683
              pcdata "parameters"
            ] ();
Stephane Glondu's avatar
Stephane Glondu committed
684
            pcdata ", ";
685
            a ~service:(file w ESCreds) [
Stephane Glondu's avatar
Stephane Glondu committed
686 687 688
              pcdata "public credentials"
            ] ();
            pcdata ", ";
689
            a ~service:(file w ESKeys) [
Stephane Glondu's avatar
Stephane Glondu committed
690 691 692
              pcdata "trustee public keys"
            ] ();
            pcdata ", ";
693
            a ~service:(file w ESBallots) [
Stephane Glondu's avatar
Stephane Glondu committed
694 695
              pcdata "ballots";
            ] ();
Stephane Glondu's avatar
Stephane Glondu committed
696
            pcdata ".";
Stephane Glondu's avatar
Stephane Glondu committed
697
          ];
Stephane Glondu's avatar
Stephane Glondu committed
698
        ]
Stephane Glondu's avatar
Stephane Glondu committed
699 700
      ] in
      let content = [
Stephane Glondu's avatar
Stephane Glondu committed
701
        p (voting_period @ state);
Stephane Glondu's avatar
Stephane Glondu committed
702
        p permissions;
Stephane Glondu's avatar
Stephane Glondu committed
703 704
        br ();
        div ~a:[a_style "text-align:center;"] [
Stephane Glondu's avatar
Stephane Glondu committed
705
          div [
Stephane Glondu's avatar
Stephane Glondu committed
706
            make_button
707
              ~service:(Eliom_service.preapply election_vote (params.e_uuid, ()))
Stephane Glondu's avatar
Stephane Glondu committed
708
              "Go to the booth";
Stephane Glondu's avatar
Stephane Glondu committed
709 710 711 712
            ];
          div [
            pcdata "or ";
            a
713
              ~service:(Eliom_service.preapply election_cast (params.e_uuid, ()))
Stephane Glondu's avatar
Stephane Glondu committed
714
              [pcdata "submit a raw ballot"] ();
Stephane Glondu's avatar
Stephane Glondu committed
715 716 717
          ];
        ];
        br ();
Stephane Glondu's avatar
Stephane Glondu committed
718
        ballots_link;
Stephane Glondu's avatar
Stephane Glondu committed
719
      ] in
720
      lwt login_box = election_login_box w () in
Stephane Glondu's avatar
Stephane Glondu committed
721
      base ~title:params.e_name ~login_box ~content ~footer ()
Stephane Glondu's avatar
Stephane Glondu committed
722

723 724
    let election_admin w ~is_featured () =
      let module W = (val w : WEB_ELECTION_) in
725
      let title = W.election.e_params.e_name ^ " — Administration" in
726
      let feature_form = post_form ~service:election_set_featured
727
        (fun featured -> [
728 729 730
          bool_checkbox ~name:featured ~checked:is_featured ();
          pcdata "Feature this election ";
          string_input ~input_type:`Submit ~value:"Apply" ();
731
        ]) (W.election.e_params.e_uuid, ())
732
      in
Stephane Glondu's avatar
Stephane Glondu committed
733 734 735 736 737 738 739 740 741 742 743
      let state_form =
        let checked = !W.state = `Open in
        post_form
          ~service:election_set_state
          (fun name ->
           [
             bool_checkbox ~name ~checked ();
             pcdata "Open this election ";
             string_input ~input_type:`Submit ~value:"Apply" ();
           ]) (W.election.e_params.e_uuid, ())
      in
744
      let uuid = W.election.e_params.e_uuid in
745 746
      let content = [
        div [
747
          a ~service:Web_services.election_home [pcdata "Election home"] (uuid, ());
748 749
        ];
        div [
750
          a ~service:election_update_credential [pcdata "Update a credential"] (uuid, ());
751
        ];
752
        div [
753
          a ~service:election_dir [pcdata "Voting records"] (uuid, ESRecords);
754
        ];
755
        div [feature_form];
Stephane Glondu's avatar
Stephane Glondu committed
756
        div [state_form];
757 758
      ] in
      lwt login_box = site_login_box () in
759
      base ~title ~login_box ~content ()
760

761 762
    let update_credential w () =
      let module W = (val w : WEB_ELECTION_) in
763
      let params = W.election.e_params in
764
      let form = post_form ~service:election_update_credential_post
Stephane Glondu's avatar
Stephane Glondu committed
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782
        (fun (old, new_) ->
          [
            div [
              p [
                pcdata "\
                  This form allows you to change a single credential at \
                  a time. To get the hash of a credential, run the \
                  following command:\
                ";
              ];
              pre [
                pcdata "printf old-credential | sha256sum";
              ];
              p [
                pcdata "In the above command, ";
                code [pcdata "old-credential"];
                pcdata " should look like a big number written in base 10.";
              ];
Stephane Glondu's avatar
Stephane Glondu committed
783
            ];
Stephane Glondu's avatar
Stephane Glondu committed
784 785 786
            p [
              pcdata "Hash of the old credential: ";
              string_input ~name:old ~input_type:`Text ~a:[a_size 64] ();
Stephane Glondu's avatar
Stephane Glondu committed
787 788
            ];
            p [
Stephane Glondu's avatar
Stephane Glondu committed
789 790
              pcdata "New credential: ";
              string_input ~name:new_ ~input_type:`Text ~a:[a_size 617] ();
Stephane Glondu's avatar
Stephane Glondu committed
791
            ];
Stephane Glondu's avatar
Stephane Glondu committed
792 793
            p [string_input ~input_type:`Submit ~value:"Submit" ()];
          ]
794
        ) (params.e_uuid, ())
Stephane Glondu's avatar
Stephane Glondu committed
795 796 797 798
      in
      let content = [
        form;
      ] in
799
      lwt login_box = site_login_box () in
800
      base ~title:params.e_name ~login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
801

802 803
    let cast_raw w () =
      let module W = (val w : WEB_ELECTION_) in
804
      let params = W.election.e_params in
805
      let form_rawballot = post_form ~service:election_cast_post
Stephane Glondu's avatar
Stephane Glondu committed
806 807 808 809 810 811
        (fun (name, _) ->
          [
            div [pcdata "Please paste your raw ballot in JSON format in the following box:"];
            div [textarea ~a:[a_rows 10; a_cols 40] ~name ()];
            div [string_input ~input_type:`Submit ~value:"Submit" ()];
          ]
812
        ) (params.e_uuid, ())
Stephane Glondu's avatar
Stephane Glondu committed
813
      in
814
      let form_upload = post_form ~service:election_cast_post
Stephane Glondu's avatar
Stephane Glondu committed
815 816 817 818 819 820 821 822 823
        (fun (_, name) ->
          [
            div [pcdata "Alternatively, you can also upload a file containing your ballot:"];
            div [
              pcdata "File: ";
              file_input ~name ();
            ];
            div [string_input ~input_type:`Submit ~value:"Submit" ()];
          ]
824
        ) (params.e_uuid, ())
Stephane Glondu's avatar
Stephane Glondu committed
825 826 827 828 829 830 831
      in
      let content = [
        h3 [ pcdata "Submit by copy/paste" ];
        form_rawballot;
        h3 [ pcdata "Submit by file" ];
        form_upload;
      ] in
832
      lwt login_box = election_login_box w () in
833
      base ~title:params.e_name ~login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
834

835
    let cast_confirmation w ~can_vote hash () =
836
      let module W = (val w : WEB_ELECTION_) in
837
      lwt user = W.S.get_user () in
838
      let params = W.election.e_params in
Stephane Glondu's avatar
Stephane Glondu committed
839 840 841
      let name = params.e_name in
      let user_div = match user with
        | Some u when can_vote ->
842
          post_form ~service:election_cast_confirm (fun () -> [
843
            p ~a:[a_style "text-align: center; padding: 10px;"] [
Stephane Glondu's avatar
Stephane Glondu committed
844 845 846 847 848 849
              pcdata "I am ";
              format_user u;
              pcdata " and ";
              string_input ~input_type:`Submit ~value:"I confirm my vote" ();
              pcdata ".";
            ]
850
          ]) (params.e_uuid, ())
Stephane Glondu's avatar
Stephane Glondu committed
851 852 853 854 855 856 857 858 859
        | Some _ ->
          div [
            pcdata "You cannot vote in this election!";
          ]
        | None ->
          div [
            pcdata "Please log in to confirm your vote.";
          ]
      in
Stephane Glondu's avatar
Stephane Glondu committed
860
      let progress = div ~a:[a_style "text-align:center;margin-bottom:20px;"] [
Stephane Glondu's avatar
Stephane Glondu committed
861
        pcdata "Input credential — Answer to questions — Review and encrypt";
Stephane Glondu's avatar
Stephane Glondu committed
862 863 864 865 866
        pcdata " — Authenticate — ";
        b [pcdata "Confirm"];
        pcdata " — Done";
        hr ();
      ] in
Stephane Glondu's avatar
Stephane Glondu committed
867
      let content = [
Stephane Glondu's avatar
Stephane Glondu committed
868
        progress;
Stephane Glondu's avatar
Stephane Glondu committed
869 870 871
        p [
          pcdata "Your ballot for ";
          em [pcdata name];
872 873 874 875
          pcdata " has been received, but not recorded yet. ";
          pcdata "Your smart ballot tracker is ";
          b [pcdata hash];
          pcdata ".";
Stephane Glondu's avatar
Stephane Glondu committed
876 877 878
        ];
        user_div;
        p [
879 880
          (let service =
            Eliom_service.preapply
881
              Web_services.election_home (W.election.e_params.e_uuid, ())
882 883
          in
          a ~service [
Stephane Glondu's avatar
Stephane Glondu committed
884
            pcdata "Go back to election"
885
          ] ());
Stephane Glondu's avatar
Stephane Glondu committed
886 887 888
          pcdata ".";
        ];
      ] in
889
      lwt login_box = election_login_box w () in
890
      base ~title:name ~login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
891

892 893
    let cast_confirmed w ~result () =
      let module W = (val w : WEB_ELECTION_) in
894
      let params = W.election.e_params in
Stephane Glondu's avatar
Stephane Glondu committed
895
      let name = params.e_name in
Stephane Glondu's avatar
Stephane Glondu committed
896
      let progress = div ~a:[a_style "text-align:center;margin-bottom:20px;"] [
Stephane Glondu's avatar
Stephane Glondu committed
897
        pcdata "Input credential — Answer to questions — Review and encrypt";
Stephane Glondu's avatar
Stephane Glondu committed
898 899 900 901
        pcdata " — Authenticate — Confirm — ";
        b [pcdata "Done"];
        hr ();
      ] in
Stephane Glondu's avatar
Stephane Glondu committed
902
      let content = [
Stephane Glondu's avatar
Stephane Glondu committed
903
        progress;
Stephane Glondu's avatar
Stephane Glondu committed
904 905 906 907
        p [
          pcdata "Your ballot for ";
          em [pcdata name];
          (match result with
Stephane Glondu's avatar
Stephane Glondu committed
908
             | `Valid hash -> pcdata (" has been accepted, your smart ballot tracker is " ^ hash ^ ".")
Stephane Glondu's avatar
Stephane Glondu committed
909 910 911 912
             | `Error e -> pcdata (" is rejected, because " ^ Web_common.explain_error e ^ ".")
          );
        ];
        p [
913 914
          (let service =
            Eliom_service.preapply
915
              election_logout (params.e_uuid, ())
916 917
          in
          a ~service [
918
            pcdata "Log out"
919
          ] ());
Stephane Glondu's avatar
Stephane Glondu committed
920 921 922
          pcdata ".";
        ];
      ] in
923
      lwt login_box = election_login_box w () in
924
      base ~title:name ~login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
925

926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949
let pretty_ballots w hashes () =
  let module W = (val w : WEB_ELECTION_) in
  let params = W.election.e_params in
  let title = params.e_name ^ " — Accepted ballots" in
  let nballots = ref 0 in
  let ballots =
    List.rev_map
      (fun h ->
       incr nballots;
       li
         [a
            ~service:election_pretty_ballot
            [pcdata h]
            ((params.e_uuid, ()), h)]
      ) hashes
  in
  let links =
    p
      [a
         ~service:Web_services.election_home
         [pcdata "Back to election"]
         (params.e_uuid, ())]
  in
  let content = [
Stephane Glondu's avatar
Stephane Glondu committed
950
    p [pcdata "This is the list of ballots accepted so far."];
951 952 953 954
    ul ballots;
    links;
  ] in
  lwt login_box = election_login_box w () in
955
  base ~title ~login_box ~content ()