web_site.ml 47.2 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
           T.generic_page ~title:"Error" (Printexc.to_string e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
405 406 407
       ) else forbidden ()
     )
  | None -> forbidden ()
408

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

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

422
let generate_password title url id =
423
  let email, login = split_identity id in
424 425 426
  lwt salt = generate_token () in
  lwt password = generate_token () in
  let hashed = sha256_hex (salt ^ password) in
427
  let body = Mail_templates.password title login password url in
428
  let subject = "Your password for election " ^ title in
429 430
  send_email "noreply@belenios.org" email subject body >>
  return (salt, hashed)
431

432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447
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 () ->
    T.generic_page ~title:"Success"
      "Passwords have been generated and mailed!" () >>= Html5.send)

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

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

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

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

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

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

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

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

540 541 542 543 544 545 546 547
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

548 549
module SSet = Set.Make (PString)

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

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

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

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

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

Stephane Glondu's avatar
Stephane Glondu committed
650 651 652 653 654 655 656 657
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 ()
    )
658

Stephane Glondu's avatar
Stephane Glondu committed
659 660 661 662 663 664 665 666
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")
    )
667

Stephane Glondu's avatar
Stephane Glondu committed
668 669 670
let wrap_handler f =
  try_lwt f ()
  with
671
  | e -> T.generic_page ~title:"Error" (Printexc.to_string e) () >>= Html5.send
Stephane Glondu's avatar
Stephane Glondu committed
672 673 674 675

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

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

Stephane Glondu's avatar
Stephane Glondu committed
712 713 714 715 716 717 718
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))

719
module CG = Credential.MakeGenerate (LwtRandom)
720 721 722 723

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

Stephane Glondu's avatar
Stephane Glondu committed
767 768 769 770 771 772
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
773
     T.election_setup_trustee token se ()
Stephane Glondu's avatar
Stephane Glondu committed
774 775 776 777 778 779 780 781 782 783 784 785 786
    )

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

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

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


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

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

910
let election_set_state state (uuid, ()) () =
Stephane Glondu's avatar
Stephane Glondu committed
911
     let uuid_s = Uuidm.to_string uuid in
912
     lwt w = find_election uuid_s in
913
     lwt metadata = Web_persist.get_election_metadata uuid_s in
914
     let module W = (val w) in
915
     lwt () =
916
       match_lwt Web_state.get_site_user () with
917
       | Some u when metadata.e_owner = Some u -> return ()
918 919 920 921 922 923 924 925 926
       | _ -> 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 >>
927 928 929 930
     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)
931

Stephane Glondu's avatar
Stephane Glondu committed
932 933 934
let () = Any.register ~service:election_archive (fun (uuid, ()) () ->
  let uuid_s = Uuidm.to_string uuid in
  lwt w = find_election uuid_s in
935
  lwt metadata = Web_persist.get_election_metadata uuid_s in
936
  lwt site_user = Web_state.get_site_user () in
Stephane Glondu's avatar
Stephane Glondu committed
937 938
  let module W = (val w) in
  match site_user with
939
  | Some u when metadata.e_owner = Some u ->
Stephane Glondu's avatar
Stephane Glondu committed
940 941 942 943 944
     archive_election uuid_s >>
     Redirection.send (Eliom_service.preapply election_admin (uuid, ()))
  | _ -> forbidden ()
)

Stephane Glondu's avatar
Stephane Glondu committed
945 946 947 948 949
let () =
  Any.register
    ~service:election_update_credential
    (fun (uuid, ()) () ->
     let uuid_s = Uuidm.to_string uuid in
950
     lwt w = find_election uuid_s in
951
     lwt metadata = Web_persist.get_election_metadata uuid_s in
952
     lwt site_user = Web_state.get_site_user () in
953
     let module W = (val w) in
954 955
     match site_user with
     | Some u ->
956
        if metadata.e_owner = Some u then (
957
          T.update_credential (module W) () >>= Html5.send