web_templates.ml 75.3 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2016 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
Stephane Glondu's avatar
Stephane Glondu committed
23
open Serializable_builtin_t
24
open Serializable_j
Stephane Glondu's avatar
Stephane Glondu committed
25
open Signatures
Stephane Glondu's avatar
Stephane Glondu committed
26
open Common
27
open Web_serializable_j
28
open Web_signatures
29
open Web_common
30
open Web_services
Stephane Glondu's avatar
Stephane Glondu committed
31 32
open Eliom_content.Html5.F

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

Stephane Glondu's avatar
Stephane Glondu committed
35
let site_title = "Election Server"
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 47
  let%lwt user = S.get_user () in
  let%lwt auth_systems = S.get_auth_systems () in
48
  let body =
49 50 51 52 53
    match user with
    | Some user ->
      [
        div [
          pcdata "Logged in as ";
54
          format_user ~site user;
55 56 57
          pcdata ".";
        ];
        div [
Stephane Glondu's avatar
Stephane Glondu committed
58
          a ~a:[a_id "logout"] ~service:L.logout [pcdata "Log out"] ();
59 60 61 62
          pcdata ".";
        ];
      ]
    | None ->
63
       if site then
64 65 66 67
      [
        div [
          pcdata "Not logged in.";
        ];
68
        let auth_systems =
69
          auth_systems |>
70
          List.map (fun name ->
Stephane Glondu's avatar
Stephane Glondu committed
71 72
            a ~a:[a_id ("login_" ^ name)]
              ~service:(L.login (Some name)) [pcdata name] ()
73 74
          ) |> list_join (pcdata ", ")
        in
75
        div (
76
          [pcdata "Log in: ["] @ auth_systems @ [pcdata "]"]
77 78
        );
      ]
79
        else []
80 81 82 83
  in
  match body with
  | [] -> return None
  | _::_ -> return (Some (div ~a:[a_style style] body))
84

85 86
module Site_links = struct
  let login x = Eliom_service.preapply site_login x
Stephane Glondu's avatar
Stephane Glondu committed
87
  let logout = Eliom_service.preapply logout ()
88 89
end

90
module Site_auth = struct
91
  let get_user () = Web_state.get_site_user ()
Stephane Glondu's avatar
Stephane Glondu committed
92
  let get_auth_systems () =
93
    let%lwt l = Web_persist.get_auth_config None in
Stephane Glondu's avatar
Stephane Glondu committed
94
    return (List.map fst l)
95 96
end

97
let site_links = (module Site_links : AUTH_LINKS)
98
let site_auth = (module Site_auth : AUTH_SERVICES)
99

100
let site_login_box () =
101
  make_login_box ~site:true site_auth site_links
102

103
let belenios_url = Eliom_service.Http.external_service
104
  ~prefix:"http://www.belenios.org"
105 106 107 108
  ~path:[]
  ~get_params:Eliom_parameter.unit
  ()

109
let base ~title ?login_box ~content ?(footer = div []) ?uuid () =
110
  let%lwt language = Eliom_reference.get Web_state.language in
111
  let module L = (val Web_i18n.get_lang language) in
112 113 114
  let administer =
    match uuid with
    | None ->
115
       a ~service:admin [pcdata L.administer_elections] ()
116
    | Some uuid ->
117
       a ~service:election_admin [pcdata L.administer_this_election] (uuid, ())
118
  in
119 120 121 122 123 124 125 126
  let login_box = match login_box with
    | None ->
       div ~a:[a_style "float: right; padding: 10px;"] [
         img ~a:[a_height 70] ~alt:""
           ~src:(uri_of_string (fun () -> "/static/placeholder.png")) ();
       ]
    | Some x -> x
  in
127
  Lwt.return (html ~a:[a_dir `Ltr; a_xml_lang L.lang]
128 129 130 131 132 133 134 135
    (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 [
136
          div ~a:[a_style "float: left; padding: 10px;"] [
Stephane Glondu's avatar
Stephane Glondu committed
137
            a ~service:home [
138
              img ~alt:L.election_server ~a:[a_height 70]
Stephane Glondu's avatar
Stephane Glondu committed
139 140
                ~src:(uri_of_string (fun () -> "/static/logo.png")) ();
            ] ();
Stephane Glondu's avatar
Stephane Glondu committed
141
          ];
142
          login_box;
143
          h1 ~a:[a_style "text-align: center; padding: 20px;"] [pcdata title];
144
          div ~a:[a_style "clear: both;"] [];
Stephane Glondu's avatar
Stephane Glondu committed
145
        ];
Stephane Glondu's avatar
Stephane Glondu committed
146
      ];
147 148 149 150
      div ~a:[a_id "main"] content;
      div ~a:[a_id "footer"; a_style "text-align: center;" ] [
        div ~a:[a_id "bottom"] [
          footer;
151
          pcdata L.powered_by;
152 153
          a ~service:belenios_url [pcdata "Belenios"] ();
          pcdata ". ";
154
          a ~service:source_code [pcdata L.get_the_source_code] ();
155
          pcdata ". ";
156
          administer;
157
          pcdata ".";
158
        ]
159 160 161
      ]]
     ]))

Stephane Glondu's avatar
Stephane Glondu committed
162
let format_election election =
Stephane Glondu's avatar
Stephane Glondu committed
163
  let e = election.e_params in
Stephane Glondu's avatar
Stephane Glondu committed
164
  let service = election_admin in
165
  li [
166
    a ~service [pcdata e.e_name] (e.e_uuid, ());
167 168
  ]

169 170 171
let unsafe_a uri text =
  Printf.ksprintf Unsafe.data "<a href=\"%s\">%s</a>" uri text

172
let admin ~elections () =
173
  let title = site_title ^ " — Administration" in
174 175
  match elections with
  | None ->
176 177 178 179 180 181 182 183 184
     let contact = match !contact_uri with
       | None -> pcdata ""
       | Some uri ->
          div [
              pcdata "If you do not have any account, you may ";
              unsafe_a uri "contact us";
              pcdata ".";
            ]
     in
185 186
     let content = [
       div [
187 188 189 190
         pcdata "To administer an election, you need to log in using one";
         pcdata " of the authentication methods available in the upper";
         pcdata " right corner of this page.";
         contact;
191 192
       ]
     ] in
193
     let%lwt login_box = site_login_box () in
194
     base ~title ?login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
195
  | Some (elections, tallied, archived, setup_elections) ->
196 197 198
    let elections =
      match elections with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
199
      | _ -> ul @@ List.map format_election elections
200
    in
201 202 203
    let tallied =
      match tallied with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
204
      | _ -> ul @@ List.map format_election tallied
205
    in
Stephane Glondu's avatar
Stephane Glondu committed
206 207 208
    let archived =
      match archived with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
209
      | _ -> ul @@ List.map format_election archived
Stephane Glondu's avatar
Stephane Glondu committed
210
    in
211 212 213 214
    let setup_elections =
      match setup_elections with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@
215 216
         List.map (fun (k, title) ->
           li [a ~service:election_setup [pcdata title] k]
217 218 219 220
         ) setup_elections
    in
    let content = [
      div [
Stephane Glondu's avatar
Stephane Glondu committed
221 222 223 224 225
        div [
          a ~service:election_setup_pre [
            pcdata "Prepare a new election";
          ] ();
        ];
Stephane Glondu's avatar
Stephane Glondu committed
226
        div [br ()];
227 228
        h2 [pcdata "Elections being prepared"];
        setup_elections;
Stephane Glondu's avatar
Stephane Glondu committed
229
        div [br ()];
230 231
        h2 [pcdata "Elections you can administer"];
        elections;
232 233 234
        div [br ()];
        h2 [pcdata "Tallied elections"];
        tallied;
Stephane Glondu's avatar
Stephane Glondu committed
235
        div [br ()];
Stephane Glondu's avatar
Stephane Glondu committed
236 237
        h2 [pcdata "Archived elections"];
        archived;
238 239
      ];
    ] in
240
    let%lwt login_box = site_login_box () in
241
    base ~title ?login_box ~content ()
242

243
let make_button ~service ~disabled contents =
244 245
  let uri = Eliom_uri.make_string_uri ~service () in
  Printf.ksprintf Unsafe.data (* FIXME: unsafe *)
246 247
    "<button onclick=\"location.href='%s';\" style=\"font-size:35px;\"%s>%s</button>"
    uri (if disabled then " disabled" else "")
248 249
    contents

250 251 252
let a_mailto ~dest ~subject ~body contents =
  let uri = Printf.sprintf "mailto:%s?subject=%s&amp;body=%s" dest
    (Netencoding.Url.encode ~plus:false subject)
253 254 255 256 257
    (Netencoding.Url.encode ~plus:false body)
  in
  Printf.ksprintf Unsafe.data "<a href=\"%s\">%s</a>"
    uri contents

258
let new_election_failure reason () =
259 260 261 262 263 264 265 266 267 268 269 270
  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
271
  let%lwt login_box = site_login_box () in
272
  base ~title ?login_box ~content ()
273

274 275 276 277 278 279 280 281
let generic_page ~title ?service message () =
  let proceed = match service with
    | None -> pcdata ""
    | Some service ->
       div [
         a ~service [pcdata "Proceed"] ();
       ]
  in
282 283
  let content = [
    p [pcdata message];
284
    proceed;
285
  ] in
286
  base ~title ~content ()
287

Stephane Glondu's avatar
Stephane Glondu committed
288 289
let election_setup_pre () =
  let title = "Prepare a new election" in
Stephane Glondu's avatar
Stephane Glondu committed
290
  let cred_info = Eliom_service.Http.external_service
291
    ~prefix:"http://www.belenios.org"
292
    ~path:["setup.php"]
Stephane Glondu's avatar
Stephane Glondu committed
293 294 295
    ~get_params:Eliom_parameter.unit
    ()
  in
Stephane Glondu's avatar
Stephane Glondu committed
296 297 298 299 300
  let form =
    post_form ~service:election_setup_new
      (fun (credmgmt, (auth, cas_server)) ->
        [
          fieldset
Stephane Glondu's avatar
Stephane Glondu committed
301 302 303 304 305
            ~legend:(legend [
              pcdata "Credential management (";
              a ~service:cred_info [pcdata "more info"] ();
              pcdata ")";
            ])
Stephane Glondu's avatar
Stephane Glondu committed
306 307 308
            [
              div [
                string_radio ~checked:true ~name:credmgmt ~value:"auto" ();
Stephane Glondu's avatar
Stephane Glondu committed
309
                pcdata " Automatic (degraded mode - credentials will be handled by the server)";
Stephane Glondu's avatar
Stephane Glondu committed
310 311 312
              ];
              div [
                string_radio ~name:credmgmt ~value:"manual" ();
Stephane Glondu's avatar
Stephane Glondu committed
313
                pcdata " Manual (safe mode - a third party will handle the credentials)";
Stephane Glondu's avatar
Stephane Glondu committed
314 315 316 317 318 319 320 321 322 323 324 325 326
              ];
            ];
          fieldset
            ~legend:(legend [pcdata "Authentication"])
            [
              div [
                string_radio ~checked:true ~name:auth ~value:"password" ();
                pcdata " Password (passwords will be emailed to voters)";
              ];
              div [
                string_radio ~name:auth ~value:"cas" ();
                pcdata " CAS (external authentication server), server address: ";
                string_input ~input_type:`Text ~name:cas_server ();
327
                pcdata " (for example: https://cas.inria.fr/cas)";
Stephane Glondu's avatar
Stephane Glondu committed
328 329 330 331 332 333 334 335 336 337 338
              ];
            ];
          div [
            string_input ~input_type:`Submit ~value:"Proceed" ();
          ];
        ]
      ) ()
  in
  let content = [
    form
  ] in
339
  let%lwt login_box = site_login_box () in
340
  base ~title ?login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
341

342
let election_setup uuid se () =
343
  let title = "Preparation of election " ^ se.se_questions.t_name in
344 345 346 347 348 349 350 351
  let form_languages =
    post_form ~service:election_setup_languages
      (fun languages ->
        [
          div [
              pcdata "Languages: ";
              string_input ~name:languages ~input_type:`Text
                ~value:(string_of_languages se.se_metadata.e_languages) ();
352 353 354
              pcdata " (Available languages: ";
              pcdata (string_of_languages (Some available_languages));
              pcdata ")";
355 356 357 358 359 360 361 362 363 364 365 366 367 368 369
            ];
          div [
              pcdata "(This is a space-separated list of languages that will be used in emails sent by the server.)";
            ];
          div [
              string_input ~input_type:`Submit ~value:"Save changes" ();
            ];
        ]) uuid
  in
  let div_languages =
    div [
        h2 [pcdata "Languages"];
        form_languages;
      ]
  in
370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386
  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 [
387
            string_input ~input_type:`Submit ~value:"Save changes" ();
388 389 390 391 392 393 394 395 396 397
          ];
        ]
      ) uuid
  in
  let div_description =
    div [
      h2 [pcdata "Name and description of the election"];
      form_description;
    ]
  in
398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
  let form_contact =
    post_form ~service:election_setup_contact
      (fun contact ->
        [
          div [
              pcdata "Contact: ";
              let value =
                match se.se_metadata.e_contact with
                | Some x -> x
                | None -> ""
              in
              string_input ~name:contact ~input_type:`Text ~value ();
            ];
          div [
              pcdata "(If non-empty, this will be added to emails sent by the server. This is free-form, but we suggest that you use \"Name <user@example.org>\".)";
            ];
          div [
              string_input ~input_type:`Submit ~value:"Save changes" ();
            ];
        ]) uuid
  in
  let div_contact =
    div [
        h2 [pcdata "Contact"];
        form_contact;
      ]
  in
Stephane Glondu's avatar
Stephane Glondu committed
425 426 427
  let has_credentials = match se.se_metadata.e_cred_authority with
    | None -> false
    | Some _ -> true
428
  in
Stephane Glondu's avatar
Stephane Glondu committed
429 430 431 432 433
  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"
434
  in
Stephane Glondu's avatar
Stephane Glondu committed
435 436 437 438 439
  let div_auth =
    div [
      h2 [pcdata "Authentication"];
      match auth with
      | `Password ->
440 441
         div [
           pcdata "Authentication scheme: password ";
442 443 444 445
           post_form ~service:election_setup_auth_genpwd
             (fun () ->
               [string_input ~input_type:`Submit ~value:"Generate and mail missing passwords" ()]
             ) uuid;
446
         ]
Stephane Glondu's avatar
Stephane Glondu committed
447 448 449 450 451 452 453 454 455 456
      | `Dummy ->
         div [
           pcdata "Authentication scheme: dummy"
         ]
      | `CAS server ->
         div [
           pcdata "Authentication scheme: CAS with server ";
           pcdata server;
         ]
    ]
457
  in
458
  let div_questions =
Stephane Glondu's avatar
Stephane Glondu committed
459 460
    div [
      h2 [
Stephane Glondu's avatar
Stephane Glondu committed
461
        a ~a:[a_id "edit_questions"] ~service:election_setup_questions
Stephane Glondu's avatar
Stephane Glondu committed
462 463 464 465
          [pcdata "Edit questions"]
          uuid;
      ]
    ]
466
  in
Stephane Glondu's avatar
Stephane Glondu committed
467 468
  let div_voters =
    div [
Stephane Glondu's avatar
Stephane Glondu committed
469
      h2 [
Stephane Glondu's avatar
Stephane Glondu committed
470
        a ~a:[a_id "edit_voters"] ~service:election_setup_voters
Stephane Glondu's avatar
Stephane Glondu committed
471 472 473
          [pcdata "Edit voters"]
          uuid
      ];
Stephane Glondu's avatar
Stephane Glondu committed
474 475 476 477 478 479
      div [
        pcdata @@ string_of_int @@ List.length se.se_voters;
        pcdata " voter(s) registered";
      ];
    ]
  in
480 481 482
  let div_trustees =
    div [
      h2 [pcdata "Trustees"];
483 484 485 486 487 488
      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 "."];
489
    ]
490 491
  in
  let div_credentials =
492 493
    div [
      h2 [pcdata "Credentials"];
494
      if se.se_public_creds_received then (
Stephane Glondu's avatar
Stephane Glondu committed
495
        div [
496
          pcdata "Credentials have already been generated!"
Stephane Glondu's avatar
Stephane Glondu committed
497
        ]
498
      ) else (
499 500 501 502 503 504 505 506 507 508 509 510 511
        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
512
      )
513
    ]
514
  in
515 516 517 518
  let link_confirm = div [
    h2 [pcdata "Finalize creation"];
    a ~service:election_setup_confirm [pcdata "Create election"] uuid;
  ] in
519 520 521 522 523 524 525 526 527 528 529 530
  let form_destroy =
    post_form
      ~service:election_setup_destroy
      (fun () ->
        [
          div [
              h2 [pcdata "Destroy election"];
              string_input ~input_type:`Submit ~value:"Destroy election" ();
            ]
        ]
      ) uuid
  in
531
  let content = [
532 533
    div_description;
    hr ();
534 535
    div_languages;
    hr ();
536 537
    div_contact;
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
538 539
    div_questions;
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
540
    div_voters;
Stephane Glondu's avatar
Stephane Glondu committed
541
    hr ();
542
    div_credentials;
Stephane Glondu's avatar
Stephane Glondu committed
543
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
544
    div_auth;
Stephane Glondu's avatar
Stephane Glondu committed
545 546 547
    hr ();
    div_trustees;
    hr ();
548
    link_confirm;
549 550
    hr ();
    form_destroy;
551
  ] in
552
  let%lwt login_box = site_login_box () in
553
  base ~title ?login_box ~content ()
554

555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584
let mail_trustee_generation : ('a, 'b, 'c, 'd, 'e, 'f) format6 =
  "Dear trustee,

You will find below the link to generate your private decryption key, used to tally the election.

  %s

Here's the instructions:
1. click on the link
2. click on \"generate a new key pair\"
3. your private key will appear in another window or tab. Make sure
   you SAVE IT properly otherwise it will not possible to tally and the
   election will be canceled.
4. in the first window, click on \"submit\" to send the public part of
   your key, used encrypt the votes. For verification purposes, you
   should save this part (that starts with {\"pok\":{\"challenge\":\") ), for
   example sending yourself an email.

Regarding your private key, it is crucial you save it (otherwise the
election will be canceled) and store it securely (if your private key
is known together with the private keys of the other trustees, then
vote privacy is no longer guaranteed). We suggest two options:
1. you may store the key on a USB stick and store it in a safe.
2. Or you may simply print it and store it in a safe.
Of course, more cryptographic solutions are welcome as well.

Thank you for your help,

-- \nThe election administrator."

585 586 587 588 589
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
590 591
      (fun name ->
        [
Stephane Glondu's avatar
Stephane Glondu committed
592
          pcdata "Trustee's e-mail address: ";
593 594 595 596
          string_input ~input_type:`Text ~name ();
          string_input ~input_type:`Submit ~value:"Add" ();
        ]
      ) uuid
597
  in
598 599 600 601 602 603 604 605 606 607 608 609
  let form_trustees_add_server =
    match List.filter (fun {st_id; _} -> st_id = "server") se.se_public_keys with
    | [] ->
       post_form
         ~service:election_setup_trustee_add_server
         (fun () ->
           [
             string_input ~input_type:`Submit ~value:"Add the server" ()
           ]
         ) uuid
    | _ -> pcdata ""
  in
610
  let mk_form_trustee_del value =
611 612
    post_form
      ~service:election_setup_trustee_del
613 614 615 616 617 618 619 620 621 622 623
      (fun name ->
        [
          int_input ~input_type:`Hidden ~name ~value ();
          string_input ~input_type:`Submit ~value:"Remove" ();
        ]) uuid
  in
  let trustees = match se.se_public_keys with
    | [] -> pcdata ""
    | ts ->
       table (
         tr [
624 625 626
           th [pcdata "Trustee"];
           th [pcdata "Mail"];
           th [pcdata "Link"];
627 628 629 630 631
           th [pcdata "Done?"];
           th [pcdata "Remove"];
         ] ::
           List.mapi (fun i t ->
             tr [
632 633 634
               td [
                 pcdata t.st_id;
               ];
635
               td [
636
                   if t.st_token <> "" then (
637
                 let uri = rewrite_prefix @@ Eliom_uri.make_string_uri
638
                   ~absolute:true ~service:election_setup_trustee t.st_token
639 640 641
                 in
                 let body = Printf.sprintf mail_trustee_generation uri in
                 let subject = "Link to generate the decryption key" in
642
                 a_mailto ~dest:t.st_id ~subject ~body "Mail"
643 644 645
                   ) else (
                     pcdata "(server)"
                   )
646 647
               ];
               td [
648
                   if t.st_token <> "" then (
649
                   a ~service:election_setup_trustee [pcdata "Link"] t.st_token;
650 651 652
                   ) else (
                     pcdata "(server)"
                   )
653 654 655 656 657 658 659 660
               ];
               td [
                 pcdata (if t.st_public_key = "" then "No" else "Yes");
               ];
               td [mk_form_trustee_del i];
             ]
           ) ts
       )
661
  in
662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678
  let import_link = div [
                        a ~service:Web_services.election_setup_import_trustees
                          [pcdata "Import trustees from another election"] uuid
                      ]
  in
  let div_trustees =
    if se.se_threshold_trustees = None then
      div [
          trustees;
          (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;
679
          form_trustees_add_server;
680 681 682
        ]
    else pcdata ""
  in
683 684 685 686
  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 ();
687
      div_trustees;
688 689
    ]
  in
690 691 692 693 694 695
  let back_link = div [
    a ~service:Web_services.election_setup
      [pcdata "Go back to election setup"] uuid;
  ] in
  let content = [
    div_content;
696
    import_link;
697 698
    back_link;
  ] in
699
  let%lwt login_box = site_login_box () in
700
  base ~title ?login_box ~content ()
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
let election_setup_threshold_trustees uuid se () =
  let title = "Trustees for election " ^ se.se_questions.t_name in
  let show_add_remove = se.se_threshold = None in
  let form_trustees_add =
    if show_add_remove then
      post_form
        ~service:election_setup_threshold_trustee_add
        (fun name ->
          [
            pcdata "Trustee's e-mail address: ";
            string_input ~input_type:`Text ~name ();
            string_input ~input_type:`Submit ~value:"Add" ();
          ]
        ) uuid
    else pcdata ""
  in
  let mk_form_trustee_del value =
    post_form
      ~service:election_setup_threshold_trustee_del
      (fun name ->
        [
          int_input ~input_type:`Hidden ~name ~value ();
          string_input ~input_type:`Submit ~value:"Remove" ();
      ]) uuid
  in
  let trustees = match se.se_threshold_trustees with
    | None -> pcdata ""
    | Some ts ->
730
       div [
731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763
       table (
         tr (
           [
             th [pcdata "Trustee"];
             th [pcdata "Mail"];
             th [pcdata "Link"];
             th [pcdata "Step"];
           ] @ (if show_add_remove then [th [pcdata "Remove"]] else [])
         ) ::
           List.mapi (fun i t ->
             tr (
                 [
                   td [
                       pcdata t.stt_id;
                     ];
                   td [
                       let uri = rewrite_prefix @@
                                   Eliom_uri.make_string_uri
                                     ~absolute:true ~service:election_setup_threshold_trustee t.stt_token
                       in
                       let body = Printf.sprintf mail_trustee_generation uri in
                       let subject = "Link to generate the decryption key" in
                       a_mailto ~dest:t.stt_id ~subject ~body "Mail"
                     ];
                   td [
                       a ~service:election_setup_threshold_trustee [pcdata "Link"] t.stt_token;
                     ];
                   td [
                       pcdata (string_of_int (match t.stt_step with None -> 0 | Some x -> x));
                     ];
                 ] @ (if show_add_remove then [td [mk_form_trustee_del i]] else [])
               )
             ) ts
764 765 766 767 768 769 770 771 772 773 774 775 776
         );
       div [
           pcdata "Meaning of steps:";
           ul [
               li [pcdata "0: administrator needs to set threshold"];
               li [pcdata "1: action needed from trustee: generate private key"];
               li [pcdata "2, 4, 6: waiting for other trustees"];
               li [pcdata "3, 5: action needed from trustee: enter private key"];
               li [pcdata "7: the key establishment protocol is finished"];
             ];
         ];
       br ();
       ]
777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795
  in
  let form_threshold =
    div [
        let value =
          match se.se_threshold with
          | None -> 0
          | Some i -> i
        in
        post_form
          ~service:election_setup_threshold_set
          (fun name ->
            [
              pcdata "Threshold: ";
              int_input ~input_type:`Text ~name ~value ();
              string_input ~input_type:`Submit ~value:"Set" ();
            ]
          ) uuid
      ]
  in
Stephane Glondu's avatar
Stephane Glondu committed
796 797 798 799 800 801 802 803
  let threshold_warning =
    if show_add_remove then pcdata "" else
      div [
          b [pcdata "Warning:"];
          pcdata " any change will re-initialize the whole process.";
          pcdata " To edit trustees and restart the process, set to 0.";
        ]
  in
804 805 806 807 808 809 810 811 812 813
  let maybe_error =
    match se.se_threshold_error with
    | None -> pcdata ""
    | Some e -> div [b [pcdata "ERROR: "]; pcdata e; br (); br ()]
  in
  let div_content =
    div [
      div [pcdata "On this page, you can configure a group of trustees such that only a threshold of them is needed to perform the decryption."];
      br ();
      form_threshold;
Stephane Glondu's avatar
Stephane Glondu committed
814
      threshold_warning;
815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838
      br ();
      trustees;
      (if se.se_threshold_trustees <> None then
          div [
            pcdata "There is one link per trustee. Send each trustee her link.";
            br ();
            br ();
            maybe_error;
          ]
       else pcdata "");
      form_trustees_add;
    ]
  in
  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
  let%lwt login_box = site_login_box () in
  base ~title ?login_box ~content ()

Stephane Glondu's avatar
Stephane Glondu committed
839
let election_setup_credential_authority _ se () =
840 841 842
  let title = "Credentials for election " ^ se.se_questions.t_name in
  let content = [
    div [
Stephane Glondu's avatar
Stephane Glondu committed
843
      pcdata "Please send the credential authority the following link:";
844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861
    ];
    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
862
  let%lwt login_box = site_login_box () in
863
  base ~title ?login_box ~content ()
864

865
let election_setup_questions uuid se () =
866
  let title = "Questions for election " ^ se.se_questions.t_name in
867 868 869 870 871 872 873 874
  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 ()];
875
         div [string_input ~input_type:`Submit ~value:"Save changes" ()]])
876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892
      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;
  ] in
893
  let%lwt login_box = site_login_box () in
894
  base ~title ?login_box ~content ()
895

896
let election_setup_voters uuid se maxvoters () =
897
  let title = "Voters for election " ^ se.se_questions.t_name in
Stephane Glondu's avatar
Stephane Glondu committed
898 899
  let form =
    post_form
900
      ~service:election_setup_voters_add
Stephane Glondu's avatar
Stephane Glondu committed
901 902
      (fun name ->
        [
903 904
          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
905 906
      uuid
  in
907 908 909 910 911 912 913 914 915 916
  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
917 918 919 920
  let has_passwords = match se.se_metadata.e_auth_config with
    | Some [{auth_system = "password"; _}] -> true
    | _ -> false
  in
921 922 923 924 925 926 927 928 929 930 931 932 933
  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"]
934
  in
935 936
  let voters =
    List.map (fun v ->
937 938
      tr (
        [td [pcdata v.sv_id]] @
939
        (if has_passwords then [td (format_password_cell v)] else []) @
940
        (if se.se_public_creds_received then [] else [td [mk_remove_button v.sv_id]])
941
      )
942 943
    ) se.se_voters
  in
944 945 946 947
  let form_passwords =
    if has_passwords then
      post_form ~service:election_setup_auth_genpwd
        (fun () ->
948
          [string_input ~input_type:`Submit ~value:"Generate and mail missing passwords" ()]
949 950 951
        ) uuid
    else pcdata ""
  in
952 953 954 955
  let voters =
    match voters with
    | [] -> div [pcdata "No voters"]
    | _ :: _ ->
956 957
       div [
         form_passwords;
958
         br ();
959 960 961
         table
           (tr (
             [th [pcdata "Identity"]] @
962
               (if has_passwords then [th [pcdata "Password sent?"]] else []) @
963 964 965
               (if se.se_public_creds_received then [] else [th [pcdata "Remove"]])
            ) :: voters)
       ]
966 967 968 969
  in
  let back = div [
    a ~service:Web_services.election_setup [pcdata "Return to setup page"] uuid;
  ] in
970 971 972 973 974
  let div_add =
    if se.se_public_creds_received then
      pcdata ""
    else
      div [
975 976 977 978 979
        div [
            pcdata "Please enter the identities of voters to add, one per line (max ";
            pcdata (string_of_int maxvoters);
            pcdata "):"
          ];
980 981 982 983 984 985 986 987 988
        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
989 990 991 992 993
  let div_import = div [
    a ~service:election_setup_import
      [pcdata "Import voters from another election"]
      uuid
  ] in
Stephane Glondu's avatar
Stephane Glondu committed
994
  let content = [
995
    back;
996
    div_import;
997
    br ();
998
    voters;
999
    div_add;
Stephane Glondu's avatar
Stephane Glondu committed
1000
  ] in
1001
  let%lwt login_box = site_login_box () in
1002
  base ~title ?login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
1003

1004 1005 1006 1007 1008 1009 1010 1011 1012
let unsafe_textarea ?rows ?cols id contents =
  let rows = match rows with
    | None -> ""
    | Some i -> Printf.sprintf " rows=\"%d\"" i
  in
  let cols = match cols with
    | None -> ""
    | Some i -> Printf.sprintf " cols=\"%d\"" i
  in
1013
  Printf.ksprintf Unsafe.data
1014 1015
    "<textarea id=\"%s\"%s%s>%s</textarea>"
    id rows cols contents
1016

1017
let election_setup_credentials token uuid se () =
1018
  let title = "Credentials for election " ^ se.se_questions.t_name in
1019 1020