Commit 010c6a65 authored by Stephane Glondu's avatar Stephane Glondu

Do no longer rely on Ocsipersist for draft elections

parent 72f1ebf2
...@@ -291,6 +291,10 @@ let write_file ?uuid x lines = ...@@ -291,6 +291,10 @@ let write_file ?uuid x lines =
) )
) >> Lwt_unix.rename fname_new fname ) >> Lwt_unix.rename fname_new fname
let cleanup_file f =
try%lwt Lwt_unix.unlink f
with _ -> return_unit
let rmdir dir = let rmdir dir =
let command = "rm", [| "rm"; "-rf"; dir |] in let command = "rm", [| "rm"; "-rf"; dir |] in
let%lwt _ = Lwt_process.exec command in let%lwt _ = Lwt_process.exec command in
......
...@@ -109,6 +109,8 @@ val extract_email : string -> string option ...@@ -109,6 +109,8 @@ val extract_email : string -> string option
val file_exists : string -> bool Lwt.t val file_exists : string -> bool Lwt.t
val read_file : ?uuid:uuid -> string -> string list option Lwt.t val read_file : ?uuid:uuid -> string -> string list option Lwt.t
val write_file : ?uuid:uuid -> string -> string list -> unit Lwt.t val write_file : ?uuid:uuid -> string -> string list -> unit Lwt.t
val cleanup_file : string -> unit Lwt.t
val rmdir : string -> unit Lwt.t val rmdir : string -> unit Lwt.t
val compile_auth_config : auth_config -> string * (string * string list) val compile_auth_config : auth_config -> string * (string * string list)
......
...@@ -21,6 +21,7 @@ ...@@ -21,6 +21,7 @@
open Lwt open Lwt
open Platform open Platform
open Signatures
open Serializable_builtin_t open Serializable_builtin_t
open Serializable_j open Serializable_j
open Common open Common
...@@ -29,6 +30,14 @@ open Web_common ...@@ -29,6 +30,14 @@ open Web_common
let ( / ) = Filename.concat let ( / ) = Filename.concat
let get_draft_election uuid =
match%lwt read_file ~uuid "draft.json" with
| Some [x] -> return @@ Some (draft_election_of_string x)
| _ -> return_none
let set_draft_election uuid se =
write_file ~uuid "draft.json" [string_of_draft_election se]
let get_election_result uuid = let get_election_result uuid =
match%lwt read_file ~uuid "result.json" with match%lwt read_file ~uuid "result.json" with
| Some [x] -> return (Some (result_of_string Yojson.Safe.read_json x)) | Some [x] -> return (Some (result_of_string Yojson.Safe.read_json x))
...@@ -125,23 +134,61 @@ let get_auth_config uuid = ...@@ -125,23 +134,61 @@ let get_auth_config uuid =
| None -> return [] | None -> return []
| Some x -> return (List.map compile_auth_config x) | Some x -> return (List.map compile_auth_config x)
type election_kind =
[ `Draft
| `Validated
| `Tallied
| `Archived
]
let get_elections_by_owner user = let get_elections_by_owner user =
Lwt_unix.files_of_directory !spool_dir |> Lwt_unix.files_of_directory !spool_dir |>
Lwt_stream.filter_map_s Lwt_stream.to_list >>=
Lwt_list.filter_map_p
(fun x -> (fun x ->
if x = "." || x = ".." then if x = "." || x = ".." then
return None return None
else ( else (
try try
let uuid = uuid_of_raw_string x in let uuid = uuid_of_raw_string x in
let%lwt metadata = get_election_metadata uuid in match%lwt get_draft_election uuid with
match metadata.e_owner with | None ->
| Some o when o = user -> return (Some uuid) (
| _ -> return None let%lwt metadata = get_election_metadata uuid in
match metadata.e_owner with
| Some o when o = user ->
(
match%lwt get_raw_election uuid with
| None -> return_none
| Some election ->
let election = Election.of_string election in
let%lwt kind, date =
match%lwt get_election_state uuid with
| `Open | `Closed | `EncryptedTally _ ->
let%lwt date = get_election_date `Validation uuid in
let date = Option.get date default_validation_date in
return (`Validated, date)
| `Tallied ->
let%lwt date = get_election_date `Tally uuid in
let date = Option.get date default_tally_date in
return (`Tallied, date)
| `Archived ->
let%lwt date = get_election_date `Archive uuid in
let date = Option.get date default_archive_date in
return (`Archived, date)
in
return @@ Some (kind, uuid, date, election.e_params.e_name)
)
| _ -> return_none
)
| Some se ->
if se.se_owner = user then
let date = Option.get se.se_creation_date default_creation_date in
return @@ Some (`Draft, uuid, date, se.se_questions.t_name)
else return_none
with _ -> return None with _ -> return None
) )
) |> )
Lwt_stream.to_list
let get_voters uuid = let get_voters uuid =
read_file ~uuid "voters.txt" read_file ~uuid "voters.txt"
......
...@@ -23,6 +23,9 @@ open Serializable_t ...@@ -23,6 +23,9 @@ open Serializable_t
open Common open Common
open Web_serializable_t open Web_serializable_t
val get_draft_election : uuid -> draft_election option Lwt.t
val set_draft_election : uuid -> draft_election -> unit Lwt.t
val get_election_state : uuid -> election_state Lwt.t val get_election_state : uuid -> election_state Lwt.t
val set_election_state : uuid -> election_state -> unit Lwt.t val set_election_state : uuid -> election_state -> unit Lwt.t
...@@ -45,7 +48,13 @@ val get_raw_election : uuid -> string option Lwt.t ...@@ -45,7 +48,13 @@ val get_raw_election : uuid -> string option Lwt.t
val get_election_metadata : uuid -> metadata Lwt.t val get_election_metadata : uuid -> metadata Lwt.t
val get_election_result : uuid -> Yojson.Safe.json result option Lwt.t val get_election_result : uuid -> Yojson.Safe.json result option Lwt.t
val get_elections_by_owner : user -> uuid list Lwt.t type election_kind =
[ `Draft
| `Validated
| `Tallied
| `Archived
]
val get_elections_by_owner : user -> (election_kind * uuid * datetime * string) list Lwt.t
val get_voters : uuid -> string list option Lwt.t val get_voters : uuid -> string list option Lwt.t
val get_passwords : uuid -> (string * string) SMap.t option Lwt.t val get_passwords : uuid -> (string * string) SMap.t option Lwt.t
......
...@@ -42,9 +42,6 @@ module PString = String ...@@ -42,9 +42,6 @@ module PString = String
open Eliom_service open Eliom_service
open Eliom_registration open Eliom_registration
(* Table with draft elections. *)
let election_stable = Ocsipersist.open_table "site_setup"
(* Table with tokens given to trustees (in threshold mode) to decrypt *) (* Table with tokens given to trustees (in threshold mode) to decrypt *)
let election_tokens_decrypt = Ocsipersist.open_table "site_tokens_decrypt" let election_tokens_decrypt = Ocsipersist.open_table "site_tokens_decrypt"
...@@ -68,13 +65,6 @@ let find_election = ...@@ -68,13 +65,6 @@ let find_election =
let cache = new WCache.cache raw_find_election ~timer:3600. 100 in let cache = new WCache.cache raw_find_election ~timer:3600. 100 in
fun x -> cache#find x fun x -> cache#find x
let get_draft_election uuid =
let%lwt se = Ocsipersist.find election_stable (raw_string_of_uuid uuid) in
return (draft_election_of_string se)
let set_draft_election uuid se =
Ocsipersist.add election_stable (raw_string_of_uuid uuid) (string_of_draft_election se)
let dump_passwords uuid db = let dump_passwords uuid db =
List.map (fun line -> PString.concat "," line) db |> List.map (fun line -> PString.concat "," line) db |>
write_file ~uuid "passwords.csv" write_file ~uuid "passwords.csv"
...@@ -187,7 +177,6 @@ let validate_election uuid se = ...@@ -187,7 +177,6 @@ let validate_election uuid se =
Lwt_io.write oc (what v) >> Lwt_io.write oc (what v) >>
Lwt_io.write oc "\n") xs) Lwt_io.write oc "\n") xs)
in in
Lwt_unix.mkdir dir 0o700 >>
(match pk_or_tp with (match pk_or_tp with
| `PK pk -> create_file "public_keys.jsons" (string_of_trustee_public_key G.write) pk | `PK pk -> create_file "public_keys.jsons" (string_of_trustee_public_key G.write) pk
| `TP tp -> create_file "threshold.json" (string_of_threshold_parameters G.write) [tp] | `TP tp -> create_file "threshold.json" (string_of_threshold_parameters G.write) [tp]
...@@ -202,7 +191,7 @@ let validate_election uuid se = ...@@ -202,7 +191,7 @@ let validate_election uuid se =
let module B = Web_election.Make (E) in let module B = Web_election.Make (E) in
(* initialize credentials *) (* initialize credentials *)
let%lwt () = let%lwt () =
let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in let fname = !spool_dir / uuid_s / "public_creds.txt" in
match%lwt read_file fname with match%lwt read_file fname with
| Some xs -> | Some xs ->
Web_persist.init_credential_mapping uuid xs >> Web_persist.init_credential_mapping uuid xs >>
...@@ -216,8 +205,8 @@ let validate_election uuid se = ...@@ -216,8 +205,8 @@ let validate_election uuid se =
| `KEY x -> create_file "private_key.json" string_of_number [x] | `KEY x -> create_file "private_key.json" string_of_number [x]
| `KEYS x -> create_file "private_keys.jsons" (fun x -> x) x | `KEYS x -> create_file "private_keys.jsons" (fun x -> x) x
in in
(* clean up draft database *) (* clean up draft *)
Ocsipersist.remove election_stable uuid_s >> cleanup_file (!spool_dir / uuid_s / "draft.json") >>
(* write passwords *) (* write passwords *)
(match metadata.e_auth_config with (match metadata.e_auth_config with
| Some [{auth_system = "password"; _}] -> | Some [{auth_system = "password"; _}] ->
...@@ -245,10 +234,6 @@ let cleanup_table ?uuid_s table = ...@@ -245,10 +234,6 @@ let cleanup_table ?uuid_s table =
Lwt_list.iter_s (Ocsipersist.remove table) indexes Lwt_list.iter_s (Ocsipersist.remove table) indexes
| Some u -> Ocsipersist.remove table u | Some u -> Ocsipersist.remove table u
let cleanup_file f =
try%lwt Lwt_unix.unlink f
with _ -> return_unit
let delete_sensitive_data uuid = let delete_sensitive_data uuid =
let uuid_s = raw_string_of_uuid uuid in let uuid_s = raw_string_of_uuid uuid in
let%lwt () = cleanup_file (!spool_dir / uuid_s / "state.json") in let%lwt () = cleanup_file (!spool_dir / uuid_s / "state.json") in
...@@ -371,29 +356,21 @@ let () = Any.register ~service:home ...@@ -371,29 +356,21 @@ let () = Any.register ~service:home
Redirection.send admin Redirection.send admin
) )
let get_validated_elections_by_owner u = let get_elections_by_owner_sorted u =
let%lwt elections, tallied, archived = let%lwt elections = Web_persist.get_elections_by_owner u in
Web_persist.get_elections_by_owner u >>= let filter kind =
Lwt_list.fold_left_s (fun accu uuid -> List.filter (fun (x, _, _, _) -> x = kind) elections |>
let%lwt w = find_election uuid in List.map (fun (_, a, b, c) -> a, b, c)
let%lwt state = Web_persist.get_election_state uuid in
let%lwt date = Web_persist.get_election_date `Validation uuid in
let date = match date with
| None -> default_validation_date
| Some x -> x
in
let elections, tallied, archived = accu in
match state with
| `Tallied -> return (elections, (date, w) :: tallied, archived)
| `Archived -> return (elections, tallied, (date, w) :: archived)
| _ -> return ((date, w) :: elections, tallied, archived)
) ([], [], [])
in in
let draft = filter `Draft in
let elections = filter `Validated in
let tallied = filter `Tallied in
let archived = filter `Archived in
let sort l = let sort l =
List.sort (fun (x, _) (y, _) -> datetime_compare x y) l |> List.sort (fun (_, x, _) (_, y, _) -> datetime_compare x y) l |>
List.map (fun (_, x) -> x) List.map (fun (x, _, y) -> x, y)
in in
return (sort elections, sort tallied, sort archived) return (sort draft, sort elections, sort tallied, sort archived)
let with_site_user f = let with_site_user f =
match%lwt Web_state.get_site_user () with match%lwt Web_state.get_site_user () with
...@@ -418,16 +395,8 @@ let () = Html5.register ~service:admin ...@@ -418,16 +395,8 @@ let () = Html5.register ~service:admin
match site_user with match site_user with
| None -> return None | None -> return None
| Some u -> | Some u ->
let%lwt elections, tallied, archived = get_validated_elections_by_owner u in let%lwt elections = get_elections_by_owner_sorted u in
let%lwt draft_elections = return @@ Some elections
Ocsipersist.fold_step (fun k v accu ->
let v = draft_election_of_string v in
if v.se_owner = u then
return ((uuid_of_raw_string k, v.se_questions.t_name) :: accu)
else return accu
) election_stable []
in
return @@ Some (elections, tallied, archived, draft_elections)
in in
T.admin ~elections () T.admin ~elections ()
) )
...@@ -488,7 +457,8 @@ let create_new_election owner cred auth = ...@@ -488,7 +457,8 @@ let create_new_election owner cred auth =
se_threshold_error = None; se_threshold_error = None;
se_creation_date = Some (now ()); se_creation_date = Some (now ());
} in } in
let%lwt () = set_draft_election uuid se in let%lwt () = Lwt_unix.mkdir (!spool_dir / raw_string_of_uuid uuid) 0o700 in
let%lwt () = Web_persist.set_draft_election uuid se in
redir_preapply election_draft uuid () redir_preapply election_draft uuid ()
let () = Html5.register ~service:election_draft_pre let () = Html5.register ~service:election_draft_pre
...@@ -514,10 +484,9 @@ let () = Any.register ~service:election_draft_new ...@@ -514,10 +484,9 @@ let () = Any.register ~service:election_draft_new
let with_draft_election_ro uuid f = let with_draft_election_ro uuid f =
with_site_user (fun u -> with_site_user (fun u ->
let%lwt se = get_draft_election uuid in match%lwt Web_persist.get_draft_election uuid with
if se.se_owner = u then | None -> fail_http 404
f se | Some se -> if se.se_owner = u then f se else forbidden ()
else forbidden ()
) )
let () = let () =
...@@ -559,11 +528,13 @@ let election_draft_mutex = Lwt_mutex.create () ...@@ -559,11 +528,13 @@ let election_draft_mutex = Lwt_mutex.create ()
let with_draft_election ?(save = true) uuid f = let with_draft_election ?(save = true) uuid f =
with_site_user (fun u -> with_site_user (fun u ->
Lwt_mutex.with_lock election_draft_mutex (fun () -> Lwt_mutex.with_lock election_draft_mutex (fun () ->
let%lwt se = get_draft_election uuid in match%lwt Web_persist.get_draft_election uuid with
| None -> fail_http 404
| Some se ->
if se.se_owner = u then ( if se.se_owner = u then (
try%lwt try%lwt
let%lwt r = f se in let%lwt r = f se in
let%lwt () = if save then set_draft_election uuid se else return_unit in let%lwt () = if save then Web_persist.set_draft_election uuid se else return_unit in
return r return r
with e -> with e ->
let service = preapply election_draft uuid in let service = preapply election_draft uuid in
...@@ -881,8 +852,9 @@ let () = ...@@ -881,8 +852,9 @@ let () =
let () = let () =
Html5.register ~service:election_draft_credentials Html5.register ~service:election_draft_credentials
(fun (uuid, token) () -> (fun (uuid, token) () ->
let%lwt se = get_draft_election uuid in match%lwt Web_persist.get_draft_election uuid with
T.election_draft_credentials token uuid se () | None -> fail_http 404
| Some se -> T.election_draft_credentials token uuid se ()
) )
let wrap_handler f = let wrap_handler f =
...@@ -891,11 +863,13 @@ let wrap_handler f = ...@@ -891,11 +863,13 @@ let wrap_handler f =
| e -> T.generic_page ~title:"Error" (Printexc.to_string e) () >>= Html5.send | e -> T.generic_page ~title:"Error" (Printexc.to_string e) () >>= Html5.send
let handle_credentials_post uuid token creds = let handle_credentials_post uuid token creds =
let%lwt se = get_draft_election uuid in match%lwt Web_persist.get_draft_election uuid with
| None -> fail_http 404
| Some se ->
if se.se_public_creds <> token then forbidden () else if se.se_public_creds <> token then forbidden () else
if se.se_public_creds_received then forbidden () else if se.se_public_creds_received then forbidden () else
let module G = (val Group.of_string se.se_group : GROUP) in let module G = (val Group.of_string se.se_group : GROUP) in
let fname = !spool_dir / raw_string_of_uuid uuid ^ ".public_creds.txt" in let fname = !spool_dir / raw_string_of_uuid uuid / "public_creds.txt" in
Lwt_mutex.with_lock Lwt_mutex.with_lock
election_draft_mutex election_draft_mutex
(fun () -> (fun () ->
...@@ -922,7 +896,7 @@ let handle_credentials_post uuid token creds = ...@@ -922,7 +896,7 @@ let handle_credentials_post uuid token creds =
in in
let () = se.se_metadata <- {se.se_metadata with e_cred_authority = None} in let () = se.se_metadata <- {se.se_metadata with e_cred_authority = None} in
let () = se.se_public_creds_received <- true in let () = se.se_public_creds_received <- true in
set_draft_election uuid se >> Web_persist.set_draft_election uuid se >>
T.generic_page ~title:"Success" T.generic_page ~title:"Success"
"Credentials have been received and checked!" () >>= Html5.send "Credentials have been received and checked!" () >>= Html5.send
...@@ -995,7 +969,7 @@ let () = ...@@ -995,7 +969,7 @@ let () =
) SSet.empty se.se_voters ) SSet.empty se.se_voters
in in
let creds = SSet.elements creds in let creds = SSet.elements creds in
let fname = !spool_dir / raw_string_of_uuid uuid ^ ".public_creds.txt" in let fname = !spool_dir / raw_string_of_uuid uuid / "public_creds.txt" in
let%lwt () = let%lwt () =
Lwt_io.with_file Lwt_io.with_file
~flags:(Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC])) ~flags:(Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC]))
...@@ -1014,8 +988,9 @@ let () = ...@@ -1014,8 +988,9 @@ let () =
let () = let () =
Html5.register ~service:election_draft_trustee Html5.register ~service:election_draft_trustee
(fun (uuid, token) () -> (fun (uuid, token) () ->
let%lwt se = get_draft_election uuid in match%lwt Web_persist.get_draft_election uuid with
T.election_draft_trustee token uuid se () | None -> fail_http 404
| Some se -> T.election_draft_trustee token uuid se ()
) )
let () = let () =
...@@ -1027,7 +1002,9 @@ let () = ...@@ -1027,7 +1002,9 @@ let () =
Lwt_mutex.with_lock Lwt_mutex.with_lock
election_draft_mutex election_draft_mutex
(fun () -> (fun () ->
let%lwt se = get_draft_election uuid in match%lwt Web_persist.get_draft_election uuid with
| None -> fail_http 404
| Some se ->
let t = List.find (fun x -> token = x.st_token) se.se_public_keys in let t = List.find (fun x -> token = x.st_token) se.se_public_keys in
let module G = (val Group.of_string se.se_group : GROUP) in 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 pk = trustee_public_key_of_string G.read public_key in
...@@ -1035,7 +1012,7 @@ let () = ...@@ -1035,7 +1012,7 @@ let () =
if not (KG.check pk) then failwith "invalid public key"; if not (KG.check pk) then failwith "invalid public key";
(* we keep pk as a string because of G.t *) (* we keep pk as a string because of G.t *)
t.st_public_key <- public_key; t.st_public_key <- public_key;
set_draft_election uuid se Web_persist.set_draft_election uuid se
) >> T.generic_page ~title:"Success" ) >> T.generic_page ~title:"Success"
"Your key has been received and checked!" "Your key has been received and checked!"
() >>= Html5.send () >>= Html5.send
...@@ -1063,15 +1040,7 @@ let () = ...@@ -1063,15 +1040,7 @@ let () =
) )
let destroy_election uuid = let destroy_election uuid =
let uuid_s = raw_string_of_uuid uuid in rmdir (!spool_dir / raw_string_of_uuid uuid)
(* clean up credentials *)
let%lwt () =
let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in
try%lwt Lwt_unix.unlink fname
with _ -> return_unit
in
(* clean up draft database *)
Ocsipersist.remove election_stable uuid_s
let () = let () =
Any.register ~service:election_draft_destroy Any.register ~service:election_draft_destroy
...@@ -1085,8 +1054,8 @@ let () = ...@@ -1085,8 +1054,8 @@ let () =
Html5.register ~service:election_draft_import Html5.register ~service:election_draft_import
(fun uuid () -> (fun uuid () ->
with_draft_election_ro uuid (fun se -> with_draft_election_ro uuid (fun se ->
let%lwt elections = get_validated_elections_by_owner se.se_owner in let%lwt _, a, b, c = get_elections_by_owner_sorted se.se_owner in
T.election_draft_import uuid se elections () T.election_draft_import uuid se (a, b, c) ()
) )
) )
...@@ -1127,8 +1096,8 @@ let () = ...@@ -1127,8 +1096,8 @@ let () =
Html5.register ~service:election_draft_import_trustees Html5.register ~service:election_draft_import_trustees
(fun uuid () -> (fun uuid () ->
with_draft_election_ro uuid (fun se -> with_draft_election_ro uuid (fun se ->
let%lwt elections = get_validated_elections_by_owner se.se_owner in let%lwt _, a, b, c = get_elections_by_owner_sorted se.se_owner in
T.election_draft_import_trustees uuid se elections () T.election_draft_import_trustees uuid se (a, b, c) ()
) )
) )
...@@ -1899,8 +1868,9 @@ let () = ...@@ -1899,8 +1868,9 @@ let () =
let () = let () =
Html5.register ~service:election_draft_threshold_trustee Html5.register ~service:election_draft_threshold_trustee
(fun (uuid, token) () -> (fun (uuid, token) () ->
let%lwt se = get_draft_election uuid in match%lwt Web_persist.get_draft_election uuid with
T.election_draft_threshold_trustee token uuid se () | None -> fail_http 404
| Some se -> T.election_draft_threshold_trustee token uuid se ()
) )
let () = let () =
...@@ -1910,7 +1880,9 @@ let () = ...@@ -1910,7 +1880,9 @@ let () =
(fun () -> (fun () ->
Lwt_mutex.with_lock election_draft_mutex Lwt_mutex.with_lock election_draft_mutex
(fun () -> (fun () ->
let%lwt se = get_draft_election uuid in match%lwt Web_persist.get_draft_election uuid with
| None -> fail_http 404
| Some se ->
let ts = let ts =
match se.se_threshold_trustees with match se.se_threshold_trustees with
| None -> failwith "No threshold trustees" | None -> failwith "No threshold trustees"
...@@ -2014,12 +1986,24 @@ let () = ...@@ -2014,12 +1986,24 @@ let () =
se.se_threshold_error <- Some (Printexc.to_string e) se.se_threshold_error <- Some (Printexc.to_string e)
); return_unit ); return_unit
) else return_unit ) else return_unit
) >> set_draft_election uuid se ) >> Web_persist.set_draft_election uuid se
) >> ) >>
redir_preapply election_draft_threshold_trustee (uuid, token) () redir_preapply election_draft_threshold_trustee (uuid, token) ()
) )
) )
let extract_automatic_data_draft uuid_s =
let uuid = uuid_of_raw_string uuid_s in
match%lwt Web_persist.get_draft_election uuid with
| None -> return_none
| Some se ->