web_site.ml 82.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
23
open Platform
24
open Serializable_builtin_t
25
open Serializable_j
26
open Signatures
27
open Common
28
open Web_serializable_builtin_t
29
open Web_serializable_j
30
open Web_common
31
open Web_services
Stephane Glondu's avatar
Stephane Glondu committed
32

33
let source_file = ref "belenios.tar.gz"
34
let maxmailsatonce = ref 1000
35
let uuid_length = ref None
36
let default_group = ref ""
37

38 39
let ( / ) = Filename.concat

40
module PString = String
41

42 43 44 45 46
open Eliom_service
open Eliom_registration

module T = Web_templates

47
let raw_find_election uuid =
48
  let%lwt raw_election = Web_persist.get_raw_election uuid in
49 50
  match raw_election with
  | Some raw_election ->
51
     return (Election.of_string raw_election)
52
  | _ -> Lwt.fail Not_found
53

54
module WCacheTypes = struct
55
  type key = uuid
56
  type value = Yojson.Safe.json election
57 58 59 60 61
end

module WCache = Ocsigen_cache.Make (WCacheTypes)

let find_election =
Stephane Glondu's avatar
Stephane Glondu committed
62
  let cache = new WCache.cache raw_find_election ~timer:3600. 100 in
63 64
  fun x -> cache#find x

65 66 67
let dump_passwords uuid db =
  List.map (fun line -> PString.concat "," line) db |>
    write_file ~uuid "passwords.csv"
Stephane Glondu's avatar
Stephane Glondu committed
68

69
let validate_election uuid se =
70
  let uuid_s = raw_string_of_uuid uuid in
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
  (* voters *)
  let () =
    if se.se_voters = [] then failwith "no voters"
  in
  (* passwords *)
  let () =
    match se.se_metadata.e_auth_config with
    | Some [{auth_system = "password"; _}] ->
       if not @@ List.for_all (fun v -> v.sv_password <> None) se.se_voters then
         failwith "some passwords are missing"
    | _ -> ()
  in
  (* credentials *)
  let () =
    if not se.se_public_creds_received then
      failwith "public credentials are missing"
  in
  (* trustees *)
  let group = Group.of_string se.se_group in
  let module G = (val group : GROUP) in
91 92 93 94 95 96 97 98 99 100 101
  let%lwt y, trustees, pk_or_tp, private_keys =
    match se.se_threshold_trustees with
    | None ->
       let module KG = Trustees.MakeSimple (G) (LwtRandom) in
       let%lwt trustees, public_keys, private_key =
         match se.se_public_keys with
         | [] ->
            let%lwt private_key = KG.generate () in
            let%lwt public_key = KG.prove private_key in
            return (None, [public_key], `KEY private_key)
         | _ :: _ ->
102 103 104 105 106 107 108 109 110 111 112 113
            let private_key =
              List.fold_left (fun accu {st_private_key; _} ->
                  match st_private_key with
                  | Some x -> x :: accu
                  | None -> accu
                ) [] se.se_public_keys
            in
            let private_key = match private_key with
              | [] -> `None
              | [x] -> `KEY x
              | _ -> failwith "multiple private keys"
            in
114 115 116 117 118 119 120
            return (
                Some (List.map (fun {st_id; _} -> st_id) se.se_public_keys),
                (List.map
                   (fun {st_public_key; _} ->
                     if st_public_key = "" then failwith "some public keys are missing";
                     trustee_public_key_of_string G.read st_public_key
                   ) se.se_public_keys),
121
                private_key)
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
       in
       let y = KG.combine (Array.of_list public_keys) in
       return (y, trustees, `PK public_keys, private_key)
    | Some ts ->
       match se.se_threshold_parameters with
       | None -> failwith "key establishment not finished"
       | Some tp ->
          let tp = threshold_parameters_of_string G.read tp in
          let module P = Trustees.MakePKI (G) (LwtRandom) in
          let module C = Trustees.MakeChannels (G) (LwtRandom) (P) in
          let module K = Trustees.MakePedersen (G) (LwtRandom) (P) (C) in
          let trustees = List.map (fun {stt_id; _} -> stt_id) ts in
          let private_keys =
            List.map (fun {stt_voutput; _} ->
                match stt_voutput with
                | Some v ->
                   let voutput = voutput_of_string G.read v in
                   voutput.vo_private_key
                | None -> failwith "inconsistent state"
              ) ts
          in
          let y = K.combine tp in
          return (y, Some trustees, `TP tp, `KEYS private_keys)
145 146
  in
  (* election parameters *)
147 148 149 150 151 152 153 154 155
  let e_server_is_trustee = match private_keys with
      | `KEY _ -> Some true
      | `None | `KEYS _ -> None
  in
  let metadata = {
      se.se_metadata with
      e_trustees = trustees;
      e_server_is_trustee;
    } in
156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
  let template = se.se_questions in
  let params = {
    e_description = template.t_description;
    e_name = template.t_name;
    e_public_key = {wpk_group = G.group; wpk_y = y};
    e_questions = template.t_questions;
    e_uuid = uuid;
  } in
  let raw_election = string_of_params (write_wrapped_pubkey G.write_group G.write) params in
  (* write election files to disk *)
  let dir = !spool_dir / uuid_s in
  let create_file fname what xs =
    Lwt_io.with_file
      ~flags:(Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC]))
      ~perm:0o600 ~mode:Lwt_io.Output (dir / fname)
      (fun oc ->
        Lwt_list.iter_s
          (fun v ->
174 175
            let%lwt () = Lwt_io.write oc (what v) in
            Lwt_io.write oc "\n") xs)
176
  in
177 178 179 180 181 182 183 184
  let%lwt () =
    match pk_or_tp with
    | `PK pk -> create_file "public_keys.jsons" (string_of_trustee_public_key G.write) pk
    | `TP tp -> create_file "threshold.json" (string_of_threshold_parameters G.write) [tp]
  in
  let%lwt () = create_file "voters.txt" (fun x -> x.sv_id) se.se_voters in
  let%lwt () = create_file "metadata.json" string_of_metadata [metadata] in
  let%lwt () = create_file "election.json" (fun x -> x) [raw_election] in
185
  (* construct Web_election instance *)
186 187 188 189
  let election = Election.of_string raw_election in
  let module W = (val Election.get_group election) in
  let module E = Election.Make (W) (LwtRandom) in
  let module B = Web_election.Make (E) in
190
  (* initialize credentials *)
191
  let%lwt () =
192
    let fname = !spool_dir / uuid_s / "public_creds.txt" in
193 194
    match%lwt read_file fname with
    | Some xs ->
195
       let%lwt () = Web_persist.init_credential_mapping uuid xs in
196
       Lwt_unix.unlink fname
197
    | None -> return_unit
198
  in
199
  (* create file with private keys, if any *)
200
  let%lwt () =
201 202 203 204
    match private_keys with
    | `None -> return_unit
    | `KEY x -> create_file "private_key.json" string_of_number [x]
    | `KEYS x -> create_file "private_keys.jsons" (fun x -> x) x
205
  in
206
  (* clean up draft *)
207
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "draft.json") in
208
  (* write passwords *)
209 210 211 212 213 214 215 216 217 218 219 220 221 222
  let%lwt () =
    match metadata.e_auth_config with
    | Some [{auth_system = "password"; _}] ->
       let db =
         List.filter_map (fun v ->
             let _, login = split_identity v.sv_id in
             match v.sv_password with
             | Some (salt, hashed) -> Some [login; salt; hashed]
             | None -> None
           ) se.se_voters
       in
       if db <> [] then dump_passwords uuid db else return_unit
    | _ -> return_unit
  in
223
  (* finish *)
224
  let%lwt () = Web_persist.set_election_state uuid `Open in
225
  Web_persist.set_election_date `Validation uuid (now ())
226

227
let delete_sensitive_data uuid =
228
  let uuid_s = raw_string_of_uuid uuid in
229
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "state.json") in
230
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "decryption_tokens.json") in
231
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "partial_decryptions.json") in
232
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "extended_records.jsons") in
233
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "credential_mappings.jsons") in
234
  let%lwt () = rmdir (!spool_dir / uuid_s / "ballots") in
235
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "private_key.json") in
236
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "private_keys.jsons") in
237 238 239 240
  return_unit

let archive_election uuid =
  let%lwt () = delete_sensitive_data uuid in
241
  let%lwt () = Web_persist.set_election_date `Archive uuid (now ()) in
242 243
  return_unit

244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272
let delete_election uuid =
  let uuid_s = raw_string_of_uuid uuid in
  let%lwt () = delete_sensitive_data uuid in
  let%lwt election = raw_find_election uuid in
  let%lwt metadata = Web_persist.get_election_metadata uuid in
  let de_template = {
      t_description = "";
      t_name = election.e_params.e_name;
      t_questions =
        Array.map (fun q ->
            {
              q_answers = Array.map (fun _ -> "") q.q_answers;
              q_blank = q.q_blank;
              q_min = q.q_min;
              q_max = q.q_max;
              q_question = "";
            }
          ) election.e_params.e_questions
    }
  in
  let de_owner = match metadata.e_owner with
    | None -> Printf.ksprintf failwith "election %s has no owner" uuid_s
    | Some x -> x
  in
  let%lwt de_date =
    let%lwt date = Web_persist.get_election_date `Tally uuid in
    match date with
    | Some x -> return x
    | None ->
273
       let%lwt date = Web_persist.get_election_date `Validation uuid in
274 275 276 277 278 279
       match date with
       | Some x -> return x
       | None ->
          let%lwt date = Web_persist.get_election_date `Creation uuid in
          match date with
          | Some x -> return x
280
          | None -> return default_validation_date
281 282
  in
  let de_authentication_method = match metadata.e_auth_config with
283 284 285
    | Some [{auth_system = "cas"; auth_config; _}] ->
       let server = List.assoc "server" auth_config in
       `CAS server
286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333
    | Some [{auth_system = "password"; _}] -> `Password
    | _ -> `Unknown
  in
  let de_credential_method = match metadata.e_cred_authority with
    | Some "server" -> `Automatic
    | _ -> `Manual
  in
  let%lwt de_trustees_threshold =
    let%lwt threshold = Web_persist.get_threshold uuid in
    match threshold with
    | None -> return None
    | Some x ->
       let x = threshold_parameters_of_string Yojson.Safe.read_json x in
       return (Some x.t_threshold)
  in
  let%lwt pks = Web_persist.get_public_keys uuid in
  let%lwt voters = Web_persist.get_voters uuid in
  let%lwt ballots = Web_persist.get_ballot_hashes uuid in
  let%lwt result = Web_persist.get_election_result uuid in
  let de = {
      de_uuid = uuid;
      de_template;
      de_owner;
      de_nb_voters = (match voters with None -> 0 | Some x -> List.length x);
      de_nb_ballots = List.length ballots;
      de_date;
      de_tallied = result <> None;
      de_authentication_method;
      de_credential_method;
      de_nb_trustees = (match pks with None -> 0 | Some x -> List.length x);
      de_trustees_threshold;
      de_server_is_trustee = metadata.e_server_is_trustee = Some true;
    }
  in
  let%lwt () = write_file ~uuid "deleted.json" [string_of_deleted_election de] in
  let files_to_delete = [
      "election.json";
      "ballots.jsons";
      "dates.json";
      "encrypted_tally.json";
      "metadata.json";
      "passwords.csv";
      "public_creds.txt";
      "public_keys.jsons";
      "threshold.json";
      "records";
      "result.json";
      "voters.txt";
334
      "archive.zip";
335 336 337 338 339 340 341 342
    ]
  in
  let%lwt () = Lwt_list.iter_p (fun x ->
                   cleanup_file (!spool_dir / uuid_s / x)
                 ) files_to_delete
  in
  return_unit

343 344
let () = Any.register ~service:home
  (fun () () ->
345
    let%lwt () = Eliom_reference.unset Web_state.cont in
Stephane Glondu's avatar
Stephane Glondu committed
346
    Redirection.send (Redirection admin)
347 348
  )

349 350 351 352 353
let get_elections_by_owner_sorted u =
  let%lwt elections = Web_persist.get_elections_by_owner u in
  let filter kind =
    List.filter (fun (x, _, _, _) -> x = kind) elections |>
    List.map (fun (_, a, b, c) -> a, b, c)
354
  in
355 356 357 358
  let draft = filter `Draft in
  let elections = filter `Validated in
  let tallied = filter `Tallied in
  let archived = filter `Archived in
359
  let sort l =
360 361
    List.sort (fun (_, x, _) (_, y, _) -> datetime_compare x y) l |>
    List.map (fun (x, _, y) -> x, y)
362
  in
363
  return (sort draft, sort elections, sort tallied, sort archived)
364

365 366 367 368 369
let with_site_user f =
  match%lwt Web_state.get_site_user () with
  | Some u -> f u
  | None -> forbidden ()

370 371 372
let () =
  Redirection.register ~service:admin_gdpr_accept
    (fun () () ->
373
      let%lwt () = Eliom_reference.set Web_state.show_cookie_disclaimer false in
Stephane Glondu's avatar
Stephane Glondu committed
374
      return (Redirection admin)
375 376
    )

Stephane Glondu's avatar
Stephane Glondu committed
377
let () = Html.register ~service:admin
378
  (fun () () ->
379 380
    let%lwt gdpr = Eliom_reference.get Web_state.show_cookie_disclaimer in
    if gdpr then T.admin_gdpr () else
Stephane Glondu's avatar
Stephane Glondu committed
381
    let cont () = Redirection.send (Redirection admin) in
382
    let%lwt () = Eliom_reference.set Web_state.cont [cont] in
383 384
    let%lwt site_user = Web_state.get_site_user () in
    let%lwt elections =
385
      match site_user with
386
      | None -> return None
387
      | Some u ->
388 389
         let%lwt elections = get_elections_by_owner_sorted u in
         return @@ Some elections
390
    in
391
    T.admin ~elections ()
392 393
  )

394
let () = File.register ~service:source_code
395 396 397
  ~content_type:"application/x-gzip"
  (fun () () -> return !source_file)

398 399
let generate_uuid =
  let gen = Uuidm.v4_gen (Random.State.make_self_init ()) in
400 401 402 403 404 405
  fun () ->
  match !uuid_length with
  | Some length ->
     let%lwt token = generate_token ~length () in
     return @@ uuid_of_raw_string token
  | None -> return @@ uuid_of_raw_string @@ Uuidm.to_string @@ gen ()
406

Stephane Glondu's avatar
Stephane Glondu committed
407
let redir_preapply s u () = Redirection.send (Redirection (preapply s u))
408

Stephane Glondu's avatar
Stephane Glondu committed
409 410 411 412 413 414 415 416 417 418
let create_new_election owner cred auth =
  let e_cred_authority = match cred with
    | `Automatic -> Some "server"
    | `Manual -> None
  in
  let e_auth_config = match auth with
    | `Password -> Some [{auth_system = "password"; auth_instance = "password"; auth_config = []}]
    | `Dummy -> Some [{auth_system = "dummy"; auth_instance = "dummy"; auth_config = []}]
    | `CAS server -> Some [{auth_system = "cas"; auth_instance = "cas"; auth_config = ["server", server]}]
  in
419
  let%lwt uuid = generate_uuid () in
420
  let%lwt token = generate_token () in
Stephane Glondu's avatar
Stephane Glondu committed
421 422 423 424
  let se_metadata = {
    e_owner = Some owner;
    e_auth_config;
    e_cred_authority;
425
    e_trustees = None;
426
    e_languages = Some ["en"; "fr"];
427
    e_contact = None;
428
    e_server_is_trustee = None;
Stephane Glondu's avatar
Stephane Glondu committed
429 430
  } in
  let se_questions = {
431 432
    t_description = default_description;
    t_name = default_name;
433
    t_questions = default_questions;
Stephane Glondu's avatar
Stephane Glondu committed
434 435 436
  } in
  let se = {
    se_owner = owner;
437
    se_group = !default_group;
Stephane Glondu's avatar
Stephane Glondu committed
438 439 440 441 442
    se_voters = [];
    se_questions;
    se_public_keys = [];
    se_metadata;
    se_public_creds = token;
443
    se_public_creds_received = false;
444 445 446 447
    se_threshold = None;
    se_threshold_trustees = None;
    se_threshold_parameters = None;
    se_threshold_error = None;
448
    se_creation_date = Some (now ());
Stephane Glondu's avatar
Stephane Glondu committed
449
  } in
450 451
  let%lwt () = Lwt_unix.mkdir (!spool_dir / raw_string_of_uuid uuid) 0o700 in
  let%lwt () = Web_persist.set_draft_election uuid se in
452
  redir_preapply election_draft uuid ()
Stephane Glondu's avatar
Stephane Glondu committed
453

Stephane Glondu's avatar
Stephane Glondu committed
454
let () = Html.register ~service:election_draft_pre
455
  (fun () () -> T.election_draft_pre ())
Stephane Glondu's avatar
Stephane Glondu committed
456

457
let () = Any.register ~service:election_draft_new
Stephane Glondu's avatar
Stephane Glondu committed
458
  (fun () (credmgmt, (auth, cas_server)) ->
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473
    with_site_user (fun u ->
        let%lwt credmgmt = match credmgmt with
          | Some "auto" -> return `Automatic
          | Some "manual" -> return `Manual
          | _ -> fail_http 400
        in
        let%lwt auth = match auth with
          | Some "password" -> return `Password
          | Some "dummy" -> return `Dummy
          | Some "cas" -> return @@ `CAS cas_server
          | _ -> fail_http 400
        in
        create_new_election u credmgmt auth
      )
  )
474

475
let with_draft_election_ro uuid f =
476
  with_site_user (fun u ->
477 478 479
      match%lwt Web_persist.get_draft_election uuid with
      | None -> fail_http 404
      | Some se -> if se.se_owner = u then f se else forbidden ()
480
    )
481

482
let () =
Stephane Glondu's avatar
Stephane Glondu committed
483
  Html.register ~service:election_draft
484
    (fun uuid () ->
485 486
      with_draft_election_ro uuid (fun se ->
          T.election_draft uuid se ()
487 488
        )
    )
489

490
let () =
491
  Any.register ~service:election_draft_trustees
492
    (fun uuid () ->
493
      with_draft_election_ro uuid (fun se ->
494
          match se.se_threshold_trustees with
Stephane Glondu's avatar
Stephane Glondu committed
495
          | None -> T.election_draft_trustees uuid se () >>= Html.send
496
          | Some _ -> redir_preapply election_draft_threshold_trustees uuid ()
497 498
        )
    )
499

500
let () =
Stephane Glondu's avatar
Stephane Glondu committed
501
  Html.register ~service:election_draft_threshold_trustees
502
    (fun uuid () ->
503 504
      with_draft_election_ro uuid (fun se ->
          T.election_draft_threshold_trustees uuid se ()
505 506
        )
    )
507

508
let () =
Stephane Glondu's avatar
Stephane Glondu committed
509
  Html.register ~service:election_draft_credential_authority
510
    (fun uuid () ->
511 512
      with_draft_election_ro uuid (fun se ->
          T.election_draft_credential_authority uuid se ()
513 514
        )
    )
515

516
let election_draft_mutex = Lwt_mutex.create ()
517

518
let with_draft_election ?(save = true) uuid f =
519
  with_site_user (fun u ->
520
      Lwt_mutex.with_lock election_draft_mutex (fun () ->
521 522 523
          match%lwt Web_persist.get_draft_election uuid with
          | None -> fail_http 404
          | Some se ->
524 525
          if se.se_owner = u then (
            try%lwt
526
              let%lwt r = f se in
527
              let%lwt () = if save then Web_persist.set_draft_election uuid se else return_unit in
528
              return r
529
            with e ->
530
              let msg = match e with Failure s -> s | _ -> Printexc.to_string e in
531
              let service = preapply election_draft uuid in
532
              T.generic_page ~title:"Error" ~service msg () >>= Html.send
533 534 535
          ) else forbidden ()
        )
    )
536

537
let () =
538
  Any.register ~service:election_draft_languages
539
    (fun uuid languages ->
540
      with_draft_election uuid (fun se ->
541 542
          let langs = languages_of_string languages in
          match langs with
543
          | [] ->
544
             let service = preapply election_draft uuid in
545
             T.generic_page ~title:"Error" ~service
Stephane Glondu's avatar
Stephane Glondu committed
546
               "You must select at least one language!" () >>= Html.send
547
          | _ :: _ ->
548 549 550
             let unavailable =
               List.filter (fun x ->
                   not (List.mem x available_languages)
551
                 ) langs
552 553 554 555 556
             in
             match unavailable with
             | [] ->
                se.se_metadata <- {
                   se.se_metadata with
557
                   e_languages = Some langs
558
                 };
559
                redir_preapply election_draft uuid ()
560
             | l :: _ ->
561
                let service = preapply election_draft uuid in
562
                T.generic_page ~title:"Error" ~service
Stephane Glondu's avatar
Stephane Glondu committed
563
                  ("No such language: " ^ l) () >>= Html.send
564 565
        )
    )
566

567
let () =
568
  Any.register ~service:election_draft_contact
569
    (fun uuid contact ->
570
      with_draft_election uuid (fun se ->
571 572 573 574 575
          let contact =
            if contact = "" || contact = default_contact then
              None
            else Some contact
          in
576 577 578 579
          se.se_metadata <- {
              se.se_metadata with
              e_contact = contact
            };
580
          redir_preapply election_draft uuid ()
581 582 583
        )
    )

584
let () =
585
  Any.register ~service:election_draft_description
586
    (fun uuid (name, description) ->
587
      with_draft_election uuid (fun se ->
588 589 590 591
          se.se_questions <- {se.se_questions with
                               t_name = name;
                               t_description = description;
                             };
592
          redir_preapply election_draft uuid ()
593 594
        )
    )
595

596
let generate_password metadata langs title url id =
597
  let email, login = split_identity id in
598 599
  let%lwt salt = generate_token () in
  let%lwt password = generate_token () in
600
  let hashed = sha256_hex (salt ^ password) in
Stephane Glondu's avatar
Stephane Glondu committed
601 602
  let bodies = List.map (fun lang ->
    let module L = (val Web_i18n.get_lang lang) in
603 604
    let contact = T.contact_footer metadata L.please_contact in
    Printf.sprintf L.mail_password title login password url contact
Stephane Glondu's avatar
Stephane Glondu committed
605 606 607
  ) langs in
  let body = PString.concat "\n\n----------\n\n" bodies in
  let body = body ^ "\n\n-- \nBelenios" in
608 609 610 611 612
  let subject =
    let lang = List.hd langs in
    let module L = (val Web_i18n.get_lang lang) in
    Printf.sprintf L.mail_password_subject title
  in
613
  let%lwt () = send_email email subject body in
614
  return (salt, hashed)
615

616
let handle_password se uuid ~force voters =
617 618
  if List.length voters > !maxmailsatonce then
    Lwt.fail (Failure (Printf.sprintf "Cannot send passwords, there are too many voters (max is %d)" !maxmailsatonce))
619 620
  else if se.se_questions.t_name = default_name then
    Lwt.fail (Failure "The election name has not been edited!")
621
  else
622 623 624 625
  let title = se.se_questions.t_name in
  let url = Eliom_uri.make_string_uri ~absolute:true ~service:election_home
    (uuid, ()) |> rewrite_prefix
  in
626
  let langs = get_languages se.se_metadata.e_languages in
627 628 629 630 631
  let%lwt () =
    Lwt_list.iter_s (fun id ->
        match id.sv_password with
        | Some _ when not force -> return_unit
        | None | Some _ ->
632
           let%lwt x = generate_password se.se_metadata langs title url id.sv_id in
633 634 635
           return (id.sv_password <- Some x)
      ) voters
  in
636
  let service = preapply election_draft uuid in
637
  T.generic_page ~title:"Success" ~service
Stephane Glondu's avatar
Stephane Glondu committed
638
    "Passwords have been generated and mailed!" () >>= Html.send
639

640
let () =
641
  Any.register ~service:election_draft_auth_genpwd
642
    (fun uuid () ->
643
      with_draft_election uuid (fun se ->
644 645 646
          handle_password se uuid ~force:false se.se_voters
        )
    )
647

648
let () =
649
  Any.register ~service:election_regenpwd
Stephane Glondu's avatar
Stephane Glondu committed
650 651
    (fun uuid () ->
      T.regenpwd uuid () >>= Html.send)
652

653 654 655 656 657
let find_user_id uuid user =
  let uuid_s = raw_string_of_uuid uuid in
  let db = Lwt_io.lines_of_file (!spool_dir / uuid_s / "voters.txt") in
  let%lwt db = Lwt_stream.to_list db in
  let rec loop = function
658
    | [] -> None
659 660
    | id :: xs ->
       let _, login = split_identity id in
661 662
       if login = user then Some id else loop xs
  in return (loop db)
663

664 665 666 667 668 669 670 671 672 673 674 675
let load_password_db uuid =
  let uuid_s = raw_string_of_uuid uuid in
  let db = !spool_dir / uuid_s / "passwords.csv" in
  Lwt_preemptive.detach Csv.load db

let rec replace_password username ((salt, hashed) as p) = function
  | [] -> []
  | ((username' :: _ :: _ :: rest) as x) :: xs ->
     if username = username' then (username :: salt :: hashed :: rest) :: xs
     else x :: (replace_password username p xs)
  | x :: xs -> x :: (replace_password username p xs)

676
let () =
677
  Any.register ~service:election_regenpwd_post
Stephane Glondu's avatar
Stephane Glondu committed
678
    (fun uuid user ->
679
      with_site_user (fun u ->
680
          let%lwt election = find_election uuid in
681
          let%lwt metadata = Web_persist.get_election_metadata uuid in
682
          if metadata.e_owner = Some u then (
683
            let title = election.e_params.e_name in
684 685 686 687
            let url = Eliom_uri.make_string_uri
                        ~absolute:true ~service:election_home
                        (uuid, ()) |> rewrite_prefix
            in
Stephane Glondu's avatar
Stephane Glondu committed
688
            let service = preapply election_admin uuid in
689 690
            match%lwt find_user_id uuid user with
            | Some id ->
691
               let langs = get_languages metadata.e_languages in
692
               let%lwt db = load_password_db uuid in
693
               let%lwt x = generate_password metadata langs title url id in
694
               let db = replace_password user x db in
695 696 697
               let%lwt () = dump_passwords uuid db in
               T.generic_page ~title:"Success" ~service
                 ("A new password has been mailed to " ^ id ^ ".") ()
Stephane Glondu's avatar
Stephane Glondu committed
698
               >>= Html.send
699 700 701 702
            | None ->
               T.generic_page ~title:"Error" ~service
                 (user ^ " is not a registered user for this election.") ()
               >>= Html.send
703 704
          ) else forbidden ()
        )
705 706
    )

707
let () =
Stephane Glondu's avatar
Stephane Glondu committed
708
  Html.register ~service:election_draft_questions
709
    (fun uuid () ->
710 711
      with_draft_election_ro uuid (fun se ->
          T.election_draft_questions uuid se ()
712
        )
713 714
    )

715
let () =
716
  Any.register ~service:election_draft_questions_post
717
    (fun uuid template ->
718
      with_draft_election uuid (fun se ->
719
          se.se_questions <- template_of_string template;
720
          redir_preapply election_draft uuid ()
721 722
        )
    )
723

724
let () =
Stephane Glondu's avatar
Stephane Glondu committed
725
  Html.register ~service:election_draft_voters
726
    (fun uuid () ->
727 728
      with_draft_election_ro uuid (fun se ->
          T.election_draft_voters uuid se !maxmailsatonce ()
729
        )
730 731 732
    )

(* see http://www.regular-expressions.info/email.html *)
733
let identity_rex = Pcre.regexp
734
  ~flags:[`CASELESS]
735
  "^[A-Z0-9._%+-]+@[A-Z0-9.-]+\\.[A-Z]{2,}(,[A-Z0-9._%+-]+)?$"
736

737
let is_identity x =
738 739 740
  match pcre_exec_opt ~rex:identity_rex x with
  | Some _ -> true
  | None -> false
741

742
let merge_voters a b f =
743 744 745 746 747 748 749
  let existing = List.fold_left (fun accu sv ->
    SSet.add sv.sv_id accu
  ) SSet.empty a in
  let _, res = List.fold_left (fun (existing, accu) sv_id ->
    if SSet.mem sv_id existing then
      (existing, accu)
    else
750
      (SSet.add sv_id existing, {sv_id; sv_password = f sv_id} :: accu)
751 752 753
  ) (existing, List.rev a) b in
  List.rev res

754
let () =
755
  Any.register ~service:election_draft_voters_add
756
    (fun uuid voters ->
757
      with_draft_election uuid (fun se ->
758 759 760 761 762
          if se.se_public_creds_received then
            forbidden ()
          else (
            let voters = Pcre.split voters in
            let () =
763 764 765 766
              match List.find_opt (fun x -> not (is_identity x)) voters with
              | Some bad ->
                 Printf.ksprintf failwith "%S is not a valid identity" bad
              | None -> ()
767 768
            in
            se.se_voters <- merge_voters se.se_voters voters (fun _ -> None);
769
            redir_preapply election_draft_voters uuid ()
770 771 772
          )
        )
    )
773 774

let () =
775
  Any.register ~service:election_draft_voters_remove
776
    (fun uuid voter ->
777
      with_draft_election uuid (fun se ->
778 779 780 781
          if se.se_public_creds_received then
            forbidden ()
          else (
            se.se_voters <- List.filter (fun v -> v.sv_id <> voter) se.se_voters;
782
            redir_preapply election_draft_voters uuid ()
783 784 785
          )
        )
    )
786

787
let () =
788
  Any.register ~service:election_draft_voters_passwd
789
    (fun uuid voter ->
790
      with_draft_election uuid (fun se ->
791 792 793 794
          let voter = List.filter (fun v -> v.sv_id = voter) se.se_voters in
          handle_password se uuid ~force:true voter
        )
    )
795

796
let () =
797
  Any.register ~service:election_draft_trustee_add
798
    (fun uuid st_id ->
799
      with_draft_election uuid (fun se ->
800
          if is_email st_id then (
801
            let%lwt st_token = generate_token () in
802
            let trustee = {st_id; st_token; st_public_key = ""; st_private_key = None} in
803
            se.se_public_keys <- se.se_public_keys @ [trustee];
804
            redir_preapply election_draft_trustees uuid ()
805 806
          ) else (
            let msg = st_id ^ " is not a valid e-mail address!" in
807
            let service = preapply election_draft_trustees uuid in
Stephane Glondu's avatar
Stephane Glondu committed
808
            T.generic_page ~title:"Error" ~service msg () >>= Html.send
809 810
          )
        )
811 812
    )

813
let () =
814
  Any.register ~service:election_draft_trustee_add_server
815
    (fun uuid () ->
816
      with_draft_election uuid (fun se ->
817 818 819 820 821 822 823 824 825
          let st_id = "server" and st_token = "" in
          let module G = (val Group.of_string se.se_group) in
          let module K = Trustees.MakeSimple (G) (LwtRandom) in
          let%lwt private_key = K.generate () in
          let%lwt public_key = K.prove private_key in
          let st_public_key = string_of_trustee_public_key G.write public_key in
          let st_private_key = Some private_key in
          let trustee = {st_id; st_token; st_public_key; st_private_key} in
          se.se_public_keys <- se.se_public_keys @ [trustee];
826
          redir_preapply election_draft_trustees uuid ()
827 828 829
        )
    )

830
let () =
831
  Any.register ~service:election_draft_trustee_del
832
    (fun uuid index ->
833
      with_draft_election uuid (fun se ->
834
          let trustees =
835 836
            se.se_public_keys |>
              List.mapi (fun i x -> i, x) |>
837 838
              List.filter (fun (i, _) -> i <> index) |>
              List.map snd
839 840
          in
          se.se_public_keys <- trustees;
841
          redir_preapply election_draft_trustees uuid ()
842
        )
843 844
    )

845
let () =
Stephane Glondu's avatar
Stephane Glondu committed
846
  Html.register ~service:election_draft_credentials
847
    (fun (uuid, token) () ->
848 849 850
      match%lwt Web_persist.get_draft_election uuid with
      | None -> fail_http 404
      | Some se -> T.election_draft_credentials token uuid se ()
851
    )
852

853
let wrap_handler f =
854
  try%lwt f ()
855
  with
Stephane Glondu's avatar
Stephane Glondu committed
856
  | e -> T.generic_page ~title:"Error" (Printexc.to_string e) () >>= Html.send
857

858
let handle_credentials_post uuid token creds =
859 860 861
  match%lwt Web_persist.get_draft_election uuid with
  | None -> fail_http 404
  | Some se ->
862
  if se.se_public_creds <> token then forbidden () else
863
  if se.se_public_creds_received then forbidden () else
864
  let module G = (val Group.of_string se.se_group : GROUP) in
865
  let fname = !spool_dir / raw_string_of_uuid uuid / "public_creds.txt" in
866 867 868 869 870 871 872 873 874
  let%lwt () =
    Lwt_mutex.with_lock election_draft_mutex
      (fun () ->
        Lwt_io.with_file
          ~flags:(Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC]))
          ~perm:0o600 ~mode:Lwt_io.Output fname
          (fun oc -> Lwt_io.write_chars oc creds)
      )
  in
875
  let%lwt () =
876
    let i = ref 1 in
877 878 879 880 881 882 883 884 885 886 887 888 889
    match%lwt read_file fname with
    | Some xs ->
       return (
           List.iter (fun x ->
               try
                 let x = G.of_string x in
                 if not (G.check x) then raise Exit;
                 incr i
               with _ ->
                 Printf.ksprintf failwith "invalid credential at line %d" !i
             ) xs
         )
    | None -> return_unit
890
  in
891
  let () = se.se_metadata <- {se.se_metadata with e_cred_authority = None} in
892
  let () = se.se_public_creds_received <- true in
893
  let%lwt () = Web_persist.set_draft_election uuid se in
894
  T.generic_page ~title:"Success"
Stephane Glondu's avatar
Stephane Glondu committed
895
    "Credentials have been received and checked!" () >>= Html.send
896 897

let () =
898
  Any.register ~service:election_draft_credentials_post
899
    (fun (uuid, token) creds ->
900
     let s = Lwt_stream.of_string creds in
901
     wrap_handler (fun () -> handle_credentials_post uuid token s))
902

903
let () =
904
  Any.register ~service:election_draft_credentials_post_file
905
    (fun (uuid, token) creds ->
906
     let s = Lwt_io.chars_of_file creds.Ocsigen_extensions.tmp_filename in
907
     wrap_handler (fun () -> handle_credentials_post uuid token s))
908

909
module CG = Credential.MakeGenerate (LwtRandom)
910 911

let () =
912
  Any.register ~service:election_draft_credentials_server
913
    (fun uuid () ->
914
      with_draft_election uuid (fun se ->
915 916 917 918 919
          let nvoters = List.length se.se_voters in
          if nvoters > !maxmailsatonce then
            Lwt.fail (Failure (Printf.sprintf "Cannot send credentials, there are too many voters (max is %d)" !maxmailsatonce))
          else if nvoters = 0 then
            Lwt.fail (Failure "No voters")
920 921
          else if se.se_questions.t_name = default_name then
            Lwt.fail (Failure "The election name has not been edited!")
922 923 924 925 926 927 928 929 930 931 932 933 934 935 936
          else if se.se_public_creds_received then
            forbidden ()
          else (
            let () = se.se_metadata <- {se.se_metadata with
                                         e_cred_authority = Some "server"
                                       } in
            let title = se.se_questions.t_name in
            let url = Eliom_uri.make_string_uri
                        ~absolute:true ~service:election_home
                        (uuid, ()) |> rewrite_prefix
            in
            let module G = (val Group.of_string se.se_group : GROUP) in
            let module CD = Credential.MakeDerive (G) in
            let%lwt creds =
              Lwt_list.fold_left_s (fun accu v ->
937
                  let email, _ = split_identity v.sv_id in
938 939 940 941 942
                  let cas =
                    match se.se_metadata.e_auth_config with
                    | Some [{auth_system = "cas"; _}] -> true
                    | _ -> false
                  in
943 944 945 946 947 948 949 950 951
                  let%lwt cred = CG.generate () in
                  let pub_cred =
                    let x = CD.derive uuid cred in
                    let y = G.(g **~ x) in
                    G.to_string y
                  in
                  let langs = get_languages se.se_metadata.e_languages in
                  let bodies = List.map (fun lang ->
                                   let module L = (val Web_i18n.get_lang lang) in
952
                                   let intro = if cas then L.mail_credential_cas else L.mail_credential_password in
953
                                   let contact = T.contact_footer se.se_metadata L.please_contact in
954
                                   Printf.sprintf L.mail_credential title intro cred url contact
955 956 957 958 959 960 961 962 963
                                 ) langs in
                  let body = PString.concat "\n\n----------\n\n" bodies in
                  let body = body ^ "\n\n-- \nBelenios" in
                  let subject =
                    let lang = List.hd langs in
                    let module L = (val Web_i18n.get_lang lang) in
                    Printf.sprintf L.mail_credential_subject title
                  in
                  let%lwt () = send_email email subject body in
964 965
                  return @@ SSet.add pub_cred accu
                ) SSet.empty se.se_voters
966
            in
967
            let creds = SSet.elements creds in
968
            let fname = !spool_dir / raw_string_of_uuid uuid / "public_creds.txt" in
969 970 971 972 973 974 975 976
            let%lwt () =
              Lwt_io.with_file
                ~flags:(Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC]))
                ~perm:0o600 ~mode:Lwt_io.Output fname
                (fun oc ->
                  Lwt_list.iter_s (Lwt_io.write_line oc) creds)
            in
            se.se_public_creds_received <- true;
977
            let service = preapply election_draft uuid in
978
            T.generic_page ~title:"Success" ~service
Stephane Glondu's avatar
Stephane Glondu committed
979
              "Credentials have been generated and mailed!" () >>= Html.send
980 981 982
          )
        )
    )
983

984
let () =
Stephane Glondu's avatar
Stephane Glondu committed
985
  Html.register ~service:election_draft_trustee
986
    (fun (uuid, token) () ->
987 988 989
      match%lwt Web_persist.get_draft_election uuid with
      | None -> fail_http 404
      | Some se -> T.election_draft_trustee token uuid se ()
990 991 992
    )

let () =
993
  Any.register ~service:election_draft_trustee_post
994 995
    (fun (uuid, token) public_key ->
     if token = "" then forbidden () else
996 997
     wrap_handler
       (fun () ->
998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016
         let%lwt () =
           Lwt_mutex.with_lock election_draft_mutex
             (fun () ->
               match%lwt Web_persist.get_draft_election uuid with
               | None -> fail_http 404
               | Some se ->
                  let t = List.find (fun x -> token = x.st_token) se.se_public_keys in
                  let module G = (val Group.of_string se.se_group : GROUP) in
                  let pk = trustee_public_key_of_string G.read public_key in
                  let module KG = Trustees.MakeSimple (G) (LwtRandom) in
                  if not (KG.check pk) then failwith "invalid public key";
                  (* we keep pk as a string because of G.t *)
                  t.st_public_key <- public_key;
                  Web_persist.set_draft_election uuid se
             )
         in
         T.generic_page ~title:"Success"
           "Your key has been received and checked!"
           () >>= Html.send
1017 1018 1019
       )
    )

1020
let () =
1021
  Any.register ~service:election_draft_confirm
1022
    (fun uuid () ->
1023
      with_draft_election_ro uuid (fun se ->
Stephane Glondu's avatar
Stephane Glondu committed
1024
          T.election_draft_confirm uuid se () >>= Html.send
1025 1026
        )
    )
1027

1028
let () =
1029
  Any.register ~service:election_draft_create
1030
    (fun uuid () ->
1031
      with_draft_election ~save:false uuid (fun se ->
1032
          try%lwt
1033
            let%lwt () = validate_election uuid se in
Stephane Glondu's avatar
Stephane Glondu committed
1034
            redir_preapply election_admin uuid ()
1035
          with e ->
Stephane Glondu's avatar
Stephane Glondu committed
1036
            T.new_election_failure (`Exception e) () >>= Html.send
1037
        )
1038
    )
1039

1040
let destroy_election uuid =
1041
  rmdir (!spool_dir / raw_string_of_uuid uuid)
1042

1043
let () =
1044
  Any.register ~service:election_draft_destroy
1045
    (fun uuid () ->
1046
      with_draft_election ~save:false uuid (fun _ ->
1047 1048
          let%lwt () = destroy_election uuid in
          Redirection.send (Redirection admin)
1049 1050 1051
        )
    )

1052
let () =
Stephane Glondu's avatar
Stephane Glondu committed
1053
  Html.register ~service:election_draft_import
1054
    (fun uuid () ->
1055
      with_draft_election_ro uuid (fun se ->
1056 1057
          let%lwt _, a, b, c = get_elections_by_owner_sorted se.se_owner in
          T.election_draft_import uuid se (a, b, c) ()
1058 1059
        )
    )
1060 1061

let () =
1062
  Any.register ~service:election_draft_import_post
1063
    (fun uuid from ->
Stephane Glondu's avatar
Stephane Glondu committed
1064
      let from = uuid_of_raw_string from in
1065
      with_draft_election uuid (fun se ->
1066
          let from_s = raw_string_of_uuid from in
1067 1068
          let%lwt voters = Web_persist.get_voters from in
          let%lwt passwords = Web_persist.get_passwords from in
1069 1070 1071 1072 1073
          let get_password =
            match passwords with
            | None -> fun _ -> None
            | Some p -> fun sv_id ->
                        let _, login = split_identity sv_id in
1074
                        SMap.find_opt login p
1075 1076 1077 1078 1079 1080 1081
          in
          match voters with
          | Some voters ->
             if se.se_public_creds_received then
               forbidden ()
             else (
               se.se_voters <- merge_voters se.se_voters voters get_password;
1082
               redir_preapply election_draft_voters uuid ()
1083 1084 1085
             )
          | None ->
             T.generic_page ~title:"Error"
1086
               ~service:(preapply election_draft_voters uuid)
1087 1088 1089
               (Printf.sprintf
                  "Could not retrieve voter list from election %s"
                  from_s)
Stephane Glondu's avatar
Stephane Glondu committed
1090
               () >>= Html.send
1091 1092
        )
    )
1093

1094
let () =
Stephane Glondu's avatar
Stephane Glondu committed
1095
  Html.register ~service:election_draft_import_trustees
1096
    (fun uuid () ->
1097
      with_draft_election_ro uuid (fun se ->
1098 1099
          let%lwt _, a, b, c = get_elections_by_owner_sorted se.se_owner in
          T.election_draft_import_trustees uuid se (a, b, c) ()
1100 1101
        )
    )
1102 1103 1104 1105

exception TrusteeImportError of string

let () =
1106
  Any.register ~service:election_draft_import_trustees_post
1107
    (fun uuid from ->
Stephane Glondu's avatar
Stephane Glondu committed
1108
      let from = uuid_of_raw_string from in
1109
      with_draft_election uuid (fun se ->
1110 1111 1112
          let%lwt metadata = Web_persist.get_election_metadata from in
          let%lwt threshold = Web_persist.get_threshold from in
          let%lwt public_keys = Web_persist.get_public_keys from in