web_templates.ml 71.4 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
let admin ~elections () =
170
  let title = site_title ^ " — Administration" in
171 172 173 174 175 176 177 178 179 180
  match elections with
  | None ->
     let content = [
       div [
         pcdata "To administer an election, you need to ";
         a ~service:site_login [pcdata "log in"] None;
         pcdata ". If you do not have an account, ";
         pcdata "please send an email to contact@belenios.org.";
       ]
     ] in
181
     let%lwt login_box = site_login_box () in
182
     base ~title ?login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
183
  | Some (elections, tallied, archived, setup_elections) ->
184 185 186
    let elections =
      match elections with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
187
      | _ -> ul @@ List.map format_election elections
188
    in
189 190 191
    let tallied =
      match tallied with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
192
      | _ -> ul @@ List.map format_election tallied
193
    in
Stephane Glondu's avatar
Stephane Glondu committed
194 195 196
    let archived =
      match archived with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
197
      | _ -> ul @@ List.map format_election archived
Stephane Glondu's avatar
Stephane Glondu committed
198
    in
199 200 201 202
    let setup_elections =
      match setup_elections with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@
203 204
         List.map (fun (k, title) ->
           li [a ~service:election_setup [pcdata title] k]
205 206 207 208
         ) setup_elections
    in
    let content = [
      div [
Stephane Glondu's avatar
Stephane Glondu committed
209 210 211 212 213
        div [
          a ~service:election_setup_pre [
            pcdata "Prepare a new election";
          ] ();
        ];
Stephane Glondu's avatar
Stephane Glondu committed
214
        div [br ()];
215 216
        h2 [pcdata "Elections being prepared"];
        setup_elections;
Stephane Glondu's avatar
Stephane Glondu committed
217
        div [br ()];
218 219
        h2 [pcdata "Elections you can administer"];
        elections;
220 221 222
        div [br ()];
        h2 [pcdata "Tallied elections"];
        tallied;
Stephane Glondu's avatar
Stephane Glondu committed
223
        div [br ()];
Stephane Glondu's avatar
Stephane Glondu committed
224 225
        h2 [pcdata "Archived elections"];
        archived;
226 227
      ];
    ] in
228
    let%lwt login_box = site_login_box () in
229
    base ~title ?login_box ~content ()
230

231
let make_button ~service ~disabled contents =
232 233
  let uri = Eliom_uri.make_string_uri ~service () in
  Printf.ksprintf Unsafe.data (* FIXME: unsafe *)
234 235
    "<button onclick=\"location.href='%s';\" style=\"font-size:35px;\"%s>%s</button>"
    uri (if disabled then " disabled" else "")
236 237
    contents

238 239 240
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)
241 242 243 244 245
    (Netencoding.Url.encode ~plus:false body)
  in
  Printf.ksprintf Unsafe.data "<a href=\"%s\">%s</a>"
    uri contents

246
let new_election_failure reason () =
247 248 249 250 251 252 253 254 255 256 257 258
  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
259
  let%lwt login_box = site_login_box () in
260
  base ~title ?login_box ~content ()
261

262 263 264 265 266 267 268 269
let generic_page ~title ?service message () =
  let proceed = match service with
    | None -> pcdata ""
    | Some service ->
       div [
         a ~service [pcdata "Proceed"] ();
       ]
  in
270 271
  let content = [
    p [pcdata message];
272
    proceed;
273
  ] in
274
  base ~title ~content ()
275

Stephane Glondu's avatar
Stephane Glondu committed
276 277
let election_setup_pre () =
  let title = "Prepare a new election" in
Stephane Glondu's avatar
Stephane Glondu committed
278
  let cred_info = Eliom_service.Http.external_service
279
    ~prefix:"http://www.belenios.org"
280
    ~path:["setup.php"]
Stephane Glondu's avatar
Stephane Glondu committed
281 282 283
    ~get_params:Eliom_parameter.unit
    ()
  in
Stephane Glondu's avatar
Stephane Glondu committed
284 285 286 287 288
  let form =
    post_form ~service:election_setup_new
      (fun (credmgmt, (auth, cas_server)) ->
        [
          fieldset
Stephane Glondu's avatar
Stephane Glondu committed
289 290 291 292 293
            ~legend:(legend [
              pcdata "Credential management (";
              a ~service:cred_info [pcdata "more info"] ();
              pcdata ")";
            ])
Stephane Glondu's avatar
Stephane Glondu committed
294 295 296
            [
              div [
                string_radio ~checked:true ~name:credmgmt ~value:"auto" ();
Stephane Glondu's avatar
Stephane Glondu committed
297
                pcdata " Automatic (degraded mode - credentials will be handled by the server)";
Stephane Glondu's avatar
Stephane Glondu committed
298 299 300
              ];
              div [
                string_radio ~name:credmgmt ~value:"manual" ();
Stephane Glondu's avatar
Stephane Glondu committed
301
                pcdata " Manual (safe mode - a third party will handle the credentials)";
Stephane Glondu's avatar
Stephane Glondu committed
302 303 304 305 306 307 308 309 310 311 312 313 314
              ];
            ];
          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 ();
315
                pcdata " (for example: https://cas.inria.fr/cas)";
Stephane Glondu's avatar
Stephane Glondu committed
316 317 318 319 320 321 322 323 324 325 326
              ];
            ];
          div [
            string_input ~input_type:`Submit ~value:"Proceed" ();
          ];
        ]
      ) ()
  in
  let content = [
    form
  ] in
327
  let%lwt login_box = site_login_box () in
328
  base ~title ?login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
329

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

500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529
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."

530 531 532 533 534
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
535 536
      (fun name ->
        [
Stephane Glondu's avatar
Stephane Glondu committed
537
          pcdata "Trustee's e-mail address: ";
538 539 540 541
          string_input ~input_type:`Text ~name ();
          string_input ~input_type:`Submit ~value:"Add" ();
        ]
      ) uuid
542
  in
543 544 545 546 547 548 549 550 551 552 553 554
  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
555
  let mk_form_trustee_del value =
556 557
    post_form
      ~service:election_setup_trustee_del
558 559 560 561 562 563 564 565 566 567 568
      (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 [
569 570 571
           th [pcdata "Trustee"];
           th [pcdata "Mail"];
           th [pcdata "Link"];
572 573 574 575 576
           th [pcdata "Done?"];
           th [pcdata "Remove"];
         ] ::
           List.mapi (fun i t ->
             tr [
577 578 579
               td [
                 pcdata t.st_id;
               ];
580
               td [
581
                   if t.st_token <> "" then (
582
                 let uri = rewrite_prefix @@ Eliom_uri.make_string_uri
583
                   ~absolute:true ~service:election_setup_trustee t.st_token
584 585 586
                 in
                 let body = Printf.sprintf mail_trustee_generation uri in
                 let subject = "Link to generate the decryption key" in
587
                 a_mailto ~dest:t.st_id ~subject ~body "Mail"
588 589 590
                   ) else (
                     pcdata "(server)"
                   )
591 592
               ];
               td [
593
                   if t.st_token <> "" then (
594
                   a ~service:election_setup_trustee [pcdata "Link"] t.st_token;
595 596 597
                   ) else (
                     pcdata "(server)"
                   )
598 599 600 601 602 603 604 605
               ];
               td [
                 pcdata (if t.st_public_key = "" then "No" else "Yes");
               ];
               td [mk_form_trustee_del i];
             ]
           ) ts
       )
606
  in
607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623
  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;
624
          form_trustees_add_server;
625 626 627
        ]
    else pcdata ""
  in
628 629 630
  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!"];
631 632 633 634 635
      div [
          pcdata "You can also set up the election so that only a ";
          a ~service:election_setup_threshold_trustees [pcdata "threshold"] uuid;
          pcdata " of trustees is needed to perform the decryption.";
        ];
636
      br ();
637
      div_trustees;
638 639
    ]
  in
640 641 642 643 644 645
  let back_link = div [
    a ~service:Web_services.election_setup
      [pcdata "Go back to election setup"] uuid;
  ] in
  let content = [
    div_content;
646
    import_link;
647 648
    back_link;
  ] in
649
  let%lwt login_box = site_login_box () in
650
  base ~title ?login_box ~content ()
651

652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679
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 ->
680
       div [
681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713
       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
714 715 716 717 718 719 720 721 722 723 724 725 726
         );
       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 ();
       ]
727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745
  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
746 747 748 749 750 751 752 753
  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
754 755 756 757 758 759 760 761 762 763
  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
764
      threshold_warning;
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788
      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
789
let election_setup_credential_authority _ se () =
790 791 792
  let title = "Credentials for election " ^ se.se_questions.t_name in
  let content = [
    div [
Stephane Glondu's avatar
Stephane Glondu committed
793
      pcdata "Please send the credential authority the following link:";
794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811
    ];
    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
812
  let%lwt login_box = site_login_box () in
813
  base ~title ?login_box ~content ()
814

815
let election_setup_questions uuid se () =
816
  let title = "Questions for election " ^ se.se_questions.t_name in
817 818 819 820 821 822 823 824
  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 ()];
825
         div [string_input ~input_type:`Submit ~value:"Save changes" ()]])
826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842
      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
843
  let%lwt login_box = site_login_box () in
844
  base ~title ?login_box ~content ()
845

846
let election_setup_voters uuid se maxvoters () =
847
  let title = "Voters for election " ^ se.se_questions.t_name in
Stephane Glondu's avatar
Stephane Glondu committed
848 849
  let form =
    post_form
850
      ~service:election_setup_voters_add
Stephane Glondu's avatar
Stephane Glondu committed
851 852
      (fun name ->
        [
853 854
          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
855 856
      uuid
  in
857 858 859 860 861 862 863 864 865 866
  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
867 868 869 870
  let has_passwords = match se.se_metadata.e_auth_config with
    | Some [{auth_system = "password"; _}] -> true
    | _ -> false
  in
871 872 873 874 875 876 877 878 879 880 881 882 883
  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"]
884
  in
885 886
  let voters =
    List.map (fun v ->
887 888
      tr (
        [td [pcdata v.sv_id]] @
889
        (if has_passwords then [td (format_password_cell v)] else []) @
890
        (if se.se_public_creds_received then [] else [td [mk_remove_button v.sv_id]])
891
      )
892 893
    ) se.se_voters
  in
894 895 896 897
  let form_passwords =
    if has_passwords then
      post_form ~service:election_setup_auth_genpwd
        (fun () ->
898
          [string_input ~input_type:`Submit ~value:"Generate and mail missing passwords" ()]
899 900 901
        ) uuid
    else pcdata ""
  in
902 903 904 905
  let voters =
    match voters with
    | [] -> div [pcdata "No voters"]
    | _ :: _ ->
906 907
       div [
         form_passwords;
908
         br ();
909 910 911
         table
           (tr (
             [th [pcdata "Identity"]] @
912
               (if has_passwords then [th [pcdata "Password sent?"]] else []) @
913 914 915
               (if se.se_public_creds_received then [] else [th [pcdata "Remove"]])
            ) :: voters)
       ]
916 917 918 919
  in
  let back = div [
    a ~service:Web_services.election_setup [pcdata "Return to setup page"] uuid;
  ] in
920 921 922 923 924
  let div_add =
    if se.se_public_creds_received then
      pcdata ""
    else
      div [
925 926 927 928 929
        div [
            pcdata "Please enter the identities of voters to add, one per line (max ";
            pcdata (string_of_int maxvoters);
            pcdata "):"
          ];
930 931 932 933 934 935 936 937 938
        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
939 940 941 942 943
  let div_import = div [
    a ~service:election_setup_import
      [pcdata "Import voters from another election"]
      uuid
  ] in
Stephane Glondu's avatar
Stephane Glondu committed
944
  let content = [
945
    back;
946
    div_import;
947
    br ();
948
    voters;
949
    div_add;
Stephane Glondu's avatar
Stephane Glondu committed
950
  ] in
951
  let%lwt login_box = site_login_box () in
952
  base ~title ?login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
953

954 955 956 957 958 959 960 961 962
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
963
  Printf.ksprintf Unsafe.data
964 965
    "<textarea id=\"%s\"%s%s>%s</textarea>"
    id rows cols contents
966

967
let election_setup_credentials token uuid se () =
968
  let title = "Credentials for election " ^ se.se_questions.t_name in
969 970 971 972 973 974 975 976 977
  let div_link =
    let url = Eliom_uri.make_string_uri ~absolute:true
                ~service:election_home (uuid, ()) |> rewrite_prefix
    in
    div [
        pcdata "The link to the election will be:";
        ul [li [pcdata url]];
      ]
  in
978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015
  let form_textarea =
    post_form
      ~service:election_setup_credentials_post
      (fun name ->
       [div
          [div [pcdata "Public credentials:"];
           div [textarea ~a:[a_id "pks"; a_rows 5; a_cols 40] ~name ()];
           div [string_input ~input_type:`Submit ~value:"Submit" ()]]])
      token
  in
  let disclaimer =
    p
      [
        b [pcdata "Note:"];
        pcdata " submitting a large (> 200) number of credentials using the above form may fail; in this case, you have to use the command-line tool and the form below.";
      ]
  in
  let form_file =
    post_form
      ~service:election_setup_credentials_post_file
      (fun name ->
       [div
          [h2 [pcdata "Submit by file"];
           div [pcdata "Use this form to upload public credentials generated with the command-line tool."];
           div [file_input ~name ()];
           div [string_input ~input_type:`Submit ~value:"Submit" ()]]])
      token
  in
  let div_download =
    p [a ~service:election_setup_credentials_download
           [pcdata "Download current file"]
           token]
  in
  let group =
    div
      ~a:[a_style "display:none;"]
      [
        div [pcdata "UUID:"];
Stephane Glondu's avatar
Stephane Glondu committed
1016
        div [unsafe_textarea "uuid" (raw_string_of_uuid uuid)];
1017
        div [pcdata "Group parameters:"];
1018
        div [unsafe_textarea "group" se.se_group];
1019 1020
      ]
  in