web_site.ml 49 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"
Stephane Glondu's avatar
Stephane Glondu committed
33

34 35
let ( / ) = Filename.concat

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

Stephane Glondu's avatar
Stephane Glondu committed
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
open Eliom_service
open Eliom_registration

module LwtRandom = MakeLwtRandom (struct let rng = make_rng () end)

(* 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"

(* 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
54
let raw_find_election uuid =
55
  lwt raw_election = Web_persist.get_raw_election uuid in
56 57 58 59
  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
60

Stephane Glondu's avatar
Stephane Glondu committed
61 62
module WCacheTypes = struct
  type key = string
63
  type value = (module ELECTION_DATA)
Stephane Glondu's avatar
Stephane Glondu committed
64 65 66 67 68 69 70 71
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

72
let get_setup_election uuid_s =
73 74
  lwt se = Ocsipersist.find election_stable uuid_s in
  return (setup_election_of_string se)
75 76

let set_setup_election uuid_s se =
77
  Ocsipersist.add election_stable uuid_s (string_of_setup_election se)
78

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

86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
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
  let module KG = Election.MakeSimpleDistKeyGen (G) (LwtRandom) in
109
  lwt trustees, public_keys, private_key =
110 111 112
    match se.se_public_keys with
    | [] ->
       lwt private_key, public_key = KG.generate_and_prove () in
113
       return (None, [public_key], Some private_key)
114
    | _ :: _ ->
115 116 117
       return (
         Some (List.map (fun {st_id; _} -> st_id) se.se_public_keys),
         (List.map
118 119 120
            (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
121 122
            ) se.se_public_keys),
         None)
123 124 125
  in
  let y = KG.combine (Array.of_list public_keys) in
  (* election parameters *)
126
  let metadata = { se.se_metadata with e_trustees = trustees } in
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
  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;
    e_short_name = template.t_short_name;
  } 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 >>
152
  create_file "metadata.json" string_of_metadata [metadata] >>
153 154
  create_file "election.json" (fun x -> x) [raw_election] >>
  (* construct Web_election instance *)
155
  let election = Group.election_params_of_string raw_election in
156 157 158
  let module W = Web_election.Make ((val election)) (LwtRandom) in
  (* set up authentication *)
  lwt () =
159
    match metadata.e_auth_config with
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
    | 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 *)
  lwt () =
    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 *)
  lwt () =
    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
186 187
    (fun {st_token; _} ->
      Ocsipersist.remove election_pktokens st_token)
188 189 190
    se.se_public_keys >>
  Ocsipersist.remove election_stable uuid_s >>
  (* inject passwords *)
191
  (match metadata.e_auth_config with
192 193 194 195 196 197 198 199 200 201
  | 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 >>
202
       dump_passwords (!spool_dir / uuid_s) table
203 204
  | _ -> return_unit) >>
  (* finish *)
Stephane Glondu's avatar
Stephane Glondu committed
205
  Web_persist.set_election_state uuid_s `Open >>
206
  Web_persist.set_election_date uuid_s (now ())
Stephane Glondu's avatar
Stephane Glondu committed
207

Stephane Glondu's avatar
Stephane Glondu committed
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233
let cleanup_table ?uuid_s table =
  let table = Ocsipersist.open_table table in
  match uuid_s with
  | None ->
     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 archive_election uuid_s =
  let uuid_u = underscorize uuid_s in
  lwt () = cleanup_table ~uuid_s "election_states" in
  lwt () = cleanup_table ~uuid_s "election_pds" in
  lwt () = cleanup_table ~uuid_s "auth_configs" in
  lwt () = cleanup_table ("password_" ^ uuid_u) in
  lwt () = cleanup_table ("records_" ^ uuid_u) in
  lwt () = cleanup_table ("creds_" ^ uuid_u) in
  lwt () = cleanup_table ("ballots_" ^ uuid_u) in
  lwt () = cleanup_file (!spool_dir / uuid_s / "private_key.json") in
  return_unit

Stephane Glondu's avatar
Stephane Glondu committed
234 235
let () = Any.register ~service:home
  (fun () () ->
236
    Eliom_reference.unset Web_state.cont >>
237
    T.home () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
238 239
  )

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

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

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

let do_get_randomness =
289
  let prng = Lazy.from_fun (Lwt_preemptive.detach (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
290 291 292 293 294 295 296
    pseudo_rng (random_string secure_rng 16)
  )) in
  let mutex = Lwt_mutex.create () in
  fun () ->
    Lwt_mutex.with_lock mutex (fun () ->
      lwt prng = Lazy.force prng in
      return (random_string prng 32)
297 298
    )

299 300 301
let b64_encode_compact x =
  Cryptokit.(transform_string (Base64.encode_compact ()) x)

Stephane Glondu's avatar
Stephane Glondu committed
302 303 304 305 306 307 308 309 310 311 312
let () = String.register
  ~service:get_randomness
  (fun () () ->
    lwt r = do_get_randomness () in
    b64_encode_compact r |>
    (fun x -> string_of_randomness { randomness=x }) |>
    (fun x -> return (x, "application/json"))
  )

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

Stephane Glondu's avatar
Stephane Glondu committed
313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
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
  lwt token = generate_token () in
  let se_metadata = {
    e_owner = Some owner;
    e_auth_config;
    e_cred_authority;
330
    e_trustees = None;
Stephane Glondu's avatar
Stephane Glondu committed
331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351
  } in
  let question = {
    q_answers = [| "Answer 1"; "Answer 2"; "Blank" |];
    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 |];
    t_short_name = "short_name";
  } in
  let se = {
    se_owner = owner;
    se_group = "{\"g\":\"14887492224963187634282421537186040801304008017743492304481737382571933937568724473847106029915040150784031882206090286938661464458896494215273989547889201144857352611058572236578734319505128042602372864570426550855201448111746579871811249114781674309062693442442368697449970648232621880001709535143047913661432883287150003429802392229361583608686643243349727791976247247948618930423866180410558458272606627111270040091203073580238905303994472202930783207472394578498507764703191288249547659899997131166130259700604433891232298182348403175947450284433411265966789131024573629546048637848902243503970966798589660808533\",\"p\":\"16328632084933010002384055033805457329601614771185955389739167309086214800406465799038583634953752941675645562182498120750264980492381375579367675648771293800310370964745767014243638518442553823973482995267304044326777047662957480269391322789378384619428596446446984694306187644767462460965622580087564339212631775817895958409016676398975671266179637898557687317076177218843233150695157881061257053019133078545928983562221396313169622475509818442661047018436264806901023966236718367204710755935899013750306107738002364137917426595737403871114187750804346564731250609196846638183903982387884578266136503697493474682071\",\"q\":\"61329566248342901292543872769978950870633559608669337131139375508370458778917\"}";
    se_voters = [];
    se_questions;
    se_public_keys = [];
    se_metadata;
    se_public_creds = token;
352
    se_public_creds_received = false;
Stephane Glondu's avatar
Stephane Glondu committed
353
  } in
354
  lwt () = set_setup_election uuid_s se in
Stephane Glondu's avatar
Stephane Glondu committed
355 356 357 358 359 360
  lwt () = Ocsipersist.add election_credtokens token uuid_s in
  return (preapply election_setup uuid)

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

Stephane Glondu's avatar
Stephane Glondu committed
361
let () = Redirection.register ~service:election_setup_new
Stephane Glondu's avatar
Stephane Glondu committed
362
  (fun () (credmgmt, (auth, cas_server)) ->
363
   match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
364
   | Some u ->
Stephane Glondu's avatar
Stephane Glondu committed
365 366 367 368 369 370 371 372 373 374 375 376 377
      lwt credmgmt = match credmgmt with
        | Some "auto" -> return `Automatic
        | Some "manual" -> return `Manual
        | _ -> fail_http 400
      in
      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
   | None -> forbidden ())
Stephane Glondu's avatar
Stephane Glondu committed
378

379
let generic_setup_page f uuid () =
380
  match_lwt Web_state.get_site_user () with
381 382
  | Some u ->
     let uuid_s = Uuidm.to_string uuid in
383
     lwt se = get_setup_election uuid_s in
384 385 386 387 388
     if se.se_owner = u
     then f uuid se ()
     else forbidden ()
  | None -> forbidden ()

Stephane Glondu's avatar
Stephane Glondu committed
389
let () = Html5.register ~service:election_setup
390
  (generic_setup_page T.election_setup)
Stephane Glondu's avatar
Stephane Glondu committed
391

392
let () = Html5.register ~service:election_setup_trustees
393 394 395 396
  (generic_setup_page T.election_setup_trustees)

let () = Html5.register ~service:election_setup_credential_authority
  (generic_setup_page T.election_setup_credential_authority)
397

Stephane Glondu's avatar
Stephane Glondu committed
398 399
let election_setup_mutex = Lwt_mutex.create ()

400
let handle_setup f uuid x =
401
  match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
402 403 404
  | Some u ->
     let uuid_s = Uuidm.to_string uuid in
     Lwt_mutex.with_lock election_setup_mutex (fun () ->
405
       lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
406 407
       if se.se_owner = u then (
         try_lwt
408
           lwt cont = f se x u uuid in
409
           set_setup_election uuid_s se >>
410
           cont ()
Stephane Glondu's avatar
Stephane Glondu committed
411
         with e ->
412 413
           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
414 415 416
       ) else forbidden ()
     )
  | None -> forbidden ()
417

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

420 421 422 423
let () =
  Any.register
    ~service:election_setup_description
    (handle_setup
424
       (fun se (name, description) _ uuid ->
425 426 427
         se.se_questions <- {se.se_questions with
           t_name = name;
           t_description = description;
428 429
         };
         return (redir_preapply election_setup uuid)))
430

Stephane Glondu's avatar
Stephane Glondu committed
431
let generate_password langs title url id =
432
  let email, login = split_identity id in
433 434 435
  lwt salt = generate_token () in
  lwt password = generate_token () in
  let hashed = sha256_hex (salt ^ password) in
Stephane Glondu's avatar
Stephane Glondu committed
436 437 438 439 440 441
  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
442
  let subject = "Your password for election " ^ title in
443
  send_email email subject body >>
444
  return (salt, hashed)
445

446 447 448 449 450 451 452 453 454
let handle_password se uuid ~force voters =
  let title = se.se_questions.t_name in
  let url = Eliom_uri.make_string_uri ~absolute:true ~service:election_home
    (uuid, ()) |> rewrite_prefix
  in
  Lwt_list.iter_s (fun id ->
    match id.sv_password with
    | Some _ when not force -> return_unit
    | None | Some _ ->
Stephane Glondu's avatar
Stephane Glondu committed
455
       lwt x = generate_password langs title url id.sv_id in
456 457 458
       return (id.sv_password <- Some x)
  ) voters >>
  return (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
459
    let service = preapply election_setup uuid in
460
    T.generic_page ~title:"Success" ~service
461 462
      "Passwords have been generated and mailed!" () >>= Html5.send)

463 464 465 466 467
let () =
  Any.register
    ~service:election_setup_auth_genpwd
    (handle_setup
       (fun se () _ uuid ->
468
         handle_password se uuid ~force:false se.se_voters))
469

470 471 472
let () =
  Any.register
    ~service:election_regenpwd
Stephane Glondu's avatar
Stephane Glondu committed
473
    (fun (uuid, ()) () ->
474 475 476 477 478 479
      T.regenpwd uuid () >>= Html5.send)

let () =
  Any.register
    ~service:election_regenpwd_post
    (fun (uuid, ()) user ->
480
      let uuid_s = Uuidm.to_string uuid in
481
      lwt w = find_election uuid_s in
482
      lwt metadata = Web_persist.get_election_metadata uuid_s in
483
      let module W = (val w) in
484
      lwt site_user = Web_state.get_site_user () in
485
      match site_user with
486
      | Some u when metadata.e_owner = Some u ->
487 488 489 490 491 492 493
         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
494
         let service = preapply election_admin (uuid, ()) in
495 496
         begin try_lwt
           lwt _ = Ocsipersist.find table user in
Stephane Glondu's avatar
Stephane Glondu committed
497
           lwt x = generate_password langs title url user in
498
           Ocsipersist.add table user x >>
499
           dump_passwords (!spool_dir / uuid_s) table >>
500
           T.generic_page ~title:"Success" ~service
501 502 503
             ("A new password has been mailed to " ^ user ^ ".") ()
           >>= Html5.send
         with Not_found ->
504
           T.generic_page ~title:"Error" ~service
505 506 507 508 509 510
             (user ^ " is not a registered user for this election.") ()
           >>= Html5.send
         end
      | _ -> forbidden ()
    )

Stephane Glondu's avatar
Stephane Glondu committed
511 512 513 514
let () =
  Html5.register
    ~service:election_setup_questions
    (fun uuid () ->
515
     match_lwt Web_state.get_site_user () with
516 517
     | Some u ->
        let uuid_s = Uuidm.to_string uuid in
518
        lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
519
        if se.se_owner = u
520
        then T.election_setup_questions uuid se ()
Stephane Glondu's avatar
Stephane Glondu committed
521 522
        else forbidden ()
     | None -> forbidden ()
523 524
    )

Stephane Glondu's avatar
Stephane Glondu committed
525 526 527 528
let () =
  Any.register
    ~service:election_setup_questions_post
    (handle_setup
529 530 531
       (fun se x _ uuid ->
        se.se_questions <- template_of_string x;
         return (redir_preapply election_setup_questions uuid)))
Stephane Glondu's avatar
Stephane Glondu committed
532

Stephane Glondu's avatar
Stephane Glondu committed
533 534 535 536
let () =
  Html5.register
    ~service:election_setup_voters
    (fun uuid () ->
537
      match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
538 539
      | Some u ->
         let uuid_s = Uuidm.to_string uuid in
540
         lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
541
         if se.se_owner = u
542
         then T.election_setup_voters uuid se ()
Stephane Glondu's avatar
Stephane Glondu committed
543 544 545 546 547
         else forbidden ()
      | None -> forbidden ()
    )

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

Stephane Glondu's avatar
Stephane Glondu committed
552 553
let is_identity x =
  try ignore (Pcre.pcre_exec ~rex:identity_rex x); true
Stephane Glondu's avatar
Stephane Glondu committed
554 555
  with Not_found -> false

556 557 558 559 560 561 562 563
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

564 565
module SSet = Set.Make (PString)

566
let merge_voters a b f =
567 568 569 570 571 572 573
  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
574
      (SSet.add sv_id existing, {sv_id; sv_password = f sv_id} :: accu)
575 576 577
  ) (existing, List.rev a) b in
  List.rev res

Stephane Glondu's avatar
Stephane Glondu committed
578 579
let () =
  Any.register
580
    ~service:election_setup_voters_add
Stephane Glondu's avatar
Stephane Glondu committed
581
    (handle_setup
582
       (fun se x _ uuid ->
583
         if se.se_public_creds_received then forbidden () else (
Stephane Glondu's avatar
Stephane Glondu committed
584 585 586
         let xs = Pcre.split x in
         let () =
           try
Stephane Glondu's avatar
Stephane Glondu committed
587 588
             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
589 590
           with Not_found -> ()
         in
591
         se.se_voters <- merge_voters se.se_voters xs (fun _ -> None);
592
         return (redir_preapply election_setup_voters uuid))))
593 594 595 596 597 598

let () =
  Any.register
    ~service:election_setup_voters_remove
    (handle_setup
       (fun se voter _ uuid ->
599
         if se.se_public_creds_received then forbidden () else (
600 601 602
         se.se_voters <- List.filter (fun v ->
           v.sv_id <> voter
         ) se.se_voters;
603
         return (redir_preapply election_setup_voters uuid))))
Stephane Glondu's avatar
Stephane Glondu committed
604

605 606 607 608 609 610 611
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
612
let () =
613
  Any.register
Stephane Glondu's avatar
Stephane Glondu committed
614
    ~service:election_setup_trustee_add
615 616
    (fun uuid st_id ->
     if is_email st_id then
617
     match_lwt Web_state.get_site_user () with
618 619
     | Some u ->
        let uuid_s = Uuidm.to_string uuid in
Stephane Glondu's avatar
Stephane Glondu committed
620
        Lwt_mutex.with_lock election_setup_mutex (fun () ->
621
          lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
622 623
          if se.se_owner = u
          then (
624
            lwt st_token = generate_token () in
625 626
            let trustee = {st_id; st_token; st_public_key = ""} in
            se.se_public_keys <- se.se_public_keys @ [trustee];
627
            set_setup_election uuid_s se >>
628
            Ocsipersist.add election_pktokens st_token uuid_s
Stephane Glondu's avatar
Stephane Glondu committed
629 630
          ) else forbidden ()
        ) >>
631
        Redirection.send (preapply election_setup_trustees uuid)
632
     | None -> forbidden ()
633 634
     else
       let msg = st_id ^ " is not a valid e-mail address!" in
635 636
       let service = preapply election_setup_trustees uuid in
       T.generic_page ~title:"Error" ~service msg () >>= Html5.send
637 638 639 640 641
    )

let () =
  Redirection.register
    ~service:election_setup_trustee_del
642
    (fun uuid index ->
643
     match_lwt Web_state.get_site_user () with
644 645 646
     | Some u ->
        let uuid_s = Uuidm.to_string uuid in
        Lwt_mutex.with_lock election_setup_mutex (fun () ->
647
          lwt se = get_setup_election uuid_s in
648 649
          if se.se_owner = u
          then (
650 651 652 653 654 655 656
            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;
657
            set_setup_election uuid_s se >>
658 659 660
            Lwt_list.iter_s (fun {st_token; _} ->
              Ocsipersist.remove election_pktokens st_token
            ) old
661 662
          ) else forbidden ()
        ) >>
663
        return (preapply election_setup_trustees uuid)
664 665 666
     | None -> forbidden ()
    )

Stephane Glondu's avatar
Stephane Glondu committed
667 668 669 670 671
let () =
  Html5.register
    ~service:election_setup_credentials
    (fun token () ->
     lwt uuid = Ocsipersist.find election_credtokens token in
672
     lwt se = get_setup_election uuid in
Stephane Glondu's avatar
Stephane Glondu committed
673 674
     T.election_setup_credentials token uuid se ()
    )
675

Stephane Glondu's avatar
Stephane Glondu committed
676 677 678 679 680 681 682 683
let () =
  File.register
    ~service:election_setup_credentials_download
    ~content_type:"text/plain"
    (fun token () ->
     lwt uuid = Ocsipersist.find election_credtokens token in
     return (!spool_dir / uuid ^ ".public_creds.txt")
    )
684

Stephane Glondu's avatar
Stephane Glondu committed
685 686 687
let wrap_handler f =
  try_lwt f ()
  with
688
  | e -> T.generic_page ~title:"Error" (Printexc.to_string e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
689 690 691

let handle_credentials_post token creds =
  lwt uuid = Ocsipersist.find election_credtokens token in
692
  lwt se = get_setup_election uuid in
693
  if se.se_public_creds_received then forbidden () else
Stephane Glondu's avatar
Stephane Glondu committed
694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715
  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)
    ) >>
  lwt () =
    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
716
  let () = se.se_metadata <- {se.se_metadata with e_cred_authority = None} in
717
  let () = se.se_public_creds_received <- true in
718
  set_setup_election uuid se >>
719
  T.generic_page ~title:"Success" ~service:home
720
    "Credentials have been received and checked!" () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
721 722 723 724 725 726 727

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))
728

Stephane Glondu's avatar
Stephane Glondu committed
729 730 731 732 733 734 735
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))

736
module CG = Credential.MakeGenerate (LwtRandom)
737 738 739 740

let () =
  Any.register
    ~service:election_setup_credentials_server
741
    (handle_setup (fun se () _ uuid ->
742
      if se.se_public_creds_received then forbidden () else
743 744 745
      let () = se.se_metadata <- {se.se_metadata with
        e_cred_authority = Some "server"
      } in
746
      let uuid_s = Uuidm.to_string uuid in
747 748 749 750 751
      let title = se.se_questions.t_name in
      let url = Eliom_uri.make_string_uri
        ~absolute:true ~service:election_home
        (uuid, ()) |> rewrite_prefix
      in
752 753
      let module S = Set.Make (PString) in
      let module G = (val Group.of_string se.se_group : GROUP) in
754
      let module CD = Credential.MakeDerive (G) in
755
      lwt creds =
756 757
        Lwt_list.fold_left_s (fun accu v ->
          let email, login = split_identity v.sv_id in
758
          lwt cred = CG.generate () in
759
          let pub_cred =
760
            let x = CD.derive uuid cred in
761 762 763
            let y = G.(g **~ x) in
            G.to_string y
          in
Stephane Glondu's avatar
Stephane Glondu committed
764 765 766 767 768 769
          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
770
          let subject = "Your credential for election " ^ title in
771
          lwt () = send_email email subject body in
772 773 774 775 776
          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
777
      lwt () =
778 779 780 781
          Lwt_io.with_file
            ~flags:(Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC]))
            ~perm:0o600 ~mode:Lwt_io.Output fname
            (fun oc ->
782
              Lwt_list.iter_s (Lwt_io.write_line oc) creds)
783
      in
784
      se.se_public_creds_received <- true;
785
      return (fun () ->
786 787
        let service = preapply election_setup uuid in
        T.generic_page ~title:"Success" ~service
788
          "Credentials have been generated and mailed!" () >>= Html5.send)))
789

Stephane Glondu's avatar
Stephane Glondu committed
790 791 792 793 794
let () =
  Html5.register
    ~service:election_setup_trustee
    (fun token () ->
     lwt uuid = Ocsipersist.find election_pktokens token in
795
     lwt se = get_setup_election uuid in
Stephane Glondu's avatar
Stephane Glondu committed
796
     T.election_setup_trustee token se ()
Stephane Glondu's avatar
Stephane Glondu committed
797 798 799 800 801 802 803 804 805 806 807 808
    )

let () =
  Any.register
    ~service:election_setup_trustee_post
    (fun token public_key ->
     wrap_handler
       (fun () ->
        lwt uuid = Ocsipersist.find election_pktokens token in
        Lwt_mutex.with_lock
          election_setup_mutex
          (fun () ->
809
           lwt se = get_setup_election uuid in
810
           let t = List.find (fun x -> token = x.st_token) se.se_public_keys in
Stephane Glondu's avatar
Stephane Glondu committed
811 812 813 814 815
           let module G = (val Group.of_string se.se_group : GROUP) in
           let pk = trustee_public_key_of_string G.read public_key in
           let module KG = Election.MakeSimpleDistKeyGen (G) (LwtRandom) in
           if not (KG.check pk) then failwith "invalid public key";
           (* we keep pk as a string because of G.t *)
816
           t.st_public_key <- public_key;
817
           set_setup_election uuid se
818
          ) >> T.generic_page ~title:"Success"
819 820
            "Your key has been received and checked!"
            () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
821 822 823
       )
    )

824 825 826 827 828 829 830 831
let () =
  Any.register
    ~service:election_setup_confirm
    (fun uuid () ->
      match_lwt Web_state.get_site_user () with
      | None -> forbidden ()
      | Some u ->
         let uuid_s = Uuidm.to_string uuid in
832
         lwt se = get_setup_election uuid_s in
833 834 835
         if se.se_owner <> u then forbidden () else
         T.election_setup_confirm uuid se () >>= Html5.send)

Stephane Glondu's avatar
Stephane Glondu committed
836 837 838 839
let () =
  Any.register
    ~service:election_setup_create
    (fun uuid () ->
840
     match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
841 842 843
     | None -> forbidden ()
     | Some u ->
        begin try_lwt
844 845
          let uuid_s = Uuidm.to_string uuid in
          Lwt_mutex.with_lock election_setup_mutex (fun () ->
846
            lwt se = get_setup_election uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
847
            if se.se_owner <> u then forbidden () else
848 849
            finalize_election uuid se >>
            Redirection.send (preapply election_admin (uuid, ()))
Stephane Glondu's avatar
Stephane Glondu committed
850 851
          )
        with e ->
852
          T.new_election_failure (`Exception e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
853 854
        end
    )
855

856 857 858 859
let () =
  Html5.register
    ~service:election_setup_import
    (fun uuid () ->
860
      lwt site_user = Web_state.get_site_user () in
861 862 863
      match site_user with
      | None -> forbidden ()
      | Some u ->
864
         lwt se = get_setup_election (Uuidm.to_string uuid) in
865 866 867 868 869 870 871 872 873 874
         lwt elections = get_finalized_elections_by_owner u in
         T.election_setup_import uuid se elections ())

let () =
  Any.register
    ~service:election_setup_import_post
    (handle_setup
       (fun se from _ uuid ->
         let from_s = Uuidm.to_string from in
         lwt voters = Web_persist.get_voters from_s in
875 876 877 878 879 880 881 882 883
         lwt passwords = Web_persist.get_passwords from_s in
         let get_password =
           match passwords with
           | None -> fun _ -> None
           | Some p -> fun sv_id ->
             let _, login = split_identity sv_id in
             try Some (SMap.find login p)
             with Not_found -> None
         in
884 885 886
         match voters with
         | Some voters ->
            if se.se_public_creds_received then forbidden () else (
887
              se.se_voters <- merge_voters se.se_voters voters get_password;
888 889 890
              return (redir_preapply election_setup_voters uuid))
         | None ->
            return (fun () -> T.generic_page ~title:"Error"
891
              ~service:(preapply election_setup_voters uuid)
892 893 894 895 896 897
              (Printf.sprintf
                 "Could not retrieve voter list from election %s"
                 from_s)
              () >>= Html5.send)))


Stephane Glondu's avatar
Stephane Glondu committed
898 899 900 901
let () =
  Any.register
    ~service:election_home
    (fun (uuid, ()) () ->
902
      let uuid_s = Uuidm.to_string uuid in
903 904 905
      try_lwt
        lwt w = find_election uuid_s in
        let module W = (val w) in
906
        Eliom_reference.unset Web_state.ballot >>
907 908 909 910 911
        let cont () =
          Redirection.send
            (Eliom_service.preapply
               election_home (W.election.e_params.e_uuid, ()))
        in
912
        Eliom_reference.set Web_state.cont [cont] >>
913
        match_lwt Eliom_reference.get Web_state.cast_confirmed with
914
        | Some result ->
915
           Eliom_reference.unset Web_state.cast_confirmed >>
916 917 918 919 920
           T.cast_confirmed (module W) ~result () >>= Html5.send
        | None ->
           lwt state = Web_persist.get_election_state uuid_s in
           T.election_home (module W) state () >>= Html5.send
      with Not_found ->
Stephane Glondu's avatar
Stephane Glondu committed
921 922 923
        lwt lang = Eliom_reference.get Web_state.language in
        let module L = (val Web_i18n.get_lang lang) in
        T.generic_page ~title:L.not_yet_open