web_templates.ml 29.1 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 =
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 108 109 110 111 112 113 114
          div ~a:[a_id "bottom"] [
            pcdata "Powered by ";
            a ~service:source_code [pcdata "Belenios"] ();
            pcdata ". ";
            a ~service:admin [pcdata "Administer elections"] ();
            pcdata ".";
          ]
        ]]
Stephane Glondu's avatar
Stephane Glondu committed
115
       ]))
116

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

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

153 154 155 156 157 158 159 160 161
  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 [
162 163
        div [a ~service:new_election [pcdata "Create a new election"] ()];
        div [a ~service:election_setup_index [pcdata "Elections being prepared"] ()];
164 165 166 167 168 169 170
        h2 [pcdata "Elections you can administer"];
        elections;
      ];
    ] in
    lwt login_box = site_login_box () in
    base ~title ~login_box ~content

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

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

    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 ()];
              ]]
193
            ];
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
      base ~title ~login_box ~content
Stephane Glondu's avatar
Stephane Glondu committed
204

205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
    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
      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 248
    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
      base ~title ~login_box ~content

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

  end
Stephane Glondu's avatar
Stephane Glondu committed
265

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

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

275 276 277
  let new_election () =
    let title = "Create new election" in
    lwt body =
278
      let form = post_form ~service:new_election_post
279 280
        (fun (election, (metadata, (public_keys, public_creds))) ->
          [
281 282 283
            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 ";
284
              a ~service:tool [pcdata "web version"] ();
285 286
              pcdata ".";
            ];
287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
            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" ()];
          ]
        ) ()
306
      in
307
      let setup_form = post_form ~service:election_setup_new
308 309 310 311 312 313 314 315
        (fun () ->
         [
           h2 [pcdata "Prepare a new election"];
           div [string_input ~input_type:`Submit ~value:"Prepare a new election" ()]
         ]
        ) ()
      in
      return [form; setup_form]
316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338
    in
    let content = [
      div body;
    ] in
    lwt login_box = site_login_box () in
    base ~title ~login_box ~content

  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
    base ~title ~login_box ~content

339
  let election_setup_index uuids () =
340
    let service = election_setup in
341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381
    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
    base ~title ~login_box ~content

  let generic_error_page message () =
    let title = "Error" in
    let content = [
      p [pcdata message];
    ] in
    let login_box = pcdata "" in
    base ~title ~login_box ~content

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

442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460
  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
    base ~title ~login_box ~content

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

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

574

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

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

597 598
    let election_home w () =
      let module W = (val w : WEB_ELECTION_) in
599
      lwt user = W.S.get_user () in
600
      let params = W.election.e_params and m = W.metadata in
Stephane Glondu's avatar
Stephane Glondu committed
601 602 603
      lwt permissions =
        match user with
        | None ->
604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619
          (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
620
        | Some u ->
621
          let can = if check_acl m.e_voters u then "can" else "cannot" in
Stephane Glondu's avatar
Stephane Glondu committed
622 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
          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
655 656 657 658 659 660 661 662
      let state =
        if !W.state = `Closed then
          [
            pcdata " ";
            b [pcdata "This election is currently closed."];
          ]
        else []
      in
663 664 665 666 667 668 669
      let ballots_link =
        p [
            a ~service:election_pretty_ballots [
                pcdata "List of accepted ballots"
              ] ((params.e_uuid, ()), 1)
          ]
      in
Stephane Glondu's avatar
Stephane Glondu committed
670 671 672
      let audit_info = div [
        h3 [pcdata "Audit Info"];
        div [
Stephane Glondu's avatar
Stephane Glondu committed
673
          div [
Stephane Glondu's avatar
Stephane Glondu committed
674
            pcdata "Election fingerprint: ";
675
            code [ pcdata W.election.e_fingerprint ];
Stephane Glondu's avatar
Stephane Glondu committed
676 677
          ];
          div [
Stephane Glondu's avatar
Stephane Glondu committed
678
            pcdata "Election data: ";
679
            a ~service:(file w ESRaw) [
680 681
              pcdata "parameters"
            ] ();
Stephane Glondu's avatar
Stephane Glondu committed
682
            pcdata ", ";
683
            a ~service:(file w ESCreds) [
Stephane Glondu's avatar
Stephane Glondu committed
684 685 686
              pcdata "public credentials"
            ] ();
            pcdata ", ";
687
            a ~service:(file w ESKeys) [
Stephane Glondu's avatar
Stephane Glondu committed
688 689 690
              pcdata "trustee public keys"
            ] ();
            pcdata ", ";
691
            a ~service:(file w ESBallots) [
Stephane Glondu's avatar
Stephane Glondu committed
692 693
              pcdata "ballots";
            ] ();
Stephane Glondu's avatar
Stephane Glondu committed
694
            pcdata ".";
Stephane Glondu's avatar
Stephane Glondu committed
695
          ];
Stephane Glondu's avatar
Stephane Glondu committed
696
        ]
Stephane Glondu's avatar
Stephane Glondu committed
697 698 699 700 701
      ] in
      let content = [
        p ~a:[a_style "margin: 1em; padding: 2pt; font-style: italic; border: 1pt solid;"] [
          pcdata params.e_description
        ];
Stephane Glondu's avatar
Stephane Glondu committed
702
        p (voting_period @ state);
Stephane Glondu's avatar
Stephane Glondu committed
703
        p permissions;
Stephane Glondu's avatar
Stephane Glondu committed
704 705
        div [
          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 709 710
              "Go to the booth";
            pcdata " or ";
            make_button
711
              ~service:(Eliom_service.preapply election_cast (params.e_uuid, ()))
Stephane Glondu's avatar
Stephane Glondu committed
712 713 714
              "Submit a raw ballot";
          ];
        ];
715
        ballots_link;
Stephane Glondu's avatar
Stephane Glondu committed
716 717 718
        br ();
        audit_info;
      ] in
719
      lwt login_box = election_login_box w () in
720
      base ~title:params.e_name ~login_box ~content
Stephane Glondu's avatar
Stephane Glondu committed
721

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

760 761
    let update_credential w () =
      let module W = (val w : WEB_ELECTION_) in
762
      let params = W.election.e_params in
763
      let form = post_form ~service:election_update_credential_post
Stephane Glondu's avatar
Stephane Glondu committed
764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
        (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
782
            ];
Stephane Glondu's avatar
Stephane Glondu committed
783 784 785
            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
786 787
            ];
            p [
Stephane Glondu's avatar
Stephane Glondu committed
788 789
              pcdata "New credential: ";
              string_input ~name:new_ ~input_type:`Text ~a:[a_size 617] ();
Stephane Glondu's avatar
Stephane Glondu committed
790
            ];
Stephane Glondu's avatar
Stephane Glondu committed
791 792
            p [string_input ~input_type:`Submit ~value:"Submit" ()];
          ]
793
        ) (params.e_uuid, ())
Stephane Glondu's avatar
Stephane Glondu committed
794 795 796 797 798
      in
      let content = [
        h1 [ pcdata params.e_name ];
        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 832
      in
      let content = [
        h1 [ pcdata params.e_name ];
        h3 [ pcdata "Submit by copy/paste" ];
        form_rawballot;
        h3 [ pcdata "Submit by file" ];
        form_upload;
      ] in
833
      lwt login_box = election_login_box w () in
834
      base ~title:params.e_name ~login_box ~content
Stephane Glondu's avatar
Stephane Glondu committed
835

836 837
    let cast_confirmation w ~can_vote () =
      let module W = (val w : WEB_ELECTION_) in
838
      lwt user = W.S.get_user () in
839
      let params = W.election.e_params in
Stephane Glondu's avatar
Stephane Glondu committed
840 841 842
      let name = params.e_name in
      let user_div = match user with
        | Some u when can_vote ->
843
          post_form ~service:election_cast_confirm (fun () -> [
Stephane Glondu's avatar
Stephane Glondu committed
844 845 846 847 848 849 850
            div [
              pcdata "I am ";
              format_user u;
              pcdata " and ";
              string_input ~input_type:`Submit ~value:"I confirm my vote" ();
              pcdata ".";
            ]
851
          ]) (params.e_uuid, ())
Stephane Glondu's avatar
Stephane Glondu committed
852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869
        | Some _ ->
          div [
            pcdata "You cannot vote in this election!";
          ]
        | None ->
          div [
            pcdata "Please log in to confirm your vote.";
          ]
      in
      let content = [
        h1 [ pcdata name ];
        p [
          pcdata "Your ballot for ";
          em [pcdata name];
          pcdata " has been received, but not recorded yet.";
        ];
        user_div;
        p [
870 871
          (let service =
            Eliom_service.preapply
872
              Web_services.election_home (W.election.e_params.e_uuid, ())
873 874
          in
          a ~service [
Stephane Glondu's avatar
Stephane Glondu committed
875
            pcdata "Go back to election"
876
          ] ());
Stephane Glondu's avatar
Stephane Glondu committed
877 878 879
          pcdata ".";
        ];
      ] in
880
      lwt login_box = election_login_box w () in
881
      base ~title:name ~login_box ~content
Stephane Glondu's avatar
Stephane Glondu committed
882

883 884
    let cast_confirmed w ~result () =
      let module W = (val w : WEB_ELECTION_) in
885
      let params = W.election.e_params in
Stephane Glondu's avatar
Stephane Glondu committed
886 887 888 889 890 891 892 893 894 895 896 897
      let name = params.e_name in
      let content = [
        h1 [ pcdata name ];
        p [
          pcdata "Your ballot for ";
          em [pcdata name];
          (match result with
             | `Valid hash -> pcdata (" has been accepted, its hash is " ^ hash ^ ".")
             | `Error e -> pcdata (" is rejected, because " ^ Web_common.explain_error e ^ ".")
          );
        ];
        p [
898 899
          (let service =
            Eliom_service.preapply
900
              election_logout (params.e_uuid, ())
901 902
          in
          a ~service [
903
            pcdata "Log out"
904
          ] ());
Stephane Glondu's avatar
Stephane Glondu committed
905 906 907
          pcdata ".";
        ];
      ] in
908
      lwt login_box = election_login_box w () in
909
      base ~title:name ~login_box ~content
Stephane Glondu's avatar
Stephane Glondu committed
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 938 939
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 = [
    ul ballots;
    links;
  ] in
  lwt login_box = election_login_box w () in
  base ~title ~login_box ~content