web_site.ml 72.3 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
Stephane Glondu's avatar
Stephane Glondu committed
24
open Serializable_builtin_t
25
open Serializable_j
26
open Signatures
27
open Common
28
open Web_serializable_builtin_t
Stephane Glondu's avatar
Stephane Glondu committed
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
Stephane Glondu's avatar
Stephane Glondu committed
36

37 38
let ( / ) = Filename.concat

Stephane Glondu's avatar
Stephane Glondu committed
39
module PString = String
Stephane Glondu's avatar
Stephane Glondu committed
40

Stephane Glondu's avatar
Stephane Glondu committed
41 42 43 44 45 46 47 48 49
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"

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

Stephane Glondu's avatar
Stephane Glondu committed
53 54 55
(* Table with tokens given to trustees (in threshold mode) to decrypt *)
let election_tokens_decrypt = Ocsipersist.open_table "site_tokens_decrypt"

Stephane Glondu's avatar
Stephane Glondu committed
56 57 58 59 60
(* 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
61
let raw_find_election uuid =
62
  let%lwt raw_election = Web_persist.get_raw_election uuid in
63 64
  match raw_election with
  | Some raw_election ->
Stephane Glondu's avatar
Stephane Glondu committed
65
     return (Election.of_string raw_election)
66
  | _ -> Lwt.fail Not_found
Stephane Glondu's avatar
Stephane Glondu committed
67

Stephane Glondu's avatar
Stephane Glondu committed
68
module WCacheTypes = struct
69
  type key = uuid
Stephane Glondu's avatar
Stephane Glondu committed
70
  type value = Yojson.Safe.json election
Stephane Glondu's avatar
Stephane Glondu committed
71 72 73 74 75 76 77 78
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

79
let get_setup_election uuid =
Stephane Glondu's avatar
Stephane Glondu committed
80
  let%lwt se = Ocsipersist.find election_stable (raw_string_of_uuid uuid) in
81
  return (setup_election_of_string se)
82

83
let set_setup_election uuid se =
Stephane Glondu's avatar
Stephane Glondu committed
84
  Ocsipersist.add election_stable (raw_string_of_uuid uuid) (string_of_setup_election se)
85

Stephane Glondu's avatar
Stephane Glondu committed
86
let dump_passwords dir table =
Stephane Glondu's avatar
Stephane Glondu committed
87 88 89 90 91 92
  Lwt_io.(with_file Output (dir / "passwords.csv") (fun oc ->
    Ocsipersist.iter_step (fun voter (salt, hashed) ->
      write_line oc (voter ^ "," ^ salt ^ "," ^ hashed)
    ) table
  ))

93
let finalize_election uuid se =
Stephane Glondu's avatar
Stephane Glondu committed
94
  let uuid_s = raw_string_of_uuid uuid in
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
  (* 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
115 116 117 118 119 120 121 122 123 124 125
  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)
         | _ :: _ ->
126 127 128 129 130 131 132 133 134 135 136 137
            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
138 139 140 141 142 143 144
            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),
145
                private_key)
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
       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)
169 170
  in
  (* election parameters *)
171
  let metadata = { se.se_metadata with e_trustees = trustees } in
172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
  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 >>
194 195 196 197
  (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]
  ) >>
198
  create_file "voters.txt" (fun x -> x.sv_id) se.se_voters >>
199
  create_file "metadata.json" string_of_metadata [metadata] >>
200 201
  create_file "election.json" (fun x -> x) [raw_election] >>
  (* construct Web_election instance *)
202 203 204 205
  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
206
  (* set up authentication *)
207
  let%lwt () =
208
    match metadata.e_auth_config with
209 210 211 212 213 214 215
    | 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
216
       Web_persist.set_auth_config (Some uuid) auth_config
217 218
  in
  (* inject credentials *)
219
  let%lwt () =
220
    let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in
221 222 223 224 225 226
    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
227
  in
228
  (* create file with private keys, if any *)
229
  let%lwt () =
230 231 232 233
    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
234 235 236 237
  in
  (* clean up setup database *)
  Ocsipersist.remove election_credtokens se.se_public_creds >>
  Lwt_list.iter_s
238
    (fun {st_token; _} ->
239 240 241 242
      if st_token <> "" then (
        Ocsipersist.remove election_pktokens st_token
      ) else return_unit
    )
243
    se.se_public_keys >>
244 245 246 247 248 249 250
  (match se.se_threshold_trustees with
   | None -> return_unit
   | Some ts ->
      Lwt_list.iter_s
        (fun x -> Ocsipersist.remove election_tpktokens x.stt_token)
        ts
  ) >>
251 252
  Ocsipersist.remove election_stable uuid_s >>
  (* inject passwords *)
253
  (match metadata.e_auth_config with
254
  | Some [{auth_system = "password"; _}] ->
255
     let table = "password_" ^ underscorize uuid in
256 257 258 259 260 261 262 263
     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 >>
264
       dump_passwords (!spool_dir / uuid_s) table
265 266
  | _ -> return_unit) >>
  (* finish *)
267 268
  Web_persist.set_election_state uuid `Open >>
  Web_persist.set_election_date uuid (now ())
Stephane Glondu's avatar
Stephane Glondu committed
269

Stephane Glondu's avatar
Stephane Glondu committed
270 271 272 273
let cleanup_table ?uuid_s table =
  let table = Ocsipersist.open_table table in
  match uuid_s with
  | None ->
274
     let%lwt indexes = Ocsipersist.fold_step (fun k _ accu ->
Stephane Glondu's avatar
Stephane Glondu committed
275 276 277 278 279 280
       return (k :: accu)) table []
     in
     Lwt_list.iter_s (Ocsipersist.remove table) indexes
  | Some u -> Ocsipersist.remove table u

let cleanup_file f =
281
  try%lwt Lwt_unix.unlink f
Stephane Glondu's avatar
Stephane Glondu committed
282 283
  with _ -> return_unit

284
let archive_election uuid =
Stephane Glondu's avatar
Stephane Glondu committed
285
  let uuid_s = raw_string_of_uuid uuid in
286
  let uuid_u = underscorize uuid in
287
  let%lwt () = cleanup_table ~uuid_s "election_states" in
Stephane Glondu's avatar
Stephane Glondu committed
288
  let%lwt () = cleanup_table ~uuid_s "site_tokens_decrypt" in
289 290 291 292 293 294 295
  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
296
  let%lwt () = cleanup_file (!spool_dir / uuid_s / "private_keys.jsons") in
Stephane Glondu's avatar
Stephane Glondu committed
297 298
  return_unit

Stephane Glondu's avatar
Stephane Glondu committed
299 300
let () = Any.register ~service:home
  (fun () () ->
301
    Eliom_reference.unset Web_state.cont >>
302
    Redirection.send admin
Stephane Glondu's avatar
Stephane Glondu committed
303 304
  )

305
let get_finalized_elections_by_owner u =
306
  let%lwt elections, tallied, archived =
307
    Web_persist.get_elections_by_owner u >>=
308 309 310 311
    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 uuid in
Stephane Glondu's avatar
Stephane Glondu committed
312
        let elections, tallied, archived = accu in
313
        match state with
Stephane Glondu's avatar
Stephane Glondu committed
314 315 316 317
        | `Tallied _ -> return (elections, (date, w) :: tallied, archived)
        | `Archived -> return (elections, tallied, (date, w) :: archived)
        | _ -> return ((date, w) :: elections, tallied, archived)
    ) ([], [], [])
318 319 320 321 322
  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
323
  return (sort elections, sort tallied, sort archived)
324

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

Stephane Glondu's avatar
Stephane Glondu committed
330 331
let () = Html5.register ~service:admin
  (fun () () ->
Stephane Glondu's avatar
Stephane Glondu committed
332
    let cont () = Redirection.send admin in
333
    Eliom_reference.set Web_state.cont [cont] >>
334 335
    let%lwt site_user = Web_state.get_site_user () in
    let%lwt elections =
336
      match site_user with
337
      | None -> return None
Stephane Glondu's avatar
Stephane Glondu committed
338
      | Some u ->
339 340
         let%lwt elections, tallied, archived = get_finalized_elections_by_owner u in
         let%lwt setup_elections =
341
           Ocsipersist.fold_step (fun k v accu ->
342
             let v = setup_election_of_string v in
343
             if v.se_owner = u then
Stephane Glondu's avatar
Stephane Glondu committed
344
               return ((uuid_of_raw_string k, v.se_questions.t_name) :: accu)
345 346
             else return accu
           ) election_stable []
347
         in
Stephane Glondu's avatar
Stephane Glondu committed
348
         return @@ Some (elections, tallied, archived, setup_elections)
Stephane Glondu's avatar
Stephane Glondu committed
349
    in
350
    T.admin ~elections ()
Stephane Glondu's avatar
Stephane Glondu committed
351 352
  )

353
let () = File.register ~service:source_code
Stephane Glondu's avatar
Stephane Glondu committed
354 355 356
  ~content_type:"application/x-gzip"
  (fun () () -> return !source_file)

357 358
let generate_uuid =
  let gen = Uuidm.v4_gen (Random.State.make_self_init ()) in
359 360 361 362 363 364
  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 ()
Stephane Glondu's avatar
Stephane Glondu committed
365

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

Stephane Glondu's avatar
Stephane Glondu committed
368 369 370 371 372 373 374 375 376 377
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
378
  let%lwt uuid = generate_uuid () in
Stephane Glondu's avatar
Stephane Glondu committed
379
  let uuid_s = raw_string_of_uuid uuid in
380
  let%lwt token = generate_token () in
Stephane Glondu's avatar
Stephane Glondu committed
381 382 383 384
  let se_metadata = {
    e_owner = Some owner;
    e_auth_config;
    e_cred_authority;
385
    e_trustees = None;
386
    e_languages = Some ["en"; "fr"];
387
    e_contact = None;
Stephane Glondu's avatar
Stephane Glondu committed
388 389
  } in
  let question = {
Stephane Glondu's avatar
Stephane Glondu committed
390
    q_answers = [| "Answer 1"; "Answer 2"; "Answer 3" |];
391
    q_blank = None;
Stephane Glondu's avatar
Stephane Glondu committed
392
    q_min = 1;
Stephane Glondu's avatar
Stephane Glondu committed
393
    q_max = 2;
Stephane Glondu's avatar
Stephane Glondu committed
394 395 396 397 398 399 400 401 402
    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;
403
    se_group = "{\"g\":\"2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627\",\"p\":\"20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719\",\"q\":\"78571733251071885079927659812671450121821421258408794611510081919805623223441\"}"; (* generated by fips.sage *)
Stephane Glondu's avatar
Stephane Glondu committed
404 405 406 407 408
    se_voters = [];
    se_questions;
    se_public_keys = [];
    se_metadata;
    se_public_creds = token;
409
    se_public_creds_received = false;
410 411 412 413
    se_threshold = None;
    se_threshold_trustees = None;
    se_threshold_parameters = None;
    se_threshold_error = None;
Stephane Glondu's avatar
Stephane Glondu committed
414
  } in
415
  let%lwt () = set_setup_election uuid se in
416
  let%lwt () = Ocsipersist.add election_credtokens token uuid_s in
417
  redir_preapply election_setup uuid ()
Stephane Glondu's avatar
Stephane Glondu committed
418 419 420 421

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

422
let () = Any.register ~service:election_setup_new
Stephane Glondu's avatar
Stephane Glondu committed
423
  (fun () (credmgmt, (auth, cas_server)) ->
424 425 426 427 428 429 430 431 432 433 434 435 436 437 438
    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
      )
  )
Stephane Glondu's avatar
Stephane Glondu committed
439

440
let with_setup_election_ro uuid f =
441
  with_site_user (fun u ->
442
      let%lwt se = get_setup_election uuid in
443
      if se.se_owner = u then
444
        f se
445 446
      else forbidden ()
    )
447

448 449 450 451 452 453 454
let () =
  Html5.register ~service:election_setup
    (fun uuid () ->
      with_setup_election_ro uuid (fun se ->
          T.election_setup uuid se ()
        )
    )
Stephane Glondu's avatar
Stephane Glondu committed
455

456 457 458 459
let () =
  Any.register ~service:election_setup_trustees
    (fun uuid () ->
      with_setup_election_ro uuid (fun se ->
460 461 462
          match se.se_threshold_trustees with
          | None -> T.election_setup_trustees uuid se () >>= Html5.send
          | Some _ -> redir_preapply election_setup_threshold_trustees uuid ()
463 464
        )
    )
465

466 467 468 469 470 471 472
let () =
  Html5.register ~service:election_setup_threshold_trustees
    (fun uuid () ->
      with_setup_election_ro uuid (fun se ->
          T.election_setup_threshold_trustees uuid se ()
        )
    )
473

474 475 476 477 478 479 480
let () =
  Html5.register ~service:election_setup_credential_authority
    (fun uuid () ->
      with_setup_election_ro uuid (fun se ->
          T.election_setup_credential_authority uuid se ()
        )
    )
481

Stephane Glondu's avatar
Stephane Glondu committed
482 483
let election_setup_mutex = Lwt_mutex.create ()

484
let with_setup_election ?(save = true) uuid f =
485 486
  with_site_user (fun u ->
      Lwt_mutex.with_lock election_setup_mutex (fun () ->
487
          let%lwt se = get_setup_election uuid in
488 489
          if se.se_owner = u then (
            try%lwt
490
              let%lwt r = f se in
Stephane Glondu's avatar
Stephane Glondu committed
491
              let%lwt () = if save then set_setup_election uuid se else return_unit in
492
              return r
493 494 495 496 497 498
            with e ->
              let service = preapply election_setup uuid in
              T.generic_page ~title:"Error" ~service (Printexc.to_string e) () >>= Html5.send
          ) else forbidden ()
        )
    )
499

500
let () =
501
  Any.register ~service:election_setup_languages
502 503 504 505
    (fun uuid languages ->
      with_setup_election uuid (fun se ->
          let langs = languages_of_string languages in
          match langs with
Stephane Glondu's avatar
Stephane Glondu committed
506
          | [] ->
507 508 509
             let service = preapply election_setup uuid in
             T.generic_page ~title:"Error" ~service
               "You must select at least one language!" () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
510
          | _ :: _ ->
511 512 513
             let unavailable =
               List.filter (fun x ->
                   not (List.mem x available_languages)
Stephane Glondu's avatar
Stephane Glondu committed
514
                 ) langs
515 516 517 518 519
             in
             match unavailable with
             | [] ->
                se.se_metadata <- {
                   se.se_metadata with
Stephane Glondu's avatar
Stephane Glondu committed
520
                   e_languages = Some langs
521 522 523
                 };
                redir_preapply election_setup uuid ()
             | l :: _ ->
524 525
                let service = preapply election_setup uuid in
                T.generic_page ~title:"Error" ~service
526 527 528
                  ("No such language: " ^ l) () >>= Html5.send
        )
    )
529

530 531 532 533
let () =
  Any.register ~service:election_setup_contact
    (fun uuid contact ->
      with_setup_election uuid (fun se ->
534 535 536 537 538
          let contact =
            if contact = "" || contact = default_contact then
              None
            else Some contact
          in
539 540 541 542 543 544 545 546
          se.se_metadata <- {
              se.se_metadata with
              e_contact = contact
            };
          redir_preapply election_setup uuid ()
        )
    )

547
let () =
548
  Any.register ~service:election_setup_description
549 550 551 552 553 554 555 556 557
    (fun uuid (name, description) ->
      with_setup_election uuid (fun se ->
          se.se_questions <- {se.se_questions with
                               t_name = name;
                               t_description = description;
                             };
          redir_preapply election_setup uuid ()
        )
    )
558

559
let generate_password metadata langs title url id =
560
  let email, login = split_identity id in
561 562
  let%lwt salt = generate_token () in
  let%lwt password = generate_token () in
563
  let hashed = sha256_hex (salt ^ password) in
Stephane Glondu's avatar
Stephane Glondu committed
564 565
  let bodies = List.map (fun lang ->
    let module L = (val Web_i18n.get_lang lang) in
566 567
    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
568 569 570
  ) 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
571 572 573 574 575
  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
576
  send_email email subject body >>
577
  return (salt, hashed)
578

579
let handle_password se uuid ~force voters =
580 581 582
  if List.length voters > !maxmailsatonce then
    Lwt.fail (Failure (Printf.sprintf "Cannot send passwords, there are too many voters (max is %d)" !maxmailsatonce))
  else
583 584 585 586
  let title = se.se_questions.t_name in
  let url = Eliom_uri.make_string_uri ~absolute:true ~service:election_home
    (uuid, ()) |> rewrite_prefix
  in
587
  let langs = get_languages se.se_metadata.e_languages in
588 589 590 591 592
  let%lwt () =
    Lwt_list.iter_s (fun id ->
        match id.sv_password with
        | Some _ when not force -> return_unit
        | None | Some _ ->
593
           let%lwt x = generate_password se.se_metadata langs title url id.sv_id in
594 595 596 597 598 599
           return (id.sv_password <- Some x)
      ) voters
  in
  let service = preapply election_setup uuid in
  T.generic_page ~title:"Success" ~service
    "Passwords have been generated and mailed!" () >>= Html5.send
600

601
let () =
602
  Any.register ~service:election_setup_auth_genpwd
603 604 605 606 607
    (fun uuid () ->
      with_setup_election uuid (fun se ->
          handle_password se uuid ~force:false se.se_voters
        )
    )
608

609
let () =
610
  Any.register ~service:election_regenpwd
Stephane Glondu's avatar
Stephane Glondu committed
611
    (fun (uuid, ()) () ->
612 613 614
      T.regenpwd uuid () >>= Html5.send)

let () =
615
  Any.register ~service:election_regenpwd_post
616
    (fun (uuid, ()) user ->
617
      with_site_user (fun u ->
Stephane Glondu's avatar
Stephane Glondu committed
618
          let%lwt election = find_election uuid in
619
          let%lwt metadata = Web_persist.get_election_metadata uuid in
620
          if metadata.e_owner = Some u then (
621
            let table = "password_" ^ underscorize uuid in
622
            let table = Ocsipersist.open_table table in
Stephane Glondu's avatar
Stephane Glondu committed
623
            let title = election.e_params.e_name in
624 625 626 627 628 629 630 631
            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 _ = Ocsipersist.find table user in
               let langs = get_languages metadata.e_languages in
632
               let%lwt x = generate_password metadata langs title url user in
633
               Ocsipersist.add table user x >>
Stephane Glondu's avatar
Stephane Glondu committed
634
                 dump_passwords (!spool_dir / raw_string_of_uuid uuid) table >>
635 636 637 638 639 640 641 642 643 644
                 T.generic_page ~title:"Success" ~service
                   ("A new password has been mailed to " ^ user ^ ".") ()
               >>= Html5.send
              with Not_found ->
                T.generic_page ~title:"Error" ~service
                  (user ^ " is not a registered user for this election.") ()
                >>= Html5.send
            )
          ) else forbidden ()
        )
645 646
    )

Stephane Glondu's avatar
Stephane Glondu committed
647
let () =
648
  Html5.register ~service:election_setup_questions
Stephane Glondu's avatar
Stephane Glondu committed
649
    (fun uuid () ->
650 651
      with_setup_election_ro uuid (fun se ->
          T.election_setup_questions uuid se ()
652
        )
653 654
    )

Stephane Glondu's avatar
Stephane Glondu committed
655
let () =
656
  Any.register ~service:election_setup_questions_post
657 658 659 660 661 662
    (fun uuid template ->
      with_setup_election uuid (fun se ->
          se.se_questions <- template_of_string template;
          redir_preapply election_setup uuid ()
        )
    )
Stephane Glondu's avatar
Stephane Glondu committed
663

Stephane Glondu's avatar
Stephane Glondu committed
664
let () =
665
  Html5.register ~service:election_setup_voters
Stephane Glondu's avatar
Stephane Glondu committed
666
    (fun uuid () ->
667 668
      with_setup_election_ro uuid (fun se ->
          T.election_setup_voters uuid se !maxmailsatonce ()
669
        )
Stephane Glondu's avatar
Stephane Glondu committed
670 671 672
    )

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

Stephane Glondu's avatar
Stephane Glondu committed
677 678
let is_identity x =
  try ignore (Pcre.pcre_exec ~rex:identity_rex x); true
Stephane Glondu's avatar
Stephane Glondu committed
679 680
  with Not_found -> false

681
let merge_voters a b f =
682 683 684 685 686 687 688
  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
689
      (SSet.add sv_id existing, {sv_id; sv_password = f sv_id} :: accu)
690 691 692
  ) (existing, List.rev a) b in
  List.rev res

Stephane Glondu's avatar
Stephane Glondu committed
693
let () =
694
  Any.register ~service:election_setup_voters_add
695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711
    (fun uuid voters ->
      with_setup_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_setup_voters uuid ()
          )
        )
    )
712 713

let () =
714
  Any.register ~service:election_setup_voters_remove
715 716 717 718 719 720 721 722 723 724
    (fun uuid voter ->
      with_setup_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_setup_voters uuid ()
          )
        )
    )
Stephane Glondu's avatar
Stephane Glondu committed
725

726 727
let () =
  Any.register ~service:election_setup_voters_passwd
728 729 730 731 732 733
    (fun uuid voter ->
      with_setup_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
        )
    )
734

Stephane Glondu's avatar
Stephane Glondu committed
735
let () =
736
  Any.register ~service:election_setup_trustee_add
737
    (fun uuid st_id ->
738
      with_setup_election uuid (fun se ->
739
          if is_email st_id then (
740
            let%lwt st_token = generate_token () in
741
            let trustee = {st_id; st_token; st_public_key = ""; st_private_key = None} in
742
            se.se_public_keys <- se.se_public_keys @ [trustee];
Stephane Glondu's avatar
Stephane Glondu committed
743
            let%lwt () = Ocsipersist.add election_pktokens st_token (raw_string_of_uuid uuid) in
744
            redir_preapply election_setup_trustees uuid ()
745 746 747 748 749 750
          ) else (
            let msg = st_id ^ " is not a valid e-mail address!" in
            let service = preapply election_setup_trustees uuid in
            T.generic_page ~title:"Error" ~service msg () >>= Html5.send
          )
        )
751 752
    )

753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769
let () =
  Any.register ~service:election_setup_trustee_add_server
    (fun uuid () ->
      with_setup_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_setup_trustees uuid ()
        )
    )

770
let () =
771
  Any.register ~service:election_setup_trustee_del
772
    (fun uuid index ->
773 774 775 776 777 778 779 780 781 782
      with_setup_election uuid (fun se ->
          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;
          let%lwt () =
            Lwt_list.iter_s (fun {st_token; _} ->
783 784 785
                if st_token <> "" then (
                  Ocsipersist.remove election_pktokens st_token
                ) else return_unit
786 787 788
              ) old
          in
          redir_preapply election_setup_trustees uuid ()
789
        )
790 791
    )

Stephane Glondu's avatar
Stephane Glondu committed
792
let () =
793
  Html5.register ~service:election_setup_credentials
Stephane Glondu's avatar
Stephane Glondu committed
794
    (fun token () ->
795
     let%lwt uuid = Ocsipersist.find election_credtokens token in
Stephane Glondu's avatar
Stephane Glondu committed
796
     let uuid = uuid_of_raw_string uuid in
797
     let%lwt se = get_setup_election uuid in
Stephane Glondu's avatar
Stephane Glondu committed
798 799
     T.election_setup_credentials token uuid se ()
    )
800

Stephane Glondu's avatar
Stephane Glondu committed
801
let wrap_handler f =
802
  try%lwt f ()
Stephane Glondu's avatar
Stephane Glondu committed
803
  with
804
  | e -> T.generic_page ~title:"Error" (Printexc.to_string e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
805 806

let handle_credentials_post token creds =
807
  let%lwt uuid = Ocsipersist.find election_credtokens token in
Stephane Glondu's avatar
Stephane Glondu committed
808
  let uuid = uuid_of_raw_string uuid in
809
  let%lwt se = get_setup_election uuid in
810
  if se.se_public_creds_received then forbidden () else
Stephane Glondu's avatar
Stephane Glondu committed
811
  let module G = (val Group.of_string se.se_group : GROUP) in
Stephane Glondu's avatar
Stephane Glondu committed
812
  let fname = !spool_dir / raw_string_of_uuid uuid ^ ".public_creds.txt" in
Stephane Glondu's avatar
Stephane Glondu committed
813 814 815 816 817 818 819 820
  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)
    ) >>
821
  let%lwt () =
Stephane Glondu's avatar
Stephane Glondu committed
822
    let i = ref 1 in
823 824 825 826 827 828 829 830 831 832 833 834 835
    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
Stephane Glondu's avatar
Stephane Glondu committed
836
  in
837
  let () = se.se_metadata <- {se.se_metadata with e_cred_authority = None} in
838
  let () = se.se_public_creds_received <- true in
839
  set_setup_election uuid se >>
840
  T.generic_page ~title:"Success"
841
    "Credentials have been received and checked!" () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
842 843

let () =
844
  Any.register ~service:election_setup_credentials_post
Stephane Glondu's avatar
Stephane Glondu committed
845 846 847
    (fun token creds ->
     let s = Lwt_stream.of_string creds in
     wrap_handler (fun () -> handle_credentials_post token s))
848

Stephane Glondu's avatar
Stephane Glondu committed
849
let () =
850
  Any.register ~service:election_setup_credentials_post_file
Stephane Glondu's avatar
Stephane Glondu committed
851 852 853 854
    (fun token creds ->
     let s = Lwt_io.chars_of_file creds.Ocsigen_extensions.tmp_filename in
     wrap_handler (fun () -> handle_credentials_post token s))

855
module CG = Credential.MakeGenerate (LwtRandom)
856 857

let () =
858
  Any.register ~service:election_setup_credentials_server
859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880
    (fun uuid () ->
      with_setup_election uuid (fun se ->
          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")
          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 ->
881
                  let email, _ = split_identity v.sv_id in
882 883 884 885 886
                  let cas =
                    match se.se_metadata.e_auth_config with
                    | Some [{auth_system = "cas"; _}] -> true
                    | _ -> false
                  in
887 888 889 890 891 892 893 894 895
                  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