Commit a1108783 authored by Stephane Glondu's avatar Stephane Glondu

Import voters from another election

parent 1bd9573a
......@@ -112,3 +112,10 @@ let get_elections_by_owner user =
| Some m -> return (m.e_owner = Some user)
| None -> return false
) |> Lwt_stream.to_list
let get_voters uuid =
try_lwt
let lines = Lwt_io.lines_of_file (!spool_dir / uuid / "voters.txt") in
lwt lines = Lwt_stream.to_list lines in
return @@ Some lines
with _ -> return_none
......@@ -45,3 +45,5 @@ val get_election_metadata : string -> metadata option Lwt.t
val get_election_result : string -> Yojson.Safe.json result option Lwt.t
val get_elections_by_owner : user -> string list Lwt.t
val get_voters : string -> string list option Lwt.t
......@@ -62,6 +62,9 @@ let election_setup_auth = post_coservice ~fallback:election_setup ~post_params:(
let election_setup_auth_cas = post_coservice ~fallback:election_setup ~post_params:(string "server") ()
let election_setup_auth_genpwd = post_coservice ~fallback:election_setup ~post_params:unit ()
let election_setup_import = service ~path:["setup"; "import"] ~get_params:(uuid "uuid") ()
let election_setup_import_post = post_coservice ~fallback:election_setup_import ~post_params:(uuid "from") ()
let election_home = service ~path:["elections"] ~get_params:(suffix (uuid "uuid" ** suffix_const "")) ()
let election_admin = service ~path:["elections"] ~get_params:(suffix (uuid "uuid" ** suffix_const "admin")) ()
let election_regenpwd = service ~path:["elections"] ~get_params:(suffix (uuid "uuid" ** suffix_const "regenpwd")) ()
......
......@@ -250,6 +250,25 @@ let () = Any.register ~service:home
T.home () >>= Html5.send
)
let get_finalized_elections_by_owner u =
lwt elections, tallied =
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
let elections, tallied = accu in
match state with
| `Tallied _ -> return (elections, (date, w) :: tallied)
| _ -> return ((date, w) :: elections, tallied)
) ([], [])
in
let sort l =
List.sort (fun (x, _) (y, _) -> datetime_compare x y) l |>
List.map (fun (_, x) -> x)
in
return (sort elections, sort tallied)
let () = Html5.register ~service:admin
(fun () () ->
let cont () = Redirection.send admin in
......@@ -259,29 +278,14 @@ let () = Html5.register ~service:admin
match site_user with
| None -> return None
| Some u ->
lwt elections, tallied =
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
let elections, tallied = accu in
match state with
| `Tallied _ -> return (elections, (date, w) :: tallied)
| _ -> return ((date, w) :: elections, tallied)
) ([], [])
and setup_elections =
lwt elections, tallied = get_finalized_elections_by_owner u in
lwt setup_elections =
Ocsipersist.fold_step (fun k v accu ->
if v.se_owner = u
then return ((uuid_of_string k, v.se_questions.t_name) :: accu)
else return accu
) election_stable []
in
let sort l =
List.sort (fun (x, _) (y, _) -> datetime_compare x y) l |>
List.map (fun (_, x) -> x)
in
let elections = sort elections and tallied = sort tallied in
return @@ Some (elections, tallied, setup_elections)
in
T.admin ~elections ()
......@@ -1035,6 +1039,40 @@ let () =
end
)
let () =
Html5.register
~service:election_setup_import
(fun uuid () ->
lwt site_user = Web_auth_state.get_site_user () in
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
match voters with
| Some voters ->
if se.se_public_creds_received then forbidden () else (
se.se_voters <- se.se_voters @ List.map (fun sv_id ->
{sv_id; sv_password = None}
) voters;
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)))
let () =
Any.register
~service:election_home
......
......@@ -665,7 +665,13 @@ let election_setup_voters uuid se () =
];
]
in
let div_import = div [
a ~service:election_setup_import
[pcdata "Import voters from another election"]
uuid
] in
let content = [
div_import;
voters;
back;
div_add;
......@@ -801,6 +807,41 @@ let election_setup_trustee token se () =
let login_box = pcdata "" in
base ~title ~login_box ~content ()
let election_setup_import uuid se (elections, tallied) () =
let title = "Election " ^ se.se_questions.t_name ^ " — Import voters from another election" in
let format_election election =
let module W = (val election : WEB_ELECTION_DATA) in
let name = W.election.e_params.e_name in
let uuid_s = Uuidm.to_string W.election.e_params.e_uuid in
let form = post_form
~service:election_setup_import_post
(fun from ->
[
div [pcdata name; pcdata " ("; pcdata uuid_s; pcdata ")"];
div [
user_type_input Uuidm.to_string
~input_type:`Hidden
~name:from
~value:W.election.e_params.e_uuid ();
string_input ~input_type:`Submit ~value:"Import from this election" ();
]
]
) uuid
in
li [form]
in
let itemize xs = match xs with
| [] -> p [pcdata "You own no such elections!"]
| _ -> ul @@ List.map format_election xs
in
let content = [
h2 [pcdata "Elections you can administer"];
itemize elections;
h2 [pcdata "Tallied elections"];
itemize tallied;
] in
lwt login_box = site_login_box () in
base ~title ~login_box ~content ()
let election_login_box w =
let module W = (val w : WEB_ELECTION_DATA) in
......
......@@ -36,6 +36,7 @@ val election_setup_credential_authority : Uuidm.t -> Web_common.setup_election -
val election_setup_credentials : string -> string -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_trustees : Uuidm.t -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_trustee : string -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_import : Uuidm.t -> Web_common.setup_election -> (module WEB_ELECTION_DATA) list * (module WEB_ELECTION_DATA) list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_home : (module WEB_ELECTION_DATA) -> Web_persist.election_state -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_admin : (module WEB_ELECTION_DATA) -> Web_persist.election_state -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment