web_site.ml 49.1 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

Stephane Glondu's avatar
Stephane Glondu committed
72
let dump_passwords dir table =
Stephane Glondu's avatar
Stephane Glondu committed
73 74 75 76 77 78
  Lwt_io.(with_file Output (dir / "passwords.csv") (fun oc ->
    Ocsipersist.iter_step (fun voter (salt, hashed) ->
      write_line oc (voter ^ "," ^ salt ^ "," ^ hashed)
    ) table
  ))

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

Stephane Glondu's avatar
Stephane Glondu committed
201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
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
227 228
let () = Any.register ~service:home
  (fun () () ->
229
    Eliom_reference.unset Web_state.cont >>
230
    T.home () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
231 232
  )

233
let get_finalized_elections_by_owner u =
Stephane Glondu's avatar
Stephane Glondu committed
234
  lwt elections, tallied, archived =
235 236 237 238 239
    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
240
        let elections, tallied, archived = accu in
241
        match state with
Stephane Glondu's avatar
Stephane Glondu committed
242 243 244 245
        | `Tallied _ -> return (elections, (date, w) :: tallied, archived)
        | `Archived -> return (elections, tallied, (date, w) :: archived)
        | _ -> return ((date, w) :: elections, tallied, archived)
    ) ([], [], [])
246 247 248 249 250
  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
251
  return (sort elections, sort tallied, sort archived)
252

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

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

let do_get_randomness =
281
  let prng = Lazy.from_fun (Lwt_preemptive.detach (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
282 283 284 285 286 287 288
    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)
289 290
    )

291 292 293
let b64_encode_compact x =
  Cryptokit.(transform_string (Base64.encode_compact ()) x)

Stephane Glondu's avatar
Stephane Glondu committed
294 295 296 297 298 299 300 301 302 303 304
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
305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321
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;
322
    e_trustees = None;
Stephane Glondu's avatar
Stephane Glondu committed
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
  } 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;
344
    se_public_creds_received = false;
Stephane Glondu's avatar
Stephane Glondu committed
345 346 347 348 349 350 351 352
  } in
  lwt () = Ocsipersist.add election_stable uuid_s se in
  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
353
let () = Redirection.register ~service:election_setup_new
Stephane Glondu's avatar
Stephane Glondu committed
354
  (fun () (credmgmt, (auth, cas_server)) ->
355
   match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
356
   | Some u ->
Stephane Glondu's avatar
Stephane Glondu committed
357 358 359 360 361 362 363 364 365 366 367 368 369
      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
370

371
let generic_setup_page f uuid () =
372
  match_lwt Web_state.get_site_user () with
373 374 375 376 377 378 379 380
  | Some u ->
     let uuid_s = Uuidm.to_string uuid in
     lwt se = Ocsipersist.find election_stable uuid_s in
     if se.se_owner = u
     then f uuid se ()
     else forbidden ()
  | None -> forbidden ()

Stephane Glondu's avatar
Stephane Glondu committed
381
let () = Html5.register ~service:election_setup
382
  (generic_setup_page T.election_setup)
Stephane Glondu's avatar
Stephane Glondu committed
383

384
let () = Html5.register ~service:election_setup_trustees
385 386 387 388
  (generic_setup_page T.election_setup_trustees)

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

Stephane Glondu's avatar
Stephane Glondu committed
390 391
let election_setup_mutex = Lwt_mutex.create ()

392
let handle_setup f uuid x =
393
  match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
394 395 396 397 398 399
  | Some u ->
     let uuid_s = Uuidm.to_string uuid in
     Lwt_mutex.with_lock election_setup_mutex (fun () ->
       lwt se = Ocsipersist.find election_stable uuid_s in
       if se.se_owner = u then (
         try_lwt
400
           lwt cont = f se x u uuid in
Stephane Glondu's avatar
Stephane Glondu committed
401
           Ocsipersist.add election_stable uuid_s se >>
402
           cont ()
Stephane Glondu's avatar
Stephane Glondu committed
403
         with e ->
404 405
           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
406 407 408
       ) else forbidden ()
     )
  | None -> forbidden ()
409

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

412 413 414 415
let () =
  Any.register
    ~service:election_setup_description
    (handle_setup
416
       (fun se (name, description) _ uuid ->
417 418 419
         se.se_questions <- {se.se_questions with
           t_name = name;
           t_description = description;
420 421
         };
         return (redir_preapply election_setup uuid)))
422

Stephane Glondu's avatar
Stephane Glondu committed
423
let generate_password langs title url id =
424
  let email, login = split_identity id in
425 426 427
  lwt salt = generate_token () in
  lwt password = generate_token () in
  let hashed = sha256_hex (salt ^ password) in
Stephane Glondu's avatar
Stephane Glondu committed
428 429 430 431 432 433
  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
434
  let subject = "Your password for election " ^ title in
435
  send_email email subject body >>
436
  return (salt, hashed)
437

438 439 440 441 442 443 444 445 446
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
447
       lwt x = generate_password langs title url id.sv_id in
448 449 450
       return (id.sv_password <- Some x)
  ) voters >>
  return (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
451
    let service = preapply election_setup uuid in
452
    T.generic_page ~title:"Success" ~service
453 454
      "Passwords have been generated and mailed!" () >>= Html5.send)

455 456 457 458 459
let () =
  Any.register
    ~service:election_setup_auth_genpwd
    (handle_setup
       (fun se () _ uuid ->
460
         handle_password se uuid ~force:false se.se_voters))
461

462 463 464
let () =
  Any.register
    ~service:election_regenpwd
Stephane Glondu's avatar
Stephane Glondu committed
465
    (fun (uuid, ()) () ->
466 467 468 469 470 471
      T.regenpwd uuid () >>= Html5.send)

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

Stephane Glondu's avatar
Stephane Glondu committed
503 504 505 506
let () =
  Html5.register
    ~service:election_setup_questions
    (fun uuid () ->
507
     match_lwt Web_state.get_site_user () with
508 509
     | Some u ->
        let uuid_s = Uuidm.to_string uuid in
Stephane Glondu's avatar
Stephane Glondu committed
510 511
        lwt se = Ocsipersist.find election_stable uuid_s in
        if se.se_owner = u
512
        then T.election_setup_questions uuid se ()
Stephane Glondu's avatar
Stephane Glondu committed
513 514
        else forbidden ()
     | None -> forbidden ()
515 516
    )

Stephane Glondu's avatar
Stephane Glondu committed
517 518 519 520
let () =
  Any.register
    ~service:election_setup_questions_post
    (handle_setup
521 522 523
       (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
524

Stephane Glondu's avatar
Stephane Glondu committed
525 526 527 528
let () =
  Html5.register
    ~service:election_setup_voters
    (fun uuid () ->
529
      match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
530 531 532 533
      | Some u ->
         let uuid_s = Uuidm.to_string uuid in
         lwt se = Ocsipersist.find election_stable uuid_s in
         if se.se_owner = u
534
         then T.election_setup_voters uuid se ()
Stephane Glondu's avatar
Stephane Glondu committed
535 536 537 538 539
         else forbidden ()
      | None -> forbidden ()
    )

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

Stephane Glondu's avatar
Stephane Glondu committed
544 545
let is_identity x =
  try ignore (Pcre.pcre_exec ~rex:identity_rex x); true
Stephane Glondu's avatar
Stephane Glondu committed
546 547
  with Not_found -> false

548 549 550 551 552 553 554 555
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

556 557
module SSet = Set.Make (PString)

558
let merge_voters a b f =
559 560 561 562 563 564 565
  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
566
      (SSet.add sv_id existing, {sv_id; sv_password = f sv_id} :: accu)
567 568 569
  ) (existing, List.rev a) b in
  List.rev res

Stephane Glondu's avatar
Stephane Glondu committed
570 571
let () =
  Any.register
572
    ~service:election_setup_voters_add
Stephane Glondu's avatar
Stephane Glondu committed
573
    (handle_setup
574
       (fun se x _ uuid ->
575
         if se.se_public_creds_received then forbidden () else (
Stephane Glondu's avatar
Stephane Glondu committed
576 577 578
         let xs = Pcre.split x in
         let () =
           try
Stephane Glondu's avatar
Stephane Glondu committed
579 580
             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
581 582
           with Not_found -> ()
         in
583
         se.se_voters <- merge_voters se.se_voters xs (fun _ -> None);
584
         return (redir_preapply election_setup_voters uuid))))
585 586 587 588 589 590

let () =
  Any.register
    ~service:election_setup_voters_remove
    (handle_setup
       (fun se voter _ uuid ->
591
         if se.se_public_creds_received then forbidden () else (
592 593 594
         se.se_voters <- List.filter (fun v ->
           v.sv_id <> voter
         ) se.se_voters;
595
         return (redir_preapply election_setup_voters uuid))))
Stephane Glondu's avatar
Stephane Glondu committed
596

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

let () =
  Redirection.register
    ~service:election_setup_trustee_del
634
    (fun uuid index ->
635
     match_lwt Web_state.get_site_user () with
636 637 638 639 640 641
     | Some u ->
        let uuid_s = Uuidm.to_string uuid in
        Lwt_mutex.with_lock election_setup_mutex (fun () ->
          lwt se = Ocsipersist.find election_stable uuid_s in
          if se.se_owner = u
          then (
642 643 644 645 646 647 648 649 650 651 652
            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;
            Ocsipersist.add election_stable uuid_s se >>
            Lwt_list.iter_s (fun {st_token; _} ->
              Ocsipersist.remove election_pktokens st_token
            ) old
653 654
          ) else forbidden ()
        ) >>
655
        return (preapply election_setup_trustees uuid)
656 657 658
     | None -> forbidden ()
    )

Stephane Glondu's avatar
Stephane Glondu committed
659 660 661 662 663 664 665 666
let () =
  Html5.register
    ~service:election_setup_credentials
    (fun token () ->
     lwt uuid = Ocsipersist.find election_credtokens token in
     lwt se = Ocsipersist.find election_stable uuid in
     T.election_setup_credentials token uuid se ()
    )
667

Stephane Glondu's avatar
Stephane Glondu committed
668 669 670 671 672 673 674 675
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")
    )
676

Stephane Glondu's avatar
Stephane Glondu committed
677 678 679
let wrap_handler f =
  try_lwt f ()
  with
680
  | e -> T.generic_page ~title:"Error" ~service:home (Printexc.to_string e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
681 682 683 684

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

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

Stephane Glondu's avatar
Stephane Glondu committed
721 722 723 724 725 726 727
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))

728
module CG = Credential.MakeGenerate (LwtRandom)
729 730 731 732

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

Stephane Glondu's avatar
Stephane Glondu committed
782 783 784 785 786 787
let () =
  Html5.register
    ~service:election_setup_trustee
    (fun token () ->
     lwt uuid = Ocsipersist.find election_pktokens token in
     lwt se = Ocsipersist.find election_stable uuid in
Stephane Glondu's avatar
Stephane Glondu committed
788
     T.election_setup_trustee token se ()
Stephane Glondu's avatar
Stephane Glondu committed
789 790 791 792 793 794 795 796 797 798 799 800 801
    )

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 () ->
           lwt se = Ocsipersist.find election_stable uuid in
802
           let t = List.find (fun x -> token = x.st_token) se.se_public_keys in
Stephane Glondu's avatar
Stephane Glondu committed
803 804 805 806 807
           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 *)
808
           t.st_public_key <- public_key;
Stephane Glondu's avatar
Stephane Glondu committed
809
           Ocsipersist.add election_stable uuid se
810
          ) >> T.generic_page ~title:"Success" ~service:home
811 812
            "Your key has been received and checked!"
            () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
813 814 815
       )
    )

816 817 818 819 820 821 822 823 824 825 826 827
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
         lwt se = Ocsipersist.find election_stable uuid_s in
         if se.se_owner <> u then forbidden () else
         T.election_setup_confirm uuid se () >>= Html5.send)

Stephane Glondu's avatar
Stephane Glondu committed
828 829 830 831
let () =
  Any.register
    ~service:election_setup_create
    (fun uuid () ->
832
     match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
833 834 835
     | None -> forbidden ()
     | Some u ->
        begin try_lwt
836 837 838
          let uuid_s = Uuidm.to_string uuid in
          Lwt_mutex.with_lock election_setup_mutex (fun () ->
            lwt se = Ocsipersist.find election_stable uuid_s in
Stephane Glondu's avatar
Stephane Glondu committed
839
            if se.se_owner <> u then forbidden () else
840 841
            finalize_election uuid se >>
            Redirection.send (preapply election_admin (uuid, ()))
Stephane Glondu's avatar
Stephane Glondu committed
842 843
          )
        with e ->
844
          T.new_election_failure (`Exception e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
845 846
        end
    )
847

848 849 850 851
let () =
  Html5.register
    ~service:election_setup_import
    (fun uuid () ->
852
      lwt site_user = Web_state.get_site_user () in
853 854 855 856 857 858 859 860 861 862 863 864 865 866
      match site_user with
      | None -> forbidden ()
      | Some u ->
         lwt se = Ocsipersist.find election_stable (Uuidm.to_string uuid) in
         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
867 868 869 870 871 872 873 874 875
         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
876 877 878
         match voters with
         | Some voters ->
            if se.se_public_creds_received then forbidden () else (
879
              se.se_voters <- merge_voters se.se_voters voters get_password;
880 881 882
              return (redir_preapply election_setup_voters uuid))
         | None ->
            return (fun () -> T.generic_page ~title:"Error"
883
              ~service:(preapply election_setup_voters uuid)
884 885 886 887 888 889
              (Printf.sprintf
                 "Could not retrieve voter list from election %s"
                 from_s)
              () >>= Html5.send)))


Stephane Glondu's avatar
Stephane Glondu committed
890 891 892 893
let () =
  Any.register
    ~service:election_home
    (fun (uuid, ()) () ->
894
      let uuid_s = Uuidm.to_string uuid in
895 896 897
      try_lwt
        lwt w = find_election uuid_s in
        let module W = (val w) in
898
        Eliom_reference.unset Web_state.ballot >>
899 900 901 902 903
        let cont () =
          Redirection.send
            (Eliom_service.preapply
               election_home (W.election.e_params.e_uuid, ()))
        in
904
        Eliom_reference.set Web_state.cont [cont] >>
905
        match_lwt Eliom_reference.get Web_state.cast_confirmed with
906
        | Some result ->
907
           Eliom_reference.unset Web_state.cast_confirmed >>
908 909 910 911 912
           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
913 914 915
        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
916
          ~service:(preapply election_home (uuid, ()))
Stephane Glondu's avatar
Stephane Glondu committed
917
          L.come_back_later ()
918
          >>= Html5.send)
919

Stephane Glondu's avatar
Stephane Glondu committed
920 921 922 923 924 925 926 927
let () =
  Any.register ~service:set_cookie_disclaimer
    (fun () () ->
      Eliom_reference.set Web_state.show_cookie_disclaimer false >>
      lwt cont = Web_state.cont_pop () in
      match cont with
      | Some f -> f ()
      | None ->
Stephane Glondu's avatar
Stephane Glondu committed
928 929 930 931
         lwt lang = Eliom_reference.get Web_state.language in
         let module L = (val Web_i18n.get_lang lang) in
         T.generic_page ~title:L.cookies_are_blocked
           ~service:home L.please_enable_them ()
Stephane Glondu's avatar
Stephane Glondu committed
932 933
           >>= Html5.send)

Stephane Glondu's avatar
Stephane Glondu committed
934 935 936 937 938
let () =
  Any.register
    ~service:election_admin
    (fun (uuid, ()) () ->
     let uuid_s = Uuidm.to_string uuid in
939
     lwt w = find_election uuid_s in
940
     lwt metadata = Web_persist.get_election_metadata uuid_s in
941
     lwt site_user = Web_state.get_site_user () in
942
     let module W = (val w) in
943
     match site_user with
944
     | Some u when metadata.e_owner = Some u ->
945
        lwt state = Web_persist.get_election_state uuid_s in
946
        T.election_admin w metadata state () >>= Html5.send
947 948 949 950
     | _ ->
        let cont () =
          Redirection.send (Eliom_service.preapply election_admin (uuid, ()))
        in
951
        Eliom_reference.set Web_state.cont [cont] >>
952
        Redirection.send (Eliom_service.preapply site_login None)
953
    )
954

Stephane Glondu's avatar