web_site.ml 63.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-2016 Inria                                           *)
Stephane Glondu's avatar
Stephane Glondu committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

22
open Lwt
23
open Platform
24
open Serializable_j
25
open Signatures
26
open Common
27
open Web_serializable_builtin_t
Stephane Glondu's avatar
Stephane Glondu committed
28
open Web_serializable_j
29
open Web_common
30
open Web_services
Stephane Glondu's avatar
Stephane Glondu committed
31

32
let source_file = ref "belenios.tar.gz"
33
let maxmailsatonce = ref 1000
Stephane Glondu's avatar
Stephane Glondu committed
34

35 36
let ( / ) = Filename.concat

Stephane Glondu's avatar
Stephane Glondu committed
37
module PString = String
Stephane Glondu's avatar
Stephane Glondu committed
38

Stephane Glondu's avatar
Stephane Glondu committed
39 40 41 42 43 44 45 46 47
open Eliom_service
open Eliom_registration

(* Table with elections in setup mode. *)
let election_stable = Ocsipersist.open_table "site_setup"

(* Table with tokens given to trustees. *)
let election_pktokens = Ocsipersist.open_table "site_pktokens"

48 49 50
(* Table with tokens given to trustees (in threshold mode). *)
let election_tpktokens = Ocsipersist.open_table "site_tpktokens"

Stephane Glondu's avatar
Stephane Glondu committed
51 52 53 54 55
(* Table with tokens given to credential authorities. *)
let election_credtokens = Ocsipersist.open_table "site_credtokens"

module T = Web_templates

Stephane Glondu's avatar
Stephane Glondu committed
56
let raw_find_election uuid =
57
  let%lwt raw_election = Web_persist.get_raw_election uuid in
58 59 60 61
  match raw_election with
  | Some raw_election ->
     return (Group.election_params_of_string raw_election)
  | _ -> Lwt.fail Not_found
Stephane Glondu's avatar
Stephane Glondu committed
62

Stephane Glondu's avatar
Stephane Glondu committed
63 64
module WCacheTypes = struct
  type key = string
65
  type value = (module ELECTION_DATA)
Stephane Glondu's avatar
Stephane Glondu committed
66 67 68 69 70 71 72 73
end

module WCache = Ocsigen_cache.Make (WCacheTypes)

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

74
let get_setup_election uuid_s =
75
  let%lwt se = Ocsipersist.find election_stable uuid_s in
76
  return (setup_election_of_string se)
77 78

let set_setup_election uuid_s se =
79
  Ocsipersist.add election_stable uuid_s (string_of_setup_election se)
80

Stephane Glondu's avatar
Stephane Glondu committed
81
let dump_passwords dir table =
Stephane Glondu's avatar
Stephane Glondu committed
82 83 84 85 86 87
  Lwt_io.(with_file Output (dir / "passwords.csv") (fun oc ->
    Ocsipersist.iter_step (fun voter (salt, hashed) ->
      write_line oc (voter ^ "," ^ salt ^ "," ^ hashed)
    ) table
  ))

88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
let finalize_election uuid se =
  let uuid_s = Uuidm.to_string 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
110
  let module KG = Trustees.MakeSimple (G) (LwtRandom) in
111
  let%lwt trustees, public_keys, private_key =
112 113
    match se.se_public_keys with
    | [] ->
Stephane Glondu's avatar
Stephane Glondu committed
114 115
       let%lwt private_key = KG.generate () in
       let%lwt public_key = KG.prove private_key in
116
       return (None, [public_key], Some private_key)
117
    | _ :: _ ->
118 119 120
       return (
         Some (List.map (fun {st_id; _} -> st_id) se.se_public_keys),
         (List.map
121 122 123
            (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
124 125
            ) se.se_public_keys),
         None)
126 127 128
  in
  let y = KG.combine (Array.of_list public_keys) in
  (* election parameters *)
129
  let metadata = { se.se_metadata with e_trustees = trustees } in
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
  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 >>
  create_file "public_keys.jsons" (string_of_trustee_public_key G.write) public_keys >>
  create_file "voters.txt" (fun x -> x.sv_id) se.se_voters >>
154
  create_file "metadata.json" string_of_metadata [metadata] >>
155 156
  create_file "election.json" (fun x -> x) [raw_election] >>
  (* construct Web_election instance *)
157
  let election = Group.election_params_of_string raw_election in
158 159
  let module W = Web_election.Make ((val election)) (LwtRandom) in
  (* set up authentication *)
160
  let%lwt () =
161
    match metadata.e_auth_config with
162 163 164 165 166 167 168 169 170 171
    | None -> return ()
    | Some xs ->
       let auth_config =
         List.map (fun {auth_system; auth_instance; auth_config} ->
           auth_instance, (auth_system, List.map snd auth_config)
         ) xs
       in
       Web_persist.set_auth_config uuid_s auth_config
  in
  (* inject credentials *)
172
  let%lwt () =
173 174 175 176 177 178 179
    let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in
    Lwt_io.lines_of_file fname |>
    Lwt_stream.iter_s W.B.inject_cred >>
    W.B.update_files () >>
    Lwt_unix.unlink fname
  in
  (* create file with private key, if any *)
180
  let%lwt () =
181 182 183 184 185 186 187
    match private_key with
    | None -> return_unit
    | Some x -> create_file "private_key.json" string_of_number [x]
  in
  (* clean up setup database *)
  Ocsipersist.remove election_credtokens se.se_public_creds >>
  Lwt_list.iter_s
188 189
    (fun {st_token; _} ->
      Ocsipersist.remove election_pktokens st_token)
190 191 192
    se.se_public_keys >>
  Ocsipersist.remove election_stable uuid_s >>
  (* inject passwords *)
193
  (match metadata.e_auth_config with
194 195 196 197 198 199 200 201 202 203
  | Some [{auth_system = "password"; _}] ->
     let table = "password_" ^ underscorize uuid_s in
     let table = Ocsipersist.open_table table in
     Lwt_list.iter_s
       (fun v ->
         let _, login = split_identity v.sv_id in
         match v.sv_password with
         | Some x -> Ocsipersist.add table login x
         | None -> return_unit
       ) se.se_voters >>
204
       dump_passwords (!spool_dir / uuid_s) table
205 206
  | _ -> return_unit) >>
  (* finish *)
Stephane Glondu's avatar
Stephane Glondu committed
207
  Web_persist.set_election_state uuid_s `Open >>
208
  Web_persist.set_election_date uuid_s (now ())
Stephane Glondu's avatar
Stephane Glondu committed
209

Stephane Glondu's avatar
Stephane Glondu committed
210 211 212 213
let cleanup_table ?uuid_s table =
  let table = Ocsipersist.open_table table in
  match uuid_s with
  | None ->
214
     let%lwt indexes = Ocsipersist.fold_step (fun k _ accu ->
Stephane Glondu's avatar
Stephane Glondu committed
215 216 217 218 219 220
       return (k :: accu)) table []
     in
     Lwt_list.iter_s (Ocsipersist.remove table) indexes
  | Some u -> Ocsipersist.remove table u

let cleanup_file f =
221
  try%lwt Lwt_unix.unlink f
Stephane Glondu's avatar
Stephane Glondu committed
222 223 224 225
  with _ -> return_unit

let archive_election uuid_s =
  let uuid_u = underscorize uuid_s in
226 227 228 229 230 231 232 233
  let%lwt () = cleanup_table ~uuid_s "election_states" in
  let%lwt () = cleanup_table ~uuid_s "election_pds" in
  let%lwt () = cleanup_table ~uuid_s "auth_configs" in
  let%lwt () = cleanup_table ("password_" ^ uuid_u) in
  let%lwt () = cleanup_table ("records_" ^ uuid_u) in
  let%lwt () = cleanup_table ("creds_" ^ uuid_u) in
  let%lwt () = cleanup_table ("ballots_" ^ uuid_u) in
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "private_key.json") in
Stephane Glondu's avatar
Stephane Glondu committed
234 235
  return_unit

Stephane Glondu's avatar
Stephane Glondu committed
236 237
let () = Any.register ~service:home
  (fun () () ->
238
    Eliom_reference.unset Web_state.cont >>
239
    Redirection.send admin
Stephane Glondu's avatar
Stephane Glondu committed
240 241
  )

242
let get_finalized_elections_by_owner u =
243
  let%lwt elections, tallied, archived =
244 245
    Web_persist.get_elections_by_owner u >>=
    Lwt_list.fold_left_s (fun accu uuid_s ->
246 247 248
        let%lwt w = find_election uuid_s in
        let%lwt state = Web_persist.get_election_state uuid_s in
        let%lwt date = Web_persist.get_election_date uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
249
        let elections, tallied, archived = accu in
250
        match state with
Stephane Glondu's avatar
Stephane Glondu committed
251 252 253 254
        | `Tallied _ -> return (elections, (date, w) :: tallied, archived)
        | `Archived -> return (elections, tallied, (date, w) :: archived)
        | _ -> return ((date, w) :: elections, tallied, archived)
    ) ([], [], [])
255 256 257 258 259
  in
  let sort l =
    List.sort (fun (x, _) (y, _) -> datetime_compare x y) l |>
    List.map (fun (_, x) -> x)
  in
Stephane Glondu's avatar
Stephane Glondu committed
260
  return (sort elections, sort tallied, sort archived)
261

Stephane Glondu's avatar
Stephane Glondu committed
262 263
let () = Html5.register ~service:admin
  (fun () () ->
Stephane Glondu's avatar
Stephane Glondu committed
264
    let cont () = Redirection.send admin in
265
    Eliom_reference.set Web_state.cont [cont] >>
266 267
    let%lwt site_user = Web_state.get_site_user () in
    let%lwt elections =
268
      match site_user with
269
      | None -> return None
Stephane Glondu's avatar
Stephane Glondu committed
270
      | Some u ->
271 272
         let%lwt elections, tallied, archived = get_finalized_elections_by_owner u in
         let%lwt setup_elections =
273
           Ocsipersist.fold_step (fun k v accu ->
274
             let v = setup_election_of_string v in
275
             if v.se_owner = u
276
             then return ((uuid_of_string k, v.se_questions.t_name) :: accu)
277 278
             else return accu
           ) election_stable []
279
         in
Stephane Glondu's avatar
Stephane Glondu committed
280
         return @@ Some (elections, tallied, archived, setup_elections)
Stephane Glondu's avatar
Stephane Glondu committed
281
    in
282
    T.admin ~elections ()
Stephane Glondu's avatar
Stephane Glondu committed
283 284 285 286 287 288 289 290 291
  )

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

let generate_uuid = Uuidm.v4_gen (Random.State.make_self_init ())

Stephane Glondu's avatar
Stephane Glondu committed
292 293 294 295 296 297 298 299 300 301 302 303
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 uuid = generate_uuid () in
  let uuid_s = Uuidm.to_string uuid in
304
  let%lwt token = generate_token () in
Stephane Glondu's avatar
Stephane Glondu committed
305 306 307 308
  let se_metadata = {
    e_owner = Some owner;
    e_auth_config;
    e_cred_authority;
309
    e_trustees = None;
310
    e_languages = Some ["en"; "fr"];
Stephane Glondu's avatar
Stephane Glondu committed
311 312 313
  } in
  let question = {
    q_answers = [| "Answer 1"; "Answer 2"; "Blank" |];
314
    q_blank = None;
Stephane Glondu's avatar
Stephane Glondu committed
315 316 317 318 319 320 321 322 323 324 325
    q_min = 1;
    q_max = 1;
    q_question = "Question 1?";
  } in
  let se_questions = {
    t_description = "Description of the election.";
    t_name = "Name of the election";
    t_questions = [| question |];
  } in
  let se = {
    se_owner = owner;
326
    se_group = "{\"g\":\"2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627\",\"p\":\"20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719\",\"q\":\"78571733251071885079927659812671450121821421258408794611510081919805623223441\"}"; (* generated by fips.sage *)
Stephane Glondu's avatar
Stephane Glondu committed
327 328 329 330 331
    se_voters = [];
    se_questions;
    se_public_keys = [];
    se_metadata;
    se_public_creds = token;
332
    se_public_creds_received = false;
333 334 335 336
    se_threshold = None;
    se_threshold_trustees = None;
    se_threshold_parameters = None;
    se_threshold_error = None;
Stephane Glondu's avatar
Stephane Glondu committed
337
  } in
338 339
  let%lwt () = set_setup_election uuid_s se in
  let%lwt () = Ocsipersist.add election_credtokens token uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
340 341 342 343 344
  return (preapply election_setup uuid)

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

Stephane Glondu's avatar
Stephane Glondu committed
345
let () = Redirection.register ~service:election_setup_new
Stephane Glondu's avatar
Stephane Glondu committed
346
  (fun () (credmgmt, (auth, cas_server)) ->
347
   match%lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
348
   | Some u ->
349
      let%lwt credmgmt = match credmgmt with
Stephane Glondu's avatar
Stephane Glondu committed
350 351 352 353
        | Some "auto" -> return `Automatic
        | Some "manual" -> return `Manual
        | _ -> fail_http 400
      in
354
      let%lwt auth = match auth with
Stephane Glondu's avatar
Stephane Glondu committed
355 356 357 358 359 360 361
        | Some "password" -> return `Password
        | Some "dummy" -> return `Dummy
        | Some "cas" -> return @@ `CAS cas_server
        | _ -> fail_http 400
      in
      create_new_election u credmgmt auth
   | None -> forbidden ())
Stephane Glondu's avatar
Stephane Glondu committed
362

363
let generic_setup_page f uuid () =
364
  match%lwt Web_state.get_site_user () with
365 366
  | Some u ->
     let uuid_s = Uuidm.to_string uuid in
367
     let%lwt se = get_setup_election uuid_s in
368 369 370 371 372
     if se.se_owner = u
     then f uuid se ()
     else forbidden ()
  | None -> forbidden ()

Stephane Glondu's avatar
Stephane Glondu committed
373
let () = Html5.register ~service:election_setup
374
  (generic_setup_page T.election_setup)
Stephane Glondu's avatar
Stephane Glondu committed
375

376
let () = Html5.register ~service:election_setup_trustees
377 378
  (generic_setup_page T.election_setup_trustees)

379 380 381
let () = Html5.register ~service:election_setup_threshold_trustees
  (generic_setup_page T.election_setup_threshold_trustees)

382 383
let () = Html5.register ~service:election_setup_credential_authority
  (generic_setup_page T.election_setup_credential_authority)
384

Stephane Glondu's avatar
Stephane Glondu committed
385 386
let election_setup_mutex = Lwt_mutex.create ()

387
let handle_setup f uuid x =
388
  match%lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
389 390 391
  | Some u ->
     let uuid_s = Uuidm.to_string uuid in
     Lwt_mutex.with_lock election_setup_mutex (fun () ->
392
       let%lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
393
       if se.se_owner = u then (
394 395
         try%lwt
           let%lwt cont = f se x u uuid in
396
           set_setup_election uuid_s se >>
397
           cont ()
Stephane Glondu's avatar
Stephane Glondu committed
398
         with e ->
399 400
           let service = preapply election_setup uuid in
           T.generic_page ~title:"Error" ~service (Printexc.to_string e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
401 402 403
       ) else forbidden ()
     )
  | None -> forbidden ()
404

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

407 408 409 410 411
let () =
  Any.register
    ~service:election_setup_languages
    (handle_setup
       (fun se languages _ uuid ->
412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440
         let langs = languages_of_string languages in
         match langs with
         | None -> assert false
         | Some [] ->
            return (fun () ->
                let service = preapply election_setup uuid in
                T.generic_page ~title:"Error" ~service
                  "You must select at least one language!" () >>= Html5.send
              )
         | Some ls ->
            let unavailable =
              List.filter (fun x ->
                  not (List.mem x available_languages)
                ) ls
            in
            match unavailable with
            | [] ->
               se.se_metadata <- {
                  se.se_metadata with
                  e_languages = langs
                };
               return (redir_preapply election_setup uuid)
            | l :: _ ->
               return (fun () ->
                   let service = preapply election_setup uuid in
                   T.generic_page ~title:"Error" ~service
                     ("No such language: " ^ l) () >>= Html5.send
                 )
    ))
441

442 443 444 445
let () =
  Any.register
    ~service:election_setup_description
    (handle_setup
446
       (fun se (name, description) _ uuid ->
447 448 449
         se.se_questions <- {se.se_questions with
           t_name = name;
           t_description = description;
450 451
         };
         return (redir_preapply election_setup uuid)))
452

Stephane Glondu's avatar
Stephane Glondu committed
453
let generate_password langs title url id =
454
  let email, login = split_identity id in
455 456
  let%lwt salt = generate_token () in
  let%lwt password = generate_token () in
457
  let hashed = sha256_hex (salt ^ password) in
Stephane Glondu's avatar
Stephane Glondu committed
458 459 460 461 462 463
  let bodies = List.map (fun lang ->
    let module L = (val Web_i18n.get_lang lang) in
    Printf.sprintf L.mail_password title login password url
  ) langs in
  let body = PString.concat "\n\n----------\n\n" bodies in
  let body = body ^ "\n\n-- \nBelenios" in
Stephane Glondu's avatar
Stephane Glondu committed
464 465 466 467 468
  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
469
  send_email email subject body >>
470
  return (salt, hashed)
471

472
let handle_password se uuid ~force voters =
473 474 475
  if List.length voters > !maxmailsatonce then
    Lwt.fail (Failure (Printf.sprintf "Cannot send passwords, there are too many voters (max is %d)" !maxmailsatonce))
  else
476 477 478 479
  let title = se.se_questions.t_name in
  let url = Eliom_uri.make_string_uri ~absolute:true ~service:election_home
    (uuid, ()) |> rewrite_prefix
  in
480
  let langs = get_languages se.se_metadata.e_languages in
481 482 483 484
  Lwt_list.iter_s (fun id ->
    match id.sv_password with
    | Some _ when not force -> return_unit
    | None | Some _ ->
485
       let%lwt x = generate_password langs title url id.sv_id in
486 487 488
       return (id.sv_password <- Some x)
  ) voters >>
  return (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
489
    let service = preapply election_setup uuid in
490
    T.generic_page ~title:"Success" ~service
491 492
      "Passwords have been generated and mailed!" () >>= Html5.send)

493 494 495 496 497
let () =
  Any.register
    ~service:election_setup_auth_genpwd
    (handle_setup
       (fun se () _ uuid ->
498
         handle_password se uuid ~force:false se.se_voters))
499

500 501 502
let () =
  Any.register
    ~service:election_regenpwd
Stephane Glondu's avatar
Stephane Glondu committed
503
    (fun (uuid, ()) () ->
504 505 506 507 508 509
      T.regenpwd uuid () >>= Html5.send)

let () =
  Any.register
    ~service:election_regenpwd_post
    (fun (uuid, ()) user ->
510
      let uuid_s = Uuidm.to_string uuid in
511 512
      let%lwt w = find_election uuid_s in
      let%lwt metadata = Web_persist.get_election_metadata uuid_s in
513
      let module W = (val w) in
514
      let%lwt site_user = Web_state.get_site_user () in
515
      match site_user with
516
      | Some u when metadata.e_owner = Some u ->
517 518 519 520 521 522 523
         let table = "password_" ^ underscorize uuid_s in
         let table = Ocsipersist.open_table table in
         let title = W.election.e_params.e_name in
         let url = Eliom_uri.make_string_uri
           ~absolute:true ~service:election_home
           (uuid, ()) |> rewrite_prefix
         in
524
         let service = preapply election_admin (uuid, ()) in
525 526
         begin try%lwt
           let%lwt _ = Ocsipersist.find table user in
527
           let langs = get_languages metadata.e_languages in
528
           let%lwt x = generate_password langs title url user in
529
           Ocsipersist.add table user x >>
530
           dump_passwords (!spool_dir / uuid_s) table >>
531
           T.generic_page ~title:"Success" ~service
532 533 534
             ("A new password has been mailed to " ^ user ^ ".") ()
           >>= Html5.send
         with Not_found ->
535
           T.generic_page ~title:"Error" ~service
536 537 538 539 540 541
             (user ^ " is not a registered user for this election.") ()
           >>= Html5.send
         end
      | _ -> forbidden ()
    )

Stephane Glondu's avatar
Stephane Glondu committed
542 543 544 545
let () =
  Html5.register
    ~service:election_setup_questions
    (fun uuid () ->
546
     match%lwt Web_state.get_site_user () with
547 548
     | Some u ->
        let uuid_s = Uuidm.to_string uuid in
549
        let%lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
550
        if se.se_owner = u
551
        then T.election_setup_questions uuid se ()
Stephane Glondu's avatar
Stephane Glondu committed
552 553
        else forbidden ()
     | None -> forbidden ()
554 555
    )

Stephane Glondu's avatar
Stephane Glondu committed
556 557 558 559
let () =
  Any.register
    ~service:election_setup_questions_post
    (handle_setup
560 561
       (fun se x _ uuid ->
        se.se_questions <- template_of_string x;
562
         return (redir_preapply election_setup uuid)))
Stephane Glondu's avatar
Stephane Glondu committed
563

Stephane Glondu's avatar
Stephane Glondu committed
564 565 566 567
let () =
  Html5.register
    ~service:election_setup_voters
    (fun uuid () ->
568
      match%lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
569 570
      | Some u ->
         let uuid_s = Uuidm.to_string uuid in
571
         let%lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
572
         if se.se_owner = u
573
         then T.election_setup_voters uuid se !maxmailsatonce ()
Stephane Glondu's avatar
Stephane Glondu committed
574 575 576 577 578
         else forbidden ()
      | None -> forbidden ()
    )

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

Stephane Glondu's avatar
Stephane Glondu committed
583 584
let is_identity x =
  try ignore (Pcre.pcre_exec ~rex:identity_rex x); true
Stephane Glondu's avatar
Stephane Glondu committed
585 586
  with Not_found -> false

587 588 589 590 591 592 593 594
let email_rex = Pcre.regexp
  ~flags:[`CASELESS]
  "^[A-Z0-9._%+-]+@[A-Z0-9.-]+\\.[A-Z]{2,7}$"

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

595 596
module SSet = Set.Make (PString)

597
let merge_voters a b f =
598 599 600 601 602 603 604
  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
605
      (SSet.add sv_id existing, {sv_id; sv_password = f sv_id} :: accu)
606 607 608
  ) (existing, List.rev a) b in
  List.rev res

Stephane Glondu's avatar
Stephane Glondu committed
609 610
let () =
  Any.register
611
    ~service:election_setup_voters_add
Stephane Glondu's avatar
Stephane Glondu committed
612
    (handle_setup
613
       (fun se x _ uuid ->
614
         if se.se_public_creds_received then forbidden () else (
Stephane Glondu's avatar
Stephane Glondu committed
615 616 617
         let xs = Pcre.split x in
         let () =
           try
Stephane Glondu's avatar
Stephane Glondu committed
618 619
             let bad = List.find (fun x -> not (is_identity x)) xs in
             Printf.ksprintf failwith "%S is not a valid identity" bad
Stephane Glondu's avatar
Stephane Glondu committed
620 621
           with Not_found -> ()
         in
622
         se.se_voters <- merge_voters se.se_voters xs (fun _ -> None);
623
         return (redir_preapply election_setup_voters uuid))))
624 625 626 627 628 629

let () =
  Any.register
    ~service:election_setup_voters_remove
    (handle_setup
       (fun se voter _ uuid ->
630
         if se.se_public_creds_received then forbidden () else (
631 632 633
         se.se_voters <- List.filter (fun v ->
           v.sv_id <> voter
         ) se.se_voters;
634
         return (redir_preapply election_setup_voters uuid))))
Stephane Glondu's avatar
Stephane Glondu committed
635

636 637 638 639 640 641 642
let () =
  Any.register ~service:election_setup_voters_passwd
    (handle_setup
       (fun se voter _ uuid ->
         let voter = List.filter (fun v -> v.sv_id = voter) se.se_voters in
         handle_password se uuid ~force:true voter))

Stephane Glondu's avatar
Stephane Glondu committed
643
let () =
644
  Any.register
Stephane Glondu's avatar
Stephane Glondu committed
645
    ~service:election_setup_trustee_add
646 647
    (fun uuid st_id ->
     if is_email st_id then
648
     match%lwt Web_state.get_site_user () with
649 650
     | Some u ->
        let uuid_s = Uuidm.to_string uuid in
Stephane Glondu's avatar
Stephane Glondu committed
651
        Lwt_mutex.with_lock election_setup_mutex (fun () ->
652
          let%lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
653 654
          if se.se_owner = u
          then (
655
            let%lwt st_token = generate_token () in
656 657
            let trustee = {st_id; st_token; st_public_key = ""} in
            se.se_public_keys <- se.se_public_keys @ [trustee];
658
            set_setup_election uuid_s se >>
659
            Ocsipersist.add election_pktokens st_token uuid_s
Stephane Glondu's avatar
Stephane Glondu committed
660 661
          ) else forbidden ()
        ) >>
662
        Redirection.send (preapply election_setup_trustees uuid)
663
     | None -> forbidden ()
664 665
     else
       let msg = st_id ^ " is not a valid e-mail address!" in
666 667
       let service = preapply election_setup_trustees uuid in
       T.generic_page ~title:"Error" ~service msg () >>= Html5.send
668 669 670 671 672
    )

let () =
  Redirection.register
    ~service:election_setup_trustee_del
673
    (fun uuid index ->
674
     match%lwt Web_state.get_site_user () with
675 676 677
     | Some u ->
        let uuid_s = Uuidm.to_string uuid in
        Lwt_mutex.with_lock election_setup_mutex (fun () ->
678
          let%lwt se = get_setup_election uuid_s in
679 680
          if se.se_owner = u
          then (
681 682 683 684 685 686 687
            let trustees, old =
              se.se_public_keys |>
              List.mapi (fun i x -> i, x) |>
              List.partition (fun (i, _) -> i <> index) |>
              (fun (x, y) -> List.map snd x, List.map snd y)
            in
            se.se_public_keys <- trustees;
688
            set_setup_election uuid_s se >>
689 690 691
            Lwt_list.iter_s (fun {st_token; _} ->
              Ocsipersist.remove election_pktokens st_token
            ) old
692 693
          ) else forbidden ()
        ) >>
694
        return (preapply election_setup_trustees uuid)
695 696 697
     | None -> forbidden ()
    )

Stephane Glondu's avatar
Stephane Glondu committed
698 699 700 701
let () =
  Html5.register
    ~service:election_setup_credentials
    (fun token () ->
702 703
     let%lwt uuid = Ocsipersist.find election_credtokens token in
     let%lwt se = get_setup_election uuid in
704 705 706 707
     let uuid = match Uuidm.of_string uuid with
       | None -> failwith "invalid UUID extracted from credtokens"
       | Some u -> u
     in
Stephane Glondu's avatar
Stephane Glondu committed
708 709
     T.election_setup_credentials token uuid se ()
    )
710

Stephane Glondu's avatar
Stephane Glondu committed
711 712 713 714 715
let () =
  File.register
    ~service:election_setup_credentials_download
    ~content_type:"text/plain"
    (fun token () ->
716
     let%lwt uuid = Ocsipersist.find election_credtokens token in
Stephane Glondu's avatar
Stephane Glondu committed
717 718
     return (!spool_dir / uuid ^ ".public_creds.txt")
    )
719

Stephane Glondu's avatar
Stephane Glondu committed
720
let wrap_handler f =
721
  try%lwt f ()
Stephane Glondu's avatar
Stephane Glondu committed
722
  with
723
  | e -> T.generic_page ~title:"Error" (Printexc.to_string e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
724 725

let handle_credentials_post token creds =
726 727
  let%lwt uuid = Ocsipersist.find election_credtokens token in
  let%lwt se = get_setup_election uuid in
728
  if se.se_public_creds_received then forbidden () else
Stephane Glondu's avatar
Stephane Glondu committed
729 730 731 732 733 734 735 736 737 738
  let module G = (val Group.of_string se.se_group : GROUP) in
  let fname = !spool_dir / uuid ^ ".public_creds.txt" in
  Lwt_mutex.with_lock
    election_setup_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)
    ) >>
739
  let%lwt () =
Stephane Glondu's avatar
Stephane Glondu committed
740 741 742 743 744 745 746 747 748 749 750
    let i = ref 1 in
    Lwt_stream.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)
      (Lwt_io.lines_of_file fname)
  in
751
  let () = se.se_metadata <- {se.se_metadata with e_cred_authority = None} in
752
  let () = se.se_public_creds_received <- true in
753
  set_setup_election uuid se >>
754
  T.generic_page ~title:"Success" ~service:home
755
    "Credentials have been received and checked!" () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
756 757 758 759 760 761 762

let () =
  Any.register
    ~service:election_setup_credentials_post
    (fun token creds ->
     let s = Lwt_stream.of_string creds in
     wrap_handler (fun () -> handle_credentials_post token s))
763

Stephane Glondu's avatar
Stephane Glondu committed
764 765 766 767 768 769 770
let () =
  Any.register
    ~service:election_setup_credentials_post_file
    (fun token creds ->
     let s = Lwt_io.chars_of_file creds.Ocsigen_extensions.tmp_filename in
     wrap_handler (fun () -> handle_credentials_post token s))

771
module CG = Credential.MakeGenerate (LwtRandom)
772 773 774 775

let () =
  Any.register
    ~service:election_setup_credentials_server
776
    (handle_setup (fun se () _ uuid ->
777 778
      let nvoters = List.length se.se_voters in
      if nvoters > !maxmailsatonce then
779
        Lwt.fail (Failure (Printf.sprintf "Cannot send credentials, there are too many voters (max is %d)" !maxmailsatonce))
780 781
      else if nvoters = 0 then
        Lwt.fail (Failure "No voters")
782
      else
783
      if se.se_public_creds_received then forbidden () else
784 785 786
      let () = se.se_metadata <- {se.se_metadata with
        e_cred_authority = Some "server"
      } in
787
      let uuid_s = Uuidm.to_string uuid in
788 789 790 791 792
      let title = se.se_questions.t_name in
      let url = Eliom_uri.make_string_uri
        ~absolute:true ~service:election_home
        (uuid, ()) |> rewrite_prefix
      in
793 794
      let module S = Set.Make (PString) in
      let module G = (val Group.of_string se.se_group : GROUP) in
795
      let module CD = Credential.MakeDerive (G) in
796
      let%lwt creds =
797 798
        Lwt_list.fold_left_s (fun accu v ->
          let email, login = split_identity v.sv_id in
799
          let%lwt cred = CG.generate () in
800
          let pub_cred =
801
            let x = CD.derive uuid cred in
802 803 804
            let y = G.(g **~ x) in
            G.to_string y
          in
805
          let langs = get_languages se.se_metadata.e_languages in
Stephane Glondu's avatar
Stephane Glondu committed
806 807 808 809 810 811
          let bodies = List.map (fun lang ->
            let module L = (val Web_i18n.get_lang lang) in
            Printf.sprintf L.mail_credential title login cred url
          ) langs in
          let body = PString.concat "\n\n----------\n\n" bodies in
          let body = body ^ "\n\n-- \nBelenios" in
Stephane Glondu's avatar
Stephane Glondu committed
812 813 814 815 816
          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
817
          let%lwt () = send_email email subject body in
818 819 820 821 822
          return @@ S.add pub_cred accu
        ) S.empty se.se_voters
      in
      let creds = S.elements creds in
      let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in
823
      let%lwt () =
824 825 826 827
          Lwt_io.with_file
            ~flags:(Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC]))
            ~perm:0o600 ~mode:Lwt_io.Output fname
            (fun oc ->
828
              Lwt_list.iter_s (Lwt_io.write_line oc) creds)
829
      in
830
      se.se_public_creds_received <- true;
831
      return (fun () ->
832 833
        let service = preapply election_setup uuid in
        T.generic_page ~title:"Success" ~service
834
          "Credentials have been generated and mailed!" () >>= Html5.send)))
835

Stephane Glondu's avatar
Stephane Glondu committed
836 837 838 839
let () =
  Html5.register
    ~service:election_setup_trustee
    (fun token () ->
840 841
     let%lwt uuid = Ocsipersist.find election_pktokens token in
     let%lwt se = get_setup_election uuid in
842 843 844 845 846
     let uuid = match Uuidm.of_string uuid with
       | None -> failwith "invalid UUID extracted from pktokens"
       | Some u -> u
     in
     T.election_setup_trustee token uuid se ()
Stephane Glondu's avatar
Stephane Glondu committed
847 848 849 850 851 852 853 854
    )

let () =
  Any.register
    ~service:election_setup_trustee_post
    (fun token public_key ->
     wrap_handler
       (fun () ->
855
        let%lwt uuid = Ocsipersist.find election_pktokens token in
Stephane Glondu's avatar
Stephane Glondu committed
856 857 858
        Lwt_mutex.with_lock
          election_setup_mutex
          (fun () ->
859
           let%lwt se = get_setup_election uuid in
860
           let t = List.find (fun x -> token = x.st_token) se.se_public_keys in
Stephane Glondu's avatar
Stephane Glondu committed
861 862
           let module G = (val Group.of_string se.se_group : GROUP) in
           let pk = trustee_public_key_of_string G.read public_key in
863
           let module KG = Trustees.MakeSimple (G) (LwtRandom) in
Stephane Glondu's avatar
Stephane Glondu committed
864 865
           if not (KG.check pk) then failwith "invalid public key";
           (* we keep pk as a string because of G.t *)
866
           t.st_public_key <- public_key;
867
           set_setup_election uuid se
868
          ) >> T.generic_page ~title:"Success"
869 870
            "Your key has been received and checked!"
            () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
871 872 873
       )
    )