web_site.ml

(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
(*  Copyright © 2012-2018 Inria                                           *)
(*                                                                        *)
(*  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/>.                                       *)
(**************************************************************************)

open Lwt
open Platform
open Serializable_builtin_t
open Serializable_j
open Signatures
open Common
open Web_serializable_builtin_t
open Web_serializable_j
open Web_common
open Web_services

let source_file = ref "belenios.tar.gz"
let maxmailsatonce = ref 1000
let uuid_length = ref None
let default_group = ref ""

let ( / ) = Filename.concat

module PString = String

open Eliom_service
open Eliom_registration

(* Table with draft elections. *)
let election_stable = Ocsipersist.open_table "site_setup"

(* Table with tokens given to trustees (in threshold mode) to decrypt *)
let election_tokens_decrypt = Ocsipersist.open_table "site_tokens_decrypt"

module T = Web_templates

let raw_find_election uuid =
  let%lwt raw_election = Web_persist.get_raw_election uuid in
  match raw_election with
  | Some raw_election ->
     return (Election.of_string raw_election)
  | _ -> Lwt.fail Not_found

module WCacheTypes = struct
  type key = uuid
  type value = Yojson.Safe.json election
end

module WCache = Ocsigen_cache.Make (WCacheTypes)

let find_election =
  let cache = new WCache.cache raw_find_election ~timer:3600. 100 in
  fun x -> cache#find x

let get_draft_election uuid =
  let%lwt se = Ocsipersist.find election_stable (raw_string_of_uuid uuid) in
  return (draft_election_of_string se)

let set_draft_election uuid se =
  Ocsipersist.add election_stable (raw_string_of_uuid uuid) (string_of_draft_election se)

let dump_passwords uuid db =
  List.map (fun line -> PString.concat "," line) db |>
    write_file ~uuid "passwords.csv"

let validate_election uuid se =
  let uuid_s = raw_string_of_uuid uuid in
  (* 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
  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)
         | _ :: _ ->
            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
            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),
                private_key)
       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)
  in
  (* election parameters *)
  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
  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 ->
            Lwt_io.write oc (what v) >>
              Lwt_io.write oc "\n") xs)
  in
  Lwt_unix.mkdir dir 0o700 >>
  (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]
  ) >>
  create_file "voters.txt" (fun x -> x.sv_id) se.se_voters >>
  create_file "metadata.json" string_of_metadata [metadata] >>
  create_file "election.json" (fun x -> x) [raw_election] >>
  (* construct Web_election instance *)
  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
  (* inject credentials *)
  let%lwt () =
    let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in
    match%lwt read_file fname with
    | Some xs ->
       Lwt_list.iter_s B.inject_cred xs
       >> B.update_files ()
       >> Lwt_unix.unlink fname
    | None -> return_unit
  in
  (* create file with private keys, if any *)
  let%lwt () =
    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
  in
  (* clean up draft database *)
  Ocsipersist.remove election_stable uuid_s >>
  (* write passwords *)
  (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) >>
  (* finish *)
  Web_persist.set_election_state uuid `Open >>
  Web_persist.set_election_date `Validation uuid (now ())

let cleanup_table ?uuid_s table =
  let table = Ocsipersist.open_table table in
  match uuid_s with
  | None ->
     let%lwt indexes = Ocsipersist.fold_step (fun k _ accu ->
       return (k :: accu)) table []
     in
     Lwt_list.iter_s (Ocsipersist.remove table) indexes
  | Some u -> Ocsipersist.remove table u

let cleanup_file f =
  try%lwt Lwt_unix.unlink f
  with _ -> return_unit

let delete_sensitive_data uuid =
  let uuid_s = raw_string_of_uuid uuid in
  let uuid_u = underscorize uuid in
  let%lwt () = cleanup_table ~uuid_s "election_states" in
  let%lwt () = cleanup_table ~uuid_s "site_tokens_decrypt" in
  let%lwt () = cleanup_table ~uuid_s "election_pds" in
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "extended_records.jsons") in
  let%lwt () = cleanup_table ("creds_" ^ uuid_u) in
  let%lwt () = rmdir (!spool_dir / uuid_s / "ballots") in
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "private_key.json") in
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "private_keys.jsons") in
  return_unit

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

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 ->
       let%lwt date = Web_persist.get_election_date `Validation uuid in
       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
          | None -> return default_validation_date
  in
  let de_authentication_method = match metadata.e_auth_config with
    | Some [{auth_system = "cas"; auth_config; _}] ->
       let server = List.assoc "server" auth_config in
       `CAS server
    | 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";
      "archive.zip";
    ]
  in
  let%lwt () = Lwt_list.iter_p (fun x ->
                   cleanup_file (!spool_dir / uuid_s / x)
                 ) files_to_delete
  in
  return_unit

let () = Any.register ~service:home
  (fun () () ->
    Eliom_reference.unset Web_state.cont >>
    Redirection.send admin
  )

let get_validated_elections_by_owner u =
  let%lwt elections, tallied, archived =
    Web_persist.get_elections_by_owner u >>=
    Lwt_list.fold_left_s (fun accu uuid ->
        let%lwt w = find_election uuid in
        let%lwt state = Web_persist.get_election_state uuid in
        let%lwt date = Web_persist.get_election_date `Validation uuid in
        let date = match date with
          | None -> default_validation_date
          | Some x -> x
        in
        let elections, tallied, archived = accu in
        match state with
        | `Tallied _ -> return (elections, (date, w) :: tallied, archived)
        | `Archived -> return (elections, tallied, (date, w) :: archived)
        | _ -> return ((date, w) :: elections, tallied, archived)
    ) ([], [], [])
  in
  let sort l =
    List.sort (fun (x, _) (y, _) -> datetime_compare x y) l |>
    List.map (fun (_, x) -> x)
  in
  return (sort elections, sort tallied, sort archived)

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

let () =
  Redirection.register ~service:admin_gdpr_accept
    (fun () () ->
      Eliom_reference.set Web_state.show_cookie_disclaimer false >>
      return admin
    )

let () = Html5.register ~service:admin
  (fun () () ->
    let%lwt gdpr = Eliom_reference.get Web_state.show_cookie_disclaimer in
    if gdpr then T.admin_gdpr () else
    let cont () = Redirection.send admin in
    Eliom_reference.set Web_state.cont [cont] >>
    let%lwt site_user = Web_state.get_site_user () in
    let%lwt elections =
      match site_user with
      | None -> return None
      | Some u ->
         let%lwt elections, tallied, archived = get_validated_elections_by_owner u in
         let%lwt draft_elections =
           Ocsipersist.fold_step (fun k v accu ->
             let v = draft_election_of_string v in
             if v.se_owner = u then
               return ((uuid_of_raw_string k, v.se_questions.t_name) :: accu)
             else return accu
           ) election_stable []
         in
         return @@ Some (elections, tallied, archived, draft_elections)
    in
    T.admin ~elections ()
  )

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

let generate_uuid =
  let gen = Uuidm.v4_gen (Random.State.make_self_init ()) in
  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 ()

let redir_preapply s u () = Redirection.send (preapply s u)

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
  let%lwt uuid = generate_uuid () in
  let%lwt token = generate_token () in
  let se_metadata = {
    e_owner = Some owner;
    e_auth_config;
    e_cred_authority;
    e_trustees = None;
    e_languages = Some ["en"; "fr"];
    e_contact = None;
    e_server_is_trustee = None;
  } in
  let se_questions = {
    t_description = default_description;
    t_name = default_name;
    t_questions = default_questions;
  } in
  let se = {
    se_owner = owner;
    se_group = !default_group;
    se_voters = [];
    se_questions;
    se_public_keys = [];
    se_metadata;
    se_public_creds = token;
    se_public_creds_received = false;
    se_threshold = None;
    se_threshold_trustees = None;
    se_threshold_parameters = None;
    se_threshold_error = None;
    se_creation_date = Some (now ());
  } in
  let%lwt () = set_draft_election uuid se in
  redir_preapply election_draft uuid ()

let () = Html5.register ~service:election_draft_pre
  (fun () () -> T.election_draft_pre ())

let () = Any.register ~service:election_draft_new
  (fun () (credmgmt, (auth, cas_server)) ->
    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
      )
  )

let with_draft_election_ro uuid f =
  with_site_user (fun u ->
      let%lwt se = get_draft_election uuid in
      if se.se_owner = u then
        f se
      else forbidden ()
    )

let () =
  Html5.register ~service:election_draft
    (fun uuid () ->
      with_draft_election_ro uuid (fun se ->
          T.election_draft uuid se ()
        )
    )

let () =
  Any.register ~service:election_draft_trustees
    (fun uuid () ->
      with_draft_election_ro uuid (fun se ->
          match se.se_threshold_trustees with
          | None -> T.election_draft_trustees uuid se () >>= Html5.send
          | Some _ -> redir_preapply election_draft_threshold_trustees uuid ()
        )
    )

let () =
  Html5.register ~service:election_draft_threshold_trustees
    (fun uuid () ->
      with_draft_election_ro uuid (fun se ->
          T.election_draft_threshold_trustees uuid se ()
        )
    )

let () =
  Html5.register ~service:election_draft_credential_authority
    (fun uuid () ->
      with_draft_election_ro uuid (fun se ->
          T.election_draft_credential_authority uuid se ()
        )
    )

let election_draft_mutex = Lwt_mutex.create ()

let with_draft_election ?(save = true) uuid f =
  with_site_user (fun u ->
      Lwt_mutex.with_lock election_draft_mutex (fun () ->
          let%lwt se = get_draft_election uuid in
          if se.se_owner = u then (
            try%lwt
              let%lwt r = f se in
              let%lwt () = if save then set_draft_election uuid se else return_unit in
              return r
            with e ->
              let service = preapply election_draft uuid in
              T.generic_page ~title:"Error" ~service (Printexc.to_string e) () >>= Html5.send
          ) else forbidden ()
        )
    )

let () =
  Any.register ~service:election_draft_languages
    (fun uuid languages ->
      with_draft_election uuid (fun se ->
          let langs = languages_of_string languages in
          match langs with
          | [] ->
             let service = preapply election_draft uuid in
             T.generic_page ~title:"Error" ~service
               "You must select at least one language!" () >>= Html5.send
          | _ :: _ ->
             let unavailable =
               List.filter (fun x ->
                   not (List.mem x available_languages)
                 ) langs
             in
             match unavailable with
             | [] ->
                se.se_metadata <- {
                   se.se_metadata with
                   e_languages = Some langs
                 };
                redir_preapply election_draft uuid ()
             | l :: _ ->
                let service = preapply election_draft uuid in
                T.generic_page ~title:"Error" ~service
                  ("No such language: " ^ l) () >>= Html5.send
        )
    )

let () =
  Any.register ~service:election_draft_contact
    (fun uuid contact ->
      with_draft_election uuid (fun se ->
          let contact =
            if contact = "" || contact = default_contact then
              None
            else Some contact
          in
          se.se_metadata <- {
              se.se_metadata with
              e_contact = contact
            };
          redir_preapply election_draft uuid ()
        )
    )

let () =
  Any.register ~service:election_draft_description
    (fun uuid (name, description) ->
      with_draft_election uuid (fun se ->
          se.se_questions <- {se.se_questions with
                               t_name = name;
                               t_description = description;
                             };
          redir_preapply election_draft uuid ()
        )
    )

let generate_password metadata langs title url id =
  let email, login = split_identity id in
  let%lwt salt = generate_token () in
  let%lwt password = generate_token () in
  let hashed = sha256_hex (salt ^ password) in
  let bodies = List.map (fun lang ->
    let module L = (val Web_i18n.get_lang lang) in
    let contact = T.contact_footer metadata L.please_contact in
    Printf.sprintf L.mail_password title login password url contact
  ) 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_password_subject title
  in
  send_email email subject body >>
  return (salt, hashed)

let handle_password se uuid ~force voters =
  if List.length voters > !maxmailsatonce then
    Lwt.fail (Failure (Printf.sprintf "Cannot send passwords, there are too many voters (max is %d)" !maxmailsatonce))
  else
  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 langs = get_languages se.se_metadata.e_languages in
  let%lwt () =
    Lwt_list.iter_s (fun id ->
        match id.sv_password with
        | Some _ when not force -> return_unit
        | None | Some _ ->
           let%lwt x = generate_password se.se_metadata langs title url id.sv_id in
           return (id.sv_password <- Some x)
      ) voters
  in
  let service = preapply election_draft uuid in
  T.generic_page ~title:"Success" ~service
    "Passwords have been generated and mailed!" () >>= Html5.send

let () =
  Any.register ~service:election_draft_auth_genpwd
    (fun uuid () ->
      with_draft_election uuid (fun se ->
          handle_password se uuid ~force:false se.se_voters
        )
    )

let () =
  Any.register ~service:election_regenpwd
    (fun (uuid, ()) () ->
      T.regenpwd uuid () >>= Html5.send)

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
    | [] -> Lwt.fail Not_found
    | id :: xs ->
       let _, login = split_identity id in
       if login = user then return id else loop xs
  in loop db

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)

let () =
  Any.register ~service:election_regenpwd_post
    (fun (uuid, ()) user ->
      with_site_user (fun u ->
          let%lwt election = find_election uuid in
          let%lwt metadata = Web_persist.get_election_metadata uuid in
          if metadata.e_owner = Some u then (
            let title = election.e_params.e_name in
            let url = Eliom_uri.make_string_uri
                        ~absolute:true ~service:election_home
                        (uuid, ()) |> rewrite_prefix
            in
            let service = preapply election_admin (uuid, ()) in
            (try%lwt
               let%lwt id = find_user_id uuid user in
               let langs = get_languages metadata.e_languages in
               let%lwt db = load_password_db uuid in
               let%lwt x = generate_password metadata langs title url id in
               let db = replace_password user x db in
               dump_passwords uuid db >>
                 T.generic_page ~title:"Success" ~service
                   ("A new password has been mailed to " ^ id ^ ".") ()
               >>= Html5.send
              with Not_found ->
                T.generic_page ~title:"Error" ~service
                  (user ^ " is not a registered user for this election.") ()
                >>= Html5.send
            )
          ) else forbidden ()
        )
    )

let () =
  Html5.register ~service:election_draft_questions
    (fun uuid () ->
      with_draft_election_ro uuid (fun se ->
          T.election_draft_questions uuid se ()
        )
    )

let () =
  Any.register ~service:election_draft_questions_post
    (fun uuid template ->
      with_draft_election uuid (fun se ->
          se.se_questions <- template_of_string template;
          redir_preapply election_draft uuid ()
        )
    )

let () =
  Html5.register ~service:election_draft_voters
    (fun uuid () ->
      with_draft_election_ro uuid (fun se ->
          T.election_draft_voters uuid se !maxmailsatonce ()
        )
    )

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

let is_identity x =
  try ignore (Pcre.pcre_exec ~rex:identity_rex x); true
  with Not_found -> false

let merge_voters a b f =
  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
      (SSet.add sv_id existing, {sv_id; sv_password = f sv_id} :: accu)
  ) (existing, List.rev a) b in
  List.rev res

let () =
  Any.register ~service:election_draft_voters_add
    (fun uuid voters ->
      with_draft_election uuid (fun se ->
          if se.se_public_creds_received then
            forbidden ()
          else (
            let voters = Pcre.split voters in
            let () =
              try
                let bad = List.find (fun x -> not (is_identity x)) voters in
                Printf.ksprintf failwith "%S is not a valid identity" bad
              with Not_found -> ()
            in
            se.se_voters <- merge_voters se.se_voters voters (fun _ -> None);
            redir_preapply election_draft_voters uuid ()
          )
        )
    )

let () =
  Any.register ~service:election_draft_voters_remove
    (fun uuid voter ->
      with_draft_election uuid (fun se ->
          if se.se_public_creds_received then
            forbidden ()
          else (
            se.se_voters <- List.filter (fun v -> v.sv_id <> voter) se.se_voters;
            redir_preapply election_draft_voters uuid ()
          )
        )
    )

let () =
  Any.register ~service:election_draft_voters_passwd
    (fun uuid voter ->
      with_draft_election uuid (fun se ->
          let voter = List.filter (fun v -> v.sv_id = voter) se.se_voters in
          handle_password se uuid ~force:true voter
        )
    )

let () =
  Any.register ~service:election_draft_trustee_add
    (fun uuid st_id ->
      with_draft_election uuid (fun se ->
          if is_email st_id then (
            let%lwt st_token = generate_token () in
            let trustee = {st_id; st_token; st_public_key = ""; st_private_key = None} in
            se.se_public_keys <- se.se_public_keys @ [trustee];
            redir_preapply election_draft_trustees uuid ()
          ) else (
            let msg = st_id ^ " is not a valid e-mail address!" in
            let service = preapply election_draft_trustees uuid in
            T.generic_page ~title:"Error" ~service msg () >>= Html5.send
          )
        )
    )

let () =
  Any.register ~service:election_draft_trustee_add_server
    (fun uuid () ->
      with_draft_election uuid (fun se ->
          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];
          redir_preapply election_draft_trustees uuid ()
        )
    )

let () =
  Any.register ~service:election_draft_trustee_del
    (fun uuid index ->