web_templates.ml 92.9 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2018 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_builtin_t
28
open Web_serializable_j
29
open Web_common
30
open Web_services
Stephane Glondu's avatar
Stephane Glondu committed
31 32
open Eliom_content.Html.F
open Eliom_content.Html.F.Form
Stephane Glondu's avatar
Stephane Glondu committed
33

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

Stephane Glondu's avatar
Stephane Glondu committed
36
let site_title = "Election Server"
37
let admin_background = " background: #FF9999;"
Stephane Glondu's avatar
Stephane Glondu committed
38

39 40 41
let unsafe_a uri text =
  Printf.ksprintf Unsafe.data "<a href=\"%s\">%s</a>" uri text

42 43 44 45
let static x =
  let service = Eliom_service.static_dir () in
  make_uri ~service ["static"; x]

46 47
let format_user ~site u =
  em [pcdata (if site then string_of_user u else u.user_name)]
48

49
let login_box ?cont () =
50
  let style = "float: right; text-align: right;" ^ admin_background in
51
  let%lwt user = Eliom_reference.get Web_state.site_user in
52
  let auth_systems = List.map (fun x -> x.auth_instance) !Web_config.site_auth_config in
53 54 55 56 57 58
  let cont = match cont with
    | None -> ContSiteHome
    | Some x -> x
  in
  let login service = Eliom_service.preapply site_login (Some service, cont) in
  let logout () = Eliom_service.preapply logout cont in
59
  let body =
60 61 62 63 64
    match user with
    | Some user ->
      [
        div [
          pcdata "Logged in as ";
65
          format_user ~site:true user;
66 67 68
          pcdata ".";
        ];
        div [
69
          a ~a:[a_id "logout"] ~service:(logout ()) [pcdata "Log out"] ();
70 71 72 73 74 75 76 77
          pcdata ".";
        ];
      ]
    | None ->
      [
        div [
          pcdata "Not logged in.";
        ];
78 79
        let auth_systems =
          List.map (fun name ->
80 81 82
              a ~a:[a_id ("login_" ^ name)]
                ~service:(login name) [pcdata name] ()
            ) auth_systems |> List.join (pcdata ", ")
83
        in
84
        div (
85
          [pcdata "Log in: ["] @ auth_systems @ [pcdata "]"]
86 87
        );
      ]
88
  in
89
  return (div ~a:[a_style style] body)
90

Stephane Glondu's avatar
Stephane Glondu committed
91
let belenios_url = Eliom_service.extern
92
  ~prefix:"http://www.belenios.org"
93
  ~path:[]
Stephane Glondu's avatar
Stephane Glondu committed
94
  ~meth:(Eliom_service.Get Eliom_parameter.unit)
95 96
  ()

97
let base ~title ?login_box ~content ?(footer = div []) ?uuid () =
98
  let%lwt language = Eliom_reference.get Web_state.language in
99
  let module L = (val Web_i18n.get_lang language) in
100 101 102
  let administer =
    match uuid with
    | None ->
103
       a ~service:admin [pcdata L.administer_elections] ()
104
    | Some uuid ->
105
       a ~service:election_admin ~a:[a_id ("election_admin_" ^ (raw_string_of_uuid uuid))] [pcdata L.administer_this_election] uuid
106
  in
107 108 109 110
  let login_box = match login_box with
    | None ->
       div ~a:[a_style "float: right; padding: 10px;"] [
         img ~a:[a_height 70] ~alt:""
111
           ~src:(static "placeholder.png") ();
112 113 114
       ]
    | Some x -> x
  in
115
  let%lwt warning = match !Web_config.warning_file with
116 117 118 119 120
    | None -> return @@ pcdata ""
    | Some f -> match%lwt read_file f with
                | None -> return @@ pcdata ""
                | Some x -> return @@ Unsafe.data (String.concat "\n" x)
  in
121
  Lwt.return (html ~a:[a_dir `Ltr; a_xml_lang L.lang]
Stephane Glondu's avatar
Stephane Glondu committed
122
    (head (Eliom_content.Html.F.title (pcdata title)) [
123
      script (pcdata "window.onbeforeunload = function () {};");
124
      link ~rel:[`Stylesheet] ~href:(static "site.css") ();
125 126 127 128 129
    ])
    (body [
      div ~a:[a_id "wrapper"] [
      div ~a:[a_id "header"] [
        div [
130
          div ~a:[a_style "float: left; padding: 10px;"] [
Stephane Glondu's avatar
Stephane Glondu committed
131
            a ~service:home [
132
              img ~alt:L.election_server ~a:[a_height 70]
133
                ~src:(static "logo.png") ();
Stephane Glondu's avatar
Stephane Glondu committed
134
            ] ();
Stephane Glondu's avatar
Stephane Glondu committed
135
          ];
136
          login_box;
137
          h1 ~a:[a_style "text-align: center; padding: 20px;"] [pcdata title];
138
          div ~a:[a_style "clear: both;"] [];
Stephane Glondu's avatar
Stephane Glondu committed
139
        ];
Stephane Glondu's avatar
Stephane Glondu committed
140
      ];
141
      warning;
142 143 144 145
      div ~a:[a_id "main"] content;
      div ~a:[a_id "footer"; a_style "text-align: center;" ] [
        div ~a:[a_id "bottom"] [
          footer;
146
          pcdata L.powered_by;
147
          a ~service:belenios_url [pcdata "Belenios"] ();
Stephane Glondu's avatar
Stephane Glondu committed
148
          Belenios_version.(
Stephane Glondu's avatar
Stephane Glondu committed
149
            Printf.ksprintf pcdata " %s (%s). " version build
Stephane Glondu's avatar
Stephane Glondu committed
150
          );
151
          a ~service:source_code [pcdata L.get_the_source_code] ();
152
          pcdata ". ";
153
          unsafe_a !Web_config.gdpr_uri "Privacy policy";
154
          pcdata ". ";
155
          administer;
156
          pcdata ".";
157
        ]
158 159 160
      ]]
     ]))

161
let privacy_notice cont =
162
  let title = site_title ^ " — Personal data processing notice" in
163
  let service = Eliom_service.preapply privacy_notice_accept cont in
164 165 166 167
  let content =
    [
      div [
          pcdata "To use this site, you must accept our ";
168
          unsafe_a !Web_config.gdpr_uri "personal data policy";
169 170
          pcdata ".";
        ];
171
      post_form ~service
172 173 174
        (fun () ->
          [
            div [
Stephane Glondu's avatar
Stephane Glondu committed
175
                input ~input_type:`Submit ~value:"Accept" string;
176 177 178 179 180 181 182
              ];
          ]
        ) ();
    ]
  in
  base ~title ~content ()

183 184
let format_election (uuid, name) =
  li [
185
    a ~service:election_admin ~a:[a_id ("election_admin_" ^ (raw_string_of_uuid uuid))] [pcdata name] uuid;
186 187 188 189
  ]

let format_draft_election (uuid, name) =
  li [
190
    a ~service:election_draft ~a:[a_id ("election_draft_" ^ (raw_string_of_uuid uuid))] [pcdata name] uuid;
191 192
  ]

193
let admin ~elections () =
194
  let title = site_title ^ " — Administration" in
195 196
  match elections with
  | None ->
197
     let contact = match !Web_config.contact_uri with
198 199 200 201 202 203 204 205
       | None -> pcdata ""
       | Some uri ->
          div [
              pcdata "If you do not have any account, you may ";
              unsafe_a uri "contact us";
              pcdata ".";
            ]
     in
206 207
     let content = [
       div [
208 209 210 211
         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;
212 213
       ]
     ] in
214
     let%lwt login_box = login_box ~cont:ContSiteAdmin () in
215
     base ~title ~login_box ~content ()
216 217 218 219 220 221
  | Some (draft, elections, tallied, archived) ->
    let draft =
      match draft with
      | [] -> p [pcdata "You own no such elections!"]
      | _ -> ul @@ List.map format_draft_election draft
    in
222 223 224
    let elections =
      match elections with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
225
      | _ -> ul @@ List.map format_election elections
226
    in
227 228 229
    let tallied =
      match tallied with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
230
      | _ -> ul @@ List.map format_election tallied
231
    in
Stephane Glondu's avatar
Stephane Glondu committed
232 233 234
    let archived =
      match archived with
      | [] -> p [pcdata "You own no such elections!"]
Stephane Glondu's avatar
Stephane Glondu committed
235
      | _ -> ul @@ List.map format_election archived
Stephane Glondu's avatar
Stephane Glondu committed
236
    in
237 238
    let content = [
      div [
Stephane Glondu's avatar
Stephane Glondu committed
239
        div [
240
          a ~service:election_draft_pre [
Stephane Glondu's avatar
Stephane Glondu committed
241 242 243
            pcdata "Prepare a new election";
          ] ();
        ];
Stephane Glondu's avatar
Stephane Glondu committed
244
        div [br ()];
245
        h2 [pcdata "Elections being prepared"];
246
        draft;
Stephane Glondu's avatar
Stephane Glondu committed
247
        div [br ()];
248 249
        h2 [pcdata "Elections you can administer"];
        elections;
250 251 252
        div [br ()];
        h2 [pcdata "Tallied elections"];
        tallied;
Stephane Glondu's avatar
Stephane Glondu committed
253
        div [br ()];
Stephane Glondu's avatar
Stephane Glondu committed
254 255
        h2 [pcdata "Archived elections"];
        archived;
256 257
      ];
    ] in
258 259
    let%lwt login_box = login_box () in
    base ~title ~login_box ~content ()
260

261
let make_button ~service ?hash ~disabled contents =
262
  let uri = Eliom_uri.make_string_uri ~service () in
263 264 265 266
  let uri = match hash with
    | None -> uri
    | Some x -> uri ^ "#" ^ x
  in
267
  Printf.ksprintf Unsafe.data (* FIXME: unsafe *)
268 269
    "<button onclick=\"location.href='%s';\" style=\"font-size:35px;\"%s>%s</button>"
    uri (if disabled then " disabled" else "")
270 271
    contents

272 273 274
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)
275 276 277 278 279
    (Netencoding.Url.encode ~plus:false body)
  in
  Printf.ksprintf Unsafe.data "<a href=\"%s\">%s</a>"
    uri contents

280
let new_election_failure reason () =
281 282 283 284 285 286 287 288 289 290 291 292
  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
293 294
  let%lwt login_box = login_box () in
  base ~title ~login_box ~content ()
295

296 297 298 299 300
let generic_page ~title ?service message () =
  let proceed = match service with
    | None -> pcdata ""
    | Some service ->
       div [
301
         a ~service ~a:[a_id "generic_proceed_link"] [pcdata "Proceed"] ();
302 303
       ]
  in
304 305
  let content = [
    p [pcdata message];
306
    proceed;
307
  ] in
308
  base ~title ~content ()
309

310
let election_draft_pre () =
Stephane Glondu's avatar
Stephane Glondu committed
311
  let title = "Prepare a new election" in
Stephane Glondu's avatar
Stephane Glondu committed
312
  let cred_info = Eliom_service.extern
313
    ~prefix:"http://www.belenios.org"
314
    ~path:["setup.html"]
Stephane Glondu's avatar
Stephane Glondu committed
315
    ~meth:(Eliom_service.Get Eliom_parameter.unit)
Stephane Glondu's avatar
Stephane Glondu committed
316 317
    ()
  in
Stephane Glondu's avatar
Stephane Glondu committed
318
  let form =
319
    post_form ~service:election_draft_new
Stephane Glondu's avatar
Stephane Glondu committed
320 321 322
      (fun (credmgmt, (auth, cas_server)) ->
        [
          fieldset
Stephane Glondu's avatar
Stephane Glondu committed
323 324 325 326 327
            ~legend:(legend [
              pcdata "Credential management (";
              a ~service:cred_info [pcdata "more info"] ();
              pcdata ")";
            ])
Stephane Glondu's avatar
Stephane Glondu committed
328 329
            [
              div [
Stephane Glondu's avatar
Stephane Glondu committed
330
                radio ~checked:true ~name:credmgmt ~value:"auto" string;
Stephane Glondu's avatar
Stephane Glondu committed
331
                pcdata " Automatic (degraded mode - credentials will be handled by the server)";
Stephane Glondu's avatar
Stephane Glondu committed
332 333
              ];
              div [
Stephane Glondu's avatar
Stephane Glondu committed
334
                radio ~name:credmgmt ~value:"manual" string;
Stephane Glondu's avatar
Stephane Glondu committed
335
                pcdata " Manual (safe mode - a third party will handle the credentials)";
Stephane Glondu's avatar
Stephane Glondu committed
336 337 338 339 340 341
              ];
            ];
          fieldset
            ~legend:(legend [pcdata "Authentication"])
            [
              div [
Stephane Glondu's avatar
Stephane Glondu committed
342
                radio ~checked:true ~name:auth ~value:"password" string;
Stephane Glondu's avatar
Stephane Glondu committed
343 344 345
                pcdata " Password (passwords will be emailed to voters)";
              ];
              div [
Stephane Glondu's avatar
Stephane Glondu committed
346
                radio ~name:auth ~value:"cas" string;
Stephane Glondu's avatar
Stephane Glondu committed
347
                pcdata " CAS (external authentication server), server address: ";
Stephane Glondu's avatar
Stephane Glondu committed
348
                input ~input_type:`Text ~name:cas_server string;
349
                pcdata " (for example: https://cas.inria.fr/cas)";
Stephane Glondu's avatar
Stephane Glondu committed
350 351 352
              ];
            ];
          div [
Stephane Glondu's avatar
Stephane Glondu committed
353
            input ~input_type:`Submit ~value:"Proceed" string;
Stephane Glondu's avatar
Stephane Glondu committed
354 355 356 357 358 359 360
          ];
        ]
      ) ()
  in
  let content = [
    form
  ] in
361 362
  let%lwt login_box = login_box () in
  base ~title ~login_box ~content ()
Stephane Glondu's avatar
Stephane Glondu committed
363

364
let preview_booth uuid =
365
  let hash = Netencoding.Url.mk_url_encoded_parameters ["uuid", raw_string_of_uuid uuid] in
366 367 368 369 370 371 372 373 374
  let service =
    Eliom_uri.make_string_uri
      ~service:election_vote ~absolute:true () |> rewrite_prefix
  in
  span [
      unsafe_a (service ^ "#" ^ hash) "Preview booth";
      pcdata " (you can use any credential such as HsqB3C3y62Ekq4D)."
    ]

375
let election_draft uuid se () =
376
  let title = "Preparation of election " ^ se.se_questions.t_name in
377
  let form_languages =
378
    post_form ~service:election_draft_languages
379 380 381 382
      (fun languages ->
        [
          div [
              pcdata "Languages: ";
Stephane Glondu's avatar
Stephane Glondu committed
383 384
              input ~name:languages ~input_type:`Text
                ~value:(string_of_languages se.se_metadata.e_languages) string;
385 386 387
              pcdata " (Available languages: ";
              pcdata (string_of_languages (Some available_languages));
              pcdata ")";
388 389
            ];
          div [
Stephane Glondu's avatar
Stephane Glondu committed
390
              pcdata "This is a space-separated list of languages that will be used in emails sent by the server.";
391 392
            ];
          div [
Stephane Glondu's avatar
Stephane Glondu committed
393
              input ~input_type:`Submit ~value:"Save changes" string;
394 395 396 397 398 399 400 401 402
            ];
        ]) uuid
  in
  let div_languages =
    div [
        h2 [pcdata "Languages"];
        form_languages;
      ]
  in
403
  let form_description =
404
    post_form ~service:election_draft_description
405 406 407 408
      (fun (name, description) ->
        [
          div [
            pcdata "Name of the election: ";
Stephane Glondu's avatar
Stephane Glondu committed
409 410
            input ~name:name
              ~input_type:`Text ~value:se.se_questions.t_name string;
411 412 413 414 415 416 417 418 419
          ];
          div [
            div [pcdata "Description of the election: "];
            div [
              textarea ~name:description ~a:[a_cols 80]
                ~value:se.se_questions.t_description ();
            ];
          ];
          div [
Stephane Glondu's avatar
Stephane Glondu committed
420
            input ~input_type:`Submit ~value:"Save changes" string;
421 422 423 424 425 426 427 428 429 430
          ];
        ]
      ) uuid
  in
  let div_description =
    div [
      h2 [pcdata "Name and description of the election"];
      form_description;
    ]
  in
431
  let form_contact =
432
    post_form ~service:election_draft_contact
433 434 435 436 437 438 439
      (fun contact ->
        [
          div [
              pcdata "Contact: ";
              let value =
                match se.se_metadata.e_contact with
                | Some x -> x
440
                | None -> default_contact
441
              in
Stephane Glondu's avatar
Stephane Glondu committed
442
              input ~name:contact ~input_type:`Text ~value string;
443 444
            ];
          div [
Stephane Glondu's avatar
Stephane Glondu committed
445
              pcdata "This contact will be added to emails sent to the voters.";
446 447
            ];
          div [
Stephane Glondu's avatar
Stephane Glondu committed
448
              input ~input_type:`Submit ~value:"Save changes" string;
449 450 451 452 453 454 455 456 457
            ];
        ]) uuid
  in
  let div_contact =
    div [
        h2 [pcdata "Contact"];
        form_contact;
      ]
  in
Stephane Glondu's avatar
Stephane Glondu committed
458 459 460
  let has_credentials = match se.se_metadata.e_cred_authority with
    | None -> false
    | Some _ -> true
461
  in
Stephane Glondu's avatar
Stephane Glondu committed
462 463 464 465
  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
466
    | _ -> failwith "unknown authentication scheme in election_draft"
467
  in
Stephane Glondu's avatar
Stephane Glondu committed
468 469 470 471 472
  let div_auth =
    div [
      h2 [pcdata "Authentication"];
      match auth with
      | `Password ->
473 474
         div [
           pcdata "Authentication scheme: password ";
475
           post_form ~service:election_draft_auth_genpwd
476
             (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
477
               [input ~input_type:`Submit ~value:"Generate and mail missing passwords" string]
478
             ) uuid;
479
         ]
Stephane Glondu's avatar
Stephane Glondu committed
480 481 482 483 484 485 486 487 488 489
      | `Dummy ->
         div [
           pcdata "Authentication scheme: dummy"
         ]
      | `CAS server ->
         div [
           pcdata "Authentication scheme: CAS with server ";
           pcdata server;
         ]
    ]
490
  in
491
  let div_questions =
Stephane Glondu's avatar
Stephane Glondu committed
492 493
    div [
      h2 [
494
        a ~a:[a_id "edit_questions"] ~service:election_draft_questions
Stephane Glondu's avatar
Stephane Glondu committed
495 496
          [pcdata "Edit questions"]
          uuid;
497 498
      ];
      preview_booth uuid;
Stephane Glondu's avatar
Stephane Glondu committed
499
    ]
500
  in
Stephane Glondu's avatar
Stephane Glondu committed
501 502
  let div_voters =
    div [
Stephane Glondu's avatar
Stephane Glondu committed
503
      h2 [
504
        a ~a:[a_id "edit_voters"] ~service:election_draft_voters
Stephane Glondu's avatar
Stephane Glondu committed
505 506 507
          [pcdata "Edit voters"]
          uuid
      ];
Stephane Glondu's avatar
Stephane Glondu committed
508 509 510 511 512 513
      div [
        pcdata @@ string_of_int @@ List.length se.se_voters;
        pcdata " voter(s) registered";
      ];
    ]
  in
514 515 516
  let div_trustees =
    div [
      h2 [pcdata "Trustees"];
517
      div [
518 519
          pcdata "By default, the election server manages the keys of the election (degraded privacy mode). ";
          pcdata "For real elections, the key must be shared among independent trustees. Click ";
520
          a ~service:election_draft_trustees [pcdata "here"] uuid;
521 522
          pcdata " to set up the election key.";
        ];
523
    ]
524 525
  in
  let div_credentials =
526 527
    div [
      h2 [pcdata "Credentials"];
528
      if se.se_public_creds_received then (
Stephane Glondu's avatar
Stephane Glondu committed
529
        div [
530
          pcdata "Credentials have already been generated!"
Stephane Glondu's avatar
Stephane Glondu committed
531
        ]
532
      ) else (
533 534 535
        div [
          pcdata "Warning: this will freeze the voter list!";
          if has_credentials then (
536
            post_form ~service:election_draft_credentials_server
537
              (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
538
                [input ~input_type:`Submit ~value:"Generate on server" string]
539 540 541
              ) uuid
          ) else (
            div [
542
              a ~service:election_draft_credential_authority [pcdata "Credential management"] uuid;
543 544 545
            ]
          );
        ]
Stephane Glondu's avatar
Stephane Glondu committed
546
      )
547
    ]
548
  in
549
  let link_confirm = div [
550
    h2 [pcdata "Validate creation"];
551
    a ~service:election_draft_confirm [pcdata "Create election"] uuid;
552
  ] in
553
  let form_destroy =
554
    let t = Option.get se.se_creation_date default_creation_date in
555
    let t = datetime_add t (day days_to_delete) in
556
    post_form
557
      ~service:election_draft_destroy
558 559 560 561
      (fun () ->
        [
          div [
              h2 [pcdata "Destroy election"];
562 563 564 565 566
              div [
                  pcdata "Note: this election will be automatically destroyed after ";
                  pcdata (format_datetime t);
                  pcdata ".";
                ];
Stephane Glondu's avatar
Stephane Glondu committed
567
              input ~input_type:`Submit ~value:"Destroy election" string;
568 569 570 571
            ]
        ]
      ) uuid
  in
572
  let content = [
573 574
    div_description;
    hr ();
575 576
    div_languages;
    hr ();
577 578
    div_contact;
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
579 580
    div_questions;
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
581
    div_voters;
Stephane Glondu's avatar
Stephane Glondu committed
582
    hr ();
583
    div_credentials;
Stephane Glondu's avatar
Stephane Glondu committed
584
    hr ();
Stephane Glondu's avatar
Stephane Glondu committed
585
    div_auth;
Stephane Glondu's avatar
Stephane Glondu committed
586 587 588
    hr ();
    div_trustees;
    hr ();
589
    link_confirm;
590 591
    hr ();
    form_destroy;
592
  ] in
593 594
  let%lwt login_box = login_box () in
  base ~title ~login_box ~content ()
595

596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625
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."

626
let election_draft_trustees uuid se () =
627 628 629
  let title = "Trustees for election " ^ se.se_questions.t_name in
  let form_trustees_add =
    post_form
630
      ~service:election_draft_trustee_add
631 632
      (fun name ->
        [
Stephane Glondu's avatar
Stephane Glondu committed
633
          pcdata "Trustee's e-mail address: ";
Stephane Glondu's avatar
Stephane Glondu committed
634 635
          input ~input_type:`Text ~name string;
          input ~input_type:`Submit ~value:"Add" string;
636 637
        ]
      ) uuid
638
  in
639
  let mk_form_trustee_del value =
640
    post_form
641
      ~service:election_draft_trustee_del
642 643
      (fun name ->
        [
Stephane Glondu's avatar
Stephane Glondu committed
644 645
          input ~input_type:`Hidden ~name ~value int;
          input ~input_type:`Submit ~value:"Remove" string;
646 647 648 649 650 651 652
        ]) uuid
  in
  let trustees = match se.se_public_keys with
    | [] -> pcdata ""
    | ts ->
       table (
         tr [
653 654 655
           th [pcdata "Trustee"];
           th [pcdata "Mail"];
           th [pcdata "Link"];
656 657 658 659 660
           th [pcdata "Done?"];
           th [pcdata "Remove"];
         ] ::
           List.mapi (fun i t ->
             tr [
661 662 663
               td [
                 pcdata t.st_id;
               ];
664
               td [
665
                   if t.st_token <> "" then (
666
                 let uri = rewrite_prefix @@ Eliom_uri.make_string_uri
667
                   ~absolute:true ~service:election_draft_trustee (uuid, t.st_token)
668 669 670
                 in
                 let body = Printf.sprintf mail_trustee_generation uri in
                 let subject = "Link to generate the decryption key" in
671
                 a_mailto ~dest:t.st_id ~subject ~body "Mail"
672 673 674
                   ) else (
                     pcdata "(server)"
                   )
675 676
               ];
               td [
677
                   if t.st_token <> "" then (
678
                   a ~service:election_draft_trustee [pcdata "Link"] (uuid, t.st_token);
679 680 681
                   ) else (
                     pcdata "(server)"
                   )
682 683 684 685
               ];
               td [
                 pcdata (if t.st_public_key = "" then "No" else "Yes");
               ];
686
               td [if t.st_id = "server" then pcdata "(cannot be removed)" else mk_form_trustee_del i];
687 688 689
             ]
           ) ts
       )
690
  in
691
  let import_link = div [
692
                        a ~service:Web_services.election_draft_import_trustees
693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710
                          [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;
        ]
    else pcdata ""
  in
711 712
  let div_content =
    div [
713
      div [
714
          pcdata "To set up the election key, you need to nominate trustees. Each trustee will create her own secret key. ";
715 716
          pcdata "To set up the election so that only a subset of trustees is needed, go to the ";
          a ~service:election_draft_threshold_trustees [pcdata "threshold mode"] uuid;
717
          pcdata ".";
718
        ];
719
      br ();
720
      div_trustees;
721 722
    ]
  in
723
  let back_link = div [
724 725
    a ~service:Web_services.election_draft
      [pcdata "Go back to election draft"] uuid;
726 727 728
  ] in
  let content = [
    div_content;
729
    import_link;
730 731
    back_link;
  ] in
732 733
  let%lwt login_box = login_box () in
  base ~title ~login_box ~content ()
734

735
let election_draft_threshold_trustees uuid se () =
736 737 738 739 740
  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
741
        ~service:election_draft_threshold_trustee_add
742 743 744
        (fun name ->
          [
            pcdata "Trustee's e-mail address: ";
Stephane Glondu's avatar
Stephane Glondu committed
745 746
            input ~input_type:`Text ~name string;
            input ~input_type:`Submit ~value:"Add" string;
747 748 749 750 751 752
          ]
        ) uuid
    else pcdata ""
  in
  let mk_form_trustee_del value =
    post_form
753
      ~service:election_draft_threshold_trustee_del
754 755
      (fun name ->
        [
Stephane Glondu's avatar
Stephane Glondu committed
756 757
          input ~input_type:`Hidden ~name ~value int;
          input ~input_type:`Submit ~value:"Remove" string;
758 759 760 761 762
      ]) uuid
  in
  let trustees = match se.se_threshold_trustees with
    | None -> pcdata ""
    | Some ts ->
763
       div [
764 765 766 767 768 769
       table (
         tr (
           [
             th [pcdata "Trustee"];
             th [pcdata "Mail"];
             th [pcdata "Link"];
770
             th [pcdata "State"];
771 772 773
           ] @ (if show_add_remove then [th [pcdata "Remove"]] else [])
         ) ::
           List.mapi (fun i t ->
774 775 776 777 778 779 780 781 782 783 784 785
               let state =
                 match t.stt_step with
                 | None -> "init"
                 | Some 1 -> "1a"
                 | Some 2 -> "1b"
                 | Some 3 -> "2a"
                 | Some 4 -> "2b"
                 | Some 5 -> "3a"
                 | Some 6 -> "3b"
                 | Some 7 -> "done"
                 | _ -> "unknown"
               in
786 787 788 789 790 791 792 793
             tr (
                 [
                   td [
                       pcdata t.stt_id;
                     ];
                   td [
                       let uri = rewrite_prefix @@
                                   Eliom_uri.make_string_uri
794
                                     ~absolute:true ~service:election_draft_threshold_trustee (uuid, t.stt_token)
795 796 797 798 799 800
                       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 [
801
                       a ~service:election_draft_threshold_trustee [pcdata "Link"] (uuid, t.stt_token);
802 803
                     ];
                   td [
804
                       pcdata state;
805 806 807 808
                     ];
                 ] @ (if show_add_remove then [td [mk_form_trustee_del i]] else [])
               )
             ) ts
809 810
         );
       div [
811
           pcdata "Meaning of states:";
812
           ul [
813 814 815 816 817
               li [pcdata "init: administrator needs to set threshold"];
               li [pcdata "1a: action needed from trustee: generate private key"];
               li [pcdata "2a, 3a: action needed from trustee: enter private key"];
               li [pcdata "1b, 2b, 3b: waiting for other trustees"];
               li [pcdata "done: the key establishment protocol is finished"];
818 819 820 821
             ];
         ];
       br ();
       ]
822
  in
823
  let form_threshold, form_reset =
824
    match se.se_threshold_trustees with
825
    | None -> pcdata "", pcdata ""
826 827 828 829 830 831 832 833 834 835 836
    | Some ts ->
       match se.se_threshold with
       | None ->
          post_form ~service:election_draft_threshold_set
            (fun name ->
              [
                pcdata "Threshold: ";
                input ~input_type:`Text ~name int;
                input ~input_type:`Submit ~value:"Set" string;
                pcdata " (the threshold must be smaller than the number of trustees)";
              ]
837 838
            ) uuid,
          pcdata ""
839
       | Some i ->
840 841 842 843 844 845
          div [
              pcdata (string_of_int i);
              pcdata " out of ";
              pcdata (string_of_int (List.length ts));
              pcdata " trustees will be needed to decrypt the result.";
            ],
846 847 848 849
          post_form ~service:election_draft_threshold_set
            (fun name ->
              [
                input ~input_type:`Hidden ~name ~value:0 int;
850
                input ~input_type:`Submit ~value:"Reset threshold" string;
851 852
              ]
            ) uuid
Stephane Glondu's avatar
Stephane Glondu committed
853
  in
854 855 856 857 858 859 860
  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 [
861
      div [pcdata "On this page, you can configure a group of trustees such that only a subset of them is needed to perform the decryption."];
862 863 864 865 866 867 868 869 870 871 872 873 874
      br ();
      form_threshold;
      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;
875
      form_reset;
876 877 878
    ]
  in
  let back_link = div [
879 880
    a ~service:Web_services.election_draft
      [pcdata "Go back to election draft"] uuid;
881 882 883
  ] in
  let content = [
    div_content;
884
    br ();
885 886
    back_link;
  ] in
887 888
  let%lwt login_box = login_box () in
  base ~title ~login_box ~content ()
889

890
let election_draft_credential_authority uuid se () =
891 892 893
  let title = "Credentials for election " ^ se.se_questions.t_name in
  let content = [
    div [
Stephane Glondu's avatar
Stephane Glondu committed
894
      pcdata "Please send the credential authority the following link:";
895 896 897 898
    ];
    ul [
      li [
        a
899
          ~service:election_draft_credentials
900 901 902
          [
            pcdata @@ rewrite_prefix @@ Eliom_uri.make_string_uri
              ~absolute:true
903
              ~service:election_draft_credentials
904
              (uuid, se.se_public_creds)
905
          ]
906
          (uuid, se.se_public_creds);
907 908 909 910 911 912
      ];
    ];
    div [
      pcdata "Note that this authority will have to send each credential to each voter herself.";
    ];
  ] in
913 914
  let%lwt login_box = login_box () in
  base ~title ~login_box ~content ()
915

916
let election_draft_questions uuid se () =
917
  let title = "Questions for election " ^ se.se_questions.t_name in
918 919 920
  let form =
    let value = string_of_template se.se_questions in
    post_form
921
      ~service:election_draft_questions_post
922 923 924 925
      (fun name ->
       [
         div [pcdata "Questions:"];
         div [textarea ~a:[a_id "questions"; a_rows 5; a_cols 80] ~name ~value ()];
Stephane Glondu's avatar
Stephane Glondu committed
926
         div [input ~input_type:`Submit ~value:"Save changes" string]])
927 928 929 930 931 932
      uuid
  in
  let interactivity =
    div
      ~a:[a_id "interactivity"]
      [
933 934 935 936 937
        script ~a:[a_src (static "sjcl.js")] (pcdata "");
        script ~a:[a_src (static "jsbn.js")] (pcdata "");
        script ~a:[a_src (static "jsbn2.js")] (pcdata "");
        script ~a:[a_src (static "random.js")] (pcdata "");
        script ~a:[a_src (static "tool_js_questions.js")] (pcdata "");
938 939
      ]
  in
940
  let preview = div [hr (); preview_booth uuid] in
941 942 943
  let content = [
    interactivity;
    form;
Stephane Glondu's avatar
Stephane Glondu committed
944
    preview;
945
  ] in
946 947
  let%lwt login_box = login_box () in
  base ~title ~login_box ~content ()
948

949
let election_draft_voters uuid se maxvoters () =
950
  let title = "Voters for election " ^ se.se_questions.t_name in
Stephane Glondu's avatar
Stephane Glondu committed
951 952
  let form =
    post_form
953
      ~service:election_draft_voters_add
Stephane Glondu's avatar
Stephane Glondu committed
954 955
      (fun name ->
        [
956
          div [textarea ~a:[a_rows 20; a_cols 50] ~name ()];
Stephane Glondu's avatar
Stephane Glondu committed
957
          div [input ~input_type:`Submit ~value:"Add" string]])
Stephane Glondu's avatar
Stephane Glondu committed
958 959
      uuid
  in
960 961
  let mk_remove_button id =
    post_form
962
      ~service:election_draft_voters_remove
963 964
      (fun name ->
        [
Stephane Glondu's avatar
Stephane Glondu committed
965 966
          input ~input_type:`Hidden ~name ~value:id string;
          input ~input_type:`Submit ~value:"Remove" string;
967 968 969
        ]
      ) uuid
  in
970 971 972 973
  let has_passwords = match se.se_metadata.e_auth_config with
    | Some [{auth_system = "password"; _}] -> true
    | _ -> false
  in
974
  let mk_regen_passwd value =
975
    post_form ~service:election_draft_voters_passwd
976 977 978
      ~a:[a_style "display: inline;"]
      (fun name ->
        [
Stephane Glondu's avatar
Stephane Glondu committed
979 980
          input ~input_type:`Hidden ~name ~value string;
          input ~input_type:`Submit ~value:"Send again" string;
981 982 983 984 985 986
        ]
      ) uuid
  in
  let format_password_cell x = match x.sv_password with
    | Some _ -> [pcdata "Yes "; mk_regen_passwd x.sv_id]
    | None -> [pcdata "No"]
987
  in
988 989
  let voters =
    List.map (fun v ->
990 991
      tr (
        [td [pcdata v.sv_id]] @
992
        (if has_passwords then [td (format_password_cell v)] else []) @
993
        (if se.se_public_creds_received then [] else [td [mk_remove_button v.sv_id]])
994
      )
995 996
    ) se.se_voters
  in
997 998
  let form_passwords =
    if has_passwords then
999
      post_form ~service:election_draft_auth_genpwd
1000
        (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
1001
          [input ~input_type:`Submit ~value:"Generate and mail missing passwords" string]
1002 1003 1004
        ) uuid
    else pcdata ""
  in
1005 1006 1007 1008
  let voters =
    match voters with
    | [] -> div [pcdata "No voters"]
    | _ :: _ ->
1009 1010
       div [
         form_passwords;
1011
         br ();
1012 1013 1014
         table
           (tr (
             [th [pcdata "Identity"]] @
Stephane Glondu's avatar