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

423
let generate_password 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
428
  let body = Mail_templates.password title login password url in
429
  let subject = "Your password for election " ^ title in
430
  send_email email subject body >>
431
  return (salt, hashed)
432

433 434 435 436 437 438 439 440 441 442 443 444 445
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 _ ->
       lwt x = generate_password title url id.sv_id in
       return (id.sv_password <- Some x)
  ) voters >>
  return (fun () ->
446 447
    let service = preapply election_setup_voters uuid in
    T.generic_page ~title:"Success" ~service
448 449
      "Passwords have been generated and mailed!" () >>= Html5.send)

450 451 452 453 454
let () =
  Any.register
    ~service:election_setup_auth_genpwd
    (handle_setup
       (fun se () _ uuid ->
455
         handle_password se uuid ~force:false se.se_voters))
456

457 458 459
let () =
  Any.register
    ~service:election_regenpwd
Stephane Glondu's avatar
Stephane Glondu committed
460
    (fun (uuid, ()) () ->
461 462 463 464 465 466
      T.regenpwd uuid () >>= Html5.send)

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

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

Stephane Glondu's avatar
Stephane Glondu committed
512 513 514 515
let () =
  Any.register
    ~service:election_setup_questions_post
    (handle_setup
516 517 518
       (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
519

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

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

Stephane Glondu's avatar
Stephane Glondu committed
539 540
let is_identity x =
  try ignore (Pcre.pcre_exec ~rex:identity_rex x); true
Stephane Glondu's avatar
Stephane Glondu committed
541 542
  with Not_found -> false

543 544 545 546 547 548 549 550
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

551 552
module SSet = Set.Make (PString)

553
let merge_voters a b f =
554 555 556 557 558 559 560
  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
561
      (SSet.add sv_id existing, {sv_id; sv_password = f sv_id} :: accu)
562 563 564
  ) (existing, List.rev a) b in
  List.rev res

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

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

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

let () =
  Redirection.register
    ~service:election_setup_trustee_del
629
    (fun uuid index ->
630
     match_lwt Web_state.get_site_user () with
631 632 633 634 635 636
     | 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 (
637 638 639 640 641 642 643 644 645 646 647
            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
648 649
          ) else forbidden ()
        ) >>
650
        return (preapply election_setup_trustees uuid)
651 652 653
     | None -> forbidden ()
    )

Stephane Glondu's avatar
Stephane Glondu committed
654 655 656 657 658 659 660 661
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 ()
    )
662

Stephane Glondu's avatar
Stephane Glondu committed
663 664 665 666 667 668 669 670
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")
    )
671

Stephane Glondu's avatar
Stephane Glondu committed
672 673 674
let wrap_handler f =
  try_lwt f ()
  with
675
  | e -> T.generic_page ~title:"Error" ~service:home (Printexc.to_string e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
676 677 678 679

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

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

Stephane Glondu's avatar
Stephane Glondu committed
716 717 718 719 720 721 722
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))

723
module CG = Credential.MakeGenerate (LwtRandom)
724 725 726 727

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

Stephane Glondu's avatar
Stephane Glondu committed
772 773 774 775 776 777
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
778
     T.election_setup_trustee token se ()
Stephane Glondu's avatar
Stephane Glondu committed
779 780 781 782 783 784 785 786 787 788 789 790 791
    )

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
792
           let t = List.find (fun x -> token = x.st_token) se.se_public_keys in
Stephane Glondu's avatar
Stephane Glondu committed
793 794 795 796 797
           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 *)
798
           t.st_public_key <- public_key;
Stephane Glondu's avatar
Stephane Glondu committed
799
           Ocsipersist.add election_stable uuid se
800
          ) >> T.generic_page ~title:"Success" ~service:home
801 802
            "Your key has been received and checked!"
            () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
803 804 805 806 807 808 809
       )
    )

let () =
  Any.register
    ~service:election_setup_create
    (fun uuid () ->
810
     match_lwt Web_state.get_site_user () with
Stephane Glondu's avatar
Stephane Glondu committed
811 812 813
     | None -> forbidden ()
     | Some u ->
        begin try_lwt
814 815 816
          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
817
            if se.se_owner <> u then forbidden () else
818 819
            finalize_election uuid se >>
            Redirection.send (preapply election_admin (uuid, ()))
Stephane Glondu's avatar
Stephane Glondu committed
820 821
          )
        with e ->
822
          T.new_election_failure (`Exception e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
823 824
        end
    )
825

826 827 828 829
let () =
  Html5.register
    ~service:election_setup_import
    (fun uuid () ->
830
      lwt site_user = Web_state.get_site_user () in
831 832 833 834 835 836 837 838 839 840 841 842 843 844
      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
845 846 847 848 849 850 851 852 853
         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
854 855 856
         match voters with
         | Some voters ->
            if se.se_public_creds_received then forbidden () else (
857
              se.se_voters <- merge_voters se.se_voters voters get_password;
858 859 860
              return (redir_preapply election_setup_voters uuid))
         | None ->
            return (fun () -> T.generic_page ~title:"Error"
861
              ~service:(preapply election_setup_voters uuid)
862 863 864 865 866 867
              (Printf.sprintf
                 "Could not retrieve voter list from election %s"
                 from_s)
              () >>= Html5.send)))


Stephane Glondu's avatar
Stephane Glondu committed
868 869 870 871
let () =
  Any.register
    ~service:election_home
    (fun (uuid, ()) () ->
872
      let uuid_s = Uuidm.to_string uuid in
873 874 875
      try_lwt
        lwt w = find_election uuid_s in
        let module W = (val w) in
876
        Eliom_reference.unset Web_state.ballot >>
877 878 879 880 881
        let cont () =
          Redirection.send
            (Eliom_service.preapply
               election_home (W.election.e_params.e_uuid, ()))
        in
882
        Eliom_reference.set Web_state.cont [cont] >>
883
        match_lwt Eliom_reference.get Web_state.cast_confirmed with
884
        | Some result ->
885
           Eliom_reference.unset Web_state.cast_confirmed >>
886 887 888 889 890
           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
891
        T.generic_page ~title:"Sorry, this election is not yet open"
892
          ~service:(preapply election_home (uuid, ()))
893 894
          "This election does not exist yet. Please come back later." ()
          >>= Html5.send)
895

Stephane Glondu's avatar
Stephane Glondu committed
896 897 898 899 900
let () =
  Any.register
    ~service:election_admin
    (fun (uuid, ()) () ->
     let uuid_s = Uuidm.to_string uuid in
901
     lwt w = find_election uuid_s in
902
     lwt metadata = Web_persist.get_election_metadata uuid_s in
903
     lwt site_user = Web_state.get_site_user () in
904
     let module W = (val w) in
905
     match site_user with
906
     | Some u when metadata.e_owner = Some u ->
907
        lwt state = Web_persist.get_election_state uuid_s in
908
        T.election_admin w metadata state () >>= Html5.send
909 910 911 912
     | _ ->
        let cont () =
          Redirection.send (Eliom_service.preapply election_admin (uuid, ()))
        in
913
        Eliom_reference.set Web_state.cont [cont] >>
914
        Redirection.send (Eliom_service.preapply site_login None)
915
    )
916

917
let election_set_state state (uuid, ()) () =
Stephane Glondu's avatar
Stephane Glondu committed
918
     let uuid_s = Uuidm.to_string uuid in
919
     lwt w = find_election uuid_s in
920
     lwt metadata = Web_persist.get_election_metadata uuid_s in
921
     let module W = (val w) in
922
     lwt () =
923
       match_lwt Web_state.get_site_user () with
924
       | Some u when metadata.e_owner = Some u -> return ()
925 926 927 928 929 930 931 932 933
       | _ -> forbidden ()
     in
     lwt () =
       match_lwt Web_persist.get_election_state uuid_s with
       | `Open | `Closed -> return ()
       | _ -> forbidden ()
     in
     let state = if state then `Open else `Closed in
     Web_persist.set_election_state uuid_s state >>
934 935 936 937
     Redirection.send (preapply election_admin (uuid, ()))

let () = Any.register ~service:election_open (election_set_state true)
let () = Any.register ~service:election_close (election_set_state false)
938

Stephane Glondu's avatar
Stephane Glondu committed
939 940 941
let () = Any.register ~service:election_archive (fun (uuid, ()) () ->
  let uuid_s = Uuidm.to_string uuid in
  lwt w = find_election uuid_s in
942
  lwt metadata = Web_persist.get_election_metadata uuid_s in
943
  lwt site_user = Web_state.get_site_user () in