web_templates.ml 91.2 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.php"]
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 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380
let preview_booth uuid =
  let url =
    Eliom_uri.make_string_uri
      ~service:election_draft_preview ~absolute:true (uuid, ()) |>
      rewrite_prefix |>
      (fun x -> Filename.chop_suffix x "election.json")
  in
  let hash = Netencoding.Url.mk_url_encoded_parameters ["url", url] in
  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)."
    ]

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

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

741
let election_draft_threshold_trustees uuid se () =
742 743 744 745 746
  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
747
        ~service:election_draft_threshold_trustee_add
748 749 750
        (fun name ->
          [
            pcdata "Trustee's e-mail address: ";
Stephane Glondu's avatar
Stephane Glondu committed
751 752
            input ~input_type:`Text ~name string;
            input ~input_type:`Submit ~value:"Add" string;
753 754 755 756 757 758
          ]
        ) uuid
    else pcdata ""
  in
  let mk_form_trustee_del value =
    post_form
759
      ~service:election_draft_threshold_trustee_del
760 761
      (fun name ->
        [
Stephane Glondu's avatar
Stephane Glondu committed
762 763
          input ~input_type:`Hidden ~name ~value int;
          input ~input_type:`Submit ~value:"Remove" string;
764 765 766 767 768
      ]) uuid
  in
  let trustees = match se.se_threshold_trustees with
    | None -> pcdata ""
    | Some ts ->
769
       div [
770 771 772 773 774 775
       table (
         tr (
           [
             th [pcdata "Trustee"];
             th [pcdata "Mail"];
             th [pcdata "Link"];
776
             th [pcdata "State"];
777 778 779
           ] @ (if show_add_remove then [th [pcdata "Remove"]] else [])
         ) ::
           List.mapi (fun i t ->
780 781 782 783 784 785 786 787 788 789 790 791
               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
792 793 794 795 796 797 798 799
             tr (
                 [
                   td [
                       pcdata t.stt_id;
                     ];
                   td [
                       let uri = rewrite_prefix @@
                                   Eliom_uri.make_string_uri
800
                                     ~absolute:true ~service:election_draft_threshold_trustee (uuid, t.stt_token)
801 802 803 804 805 806
                       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 [
807
                       a ~service:election_draft_threshold_trustee [pcdata "Link"] (uuid, t.stt_token);
808 809
                     ];
                   td [
810
                       pcdata state;
811 812 813 814
                     ];
                 ] @ (if show_add_remove then [td [mk_form_trustee_del i]] else [])
               )
             ) ts
815 816
         );
       div [
817
           pcdata "Meaning of states:";
818
           ul [
819 820 821 822 823
               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"];
824 825 826 827
             ];
         ];
       br ();
       ]
828
  in
829
  let form_threshold, form_reset =
830
    match se.se_threshold_trustees with
831
    | None -> pcdata "", pcdata ""
832 833 834 835 836 837 838 839 840 841 842
    | 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)";
              ]
843 844
            ) uuid,
          pcdata ""
845
       | Some i ->
846 847 848 849 850 851
          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.";
            ],
852 853 854 855
          post_form ~service:election_draft_threshold_set
            (fun name ->
              [
                input ~input_type:`Hidden ~name ~value:0 int;
856
                input ~input_type:`Submit ~value:"Reset threshold" string;
857 858
              ]
            ) uuid
Stephane Glondu's avatar
Stephane Glondu committed
859
  in
860 861 862 863 864 865 866
  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 [
867
      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."];
868 869 870 871 872 873 874 875 876 877 878 879 880
      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;
881
      form_reset;
882 883 884
    ]
  in
  let back_link = div [
885 886
    a ~service:Web_services.election_draft
      [pcdata "Go back to election draft"] uuid;
887 888 889
  ] in
  let content = [
    div_content;
890
    br ();
891 892
    back_link;
  ] in
893 894
  let%lwt login_box = login_box () in
  base ~title ~login_box ~content ()
895

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

922
let election_draft_questions uuid se () =
923
  let title = "Questions for election " ^ se.se_questions.t_name in