Commit 91291545 authored by Stephane Glondu's avatar Stephane Glondu

The user must give a release date when she hides the result

parent 7700cecd
Pipeline #78512 passed with stages
in 18 minutes and 11 seconds
......@@ -433,3 +433,4 @@ let days_to_archive = 7
let days_to_delete = 365
let days_to_mail = 30
let days_between_mails = 7
let days_to_publish_result = 7
......@@ -166,3 +166,4 @@ val days_to_archive : int
val days_to_delete : int
val days_to_mail : int
val days_between_mails : int
val days_to_publish_result : int
......@@ -44,16 +44,25 @@ let get_election_result uuid =
| Some [x] -> return (Some (election_result_of_string Yojson.Safe.read_json x))
| _ -> return_none
let get_election_result_hidden uuid =
Lwt_unix.file_exists (!Web_config.spool_dir / raw_string_of_uuid uuid / "hide_result")
let set_election_result_hidden uuid hidden =
if hidden then (
write_file ~uuid "hide_result" []
) else (
try%lwt Lwt_unix.unlink (!Web_config.spool_dir / raw_string_of_uuid uuid / "hide_result")
with _ -> return_unit
)
match hidden with
| None ->
(
try%lwt Lwt_unix.unlink (!Web_config.spool_dir / raw_string_of_uuid uuid / "hide_result")
with _ -> return_unit
)
| Some d -> write_file ~uuid "hide_result" [string_of_datetime d]
let get_election_result_hidden uuid =
match%lwt read_file ~uuid "hide_result" with
| Some [x] ->
let t = datetime_of_string x in
if datetime_compare (now ()) t < 0 then
return (Some t)
else
let%lwt () = set_election_result_hidden uuid None in
return_none
| _ -> return_none
type election_date =
[ `Creation
......
......@@ -59,8 +59,8 @@ val get_raw_election : uuid -> string option Lwt.t
val get_election_metadata : uuid -> metadata Lwt.t
val get_election_result : uuid -> Yojson.Safe.json election_result option Lwt.t
val get_election_result_hidden : uuid -> bool Lwt.t
val set_election_result_hidden : uuid -> bool -> unit Lwt.t
val get_election_result_hidden : uuid -> datetime option Lwt.t
val set_election_result_hidden : uuid -> datetime option -> unit Lwt.t
type election_kind =
[ `Draft
......
......@@ -83,7 +83,7 @@ let election_regenpwd_post = create_attached_post ~fallback:election_regenpwd ~p
let election_login = create ~path:(Path ["elections"]) ~meth:(Get (suffix_prod (uuid "uuid" ** suffix_const "login") (opt (string "service")))) ()
let election_open = create_attached_post ~fallback:election_admin ~post_params:unit ()
let election_close = create_attached_post ~fallback:election_admin ~post_params:unit ()
let election_hide_result = create_attached_post ~fallback:election_admin ~post_params:unit ()
let election_hide_result = create_attached_post ~fallback:election_admin ~post_params:(string "date") ()
let election_show_result = create_attached_post ~fallback:election_admin ~post_params:unit ()
let election_auto_post = create_attached_post ~fallback:election_admin ~post_params:(string "open" ** string "close") ()
let election_archive = create_attached_post ~fallback:election_admin ~post_params:unit ()
......
......@@ -1277,17 +1277,42 @@ let election_set_state state uuid () =
let () = Any.register ~service:election_open (election_set_state true)
let () = Any.register ~service:election_close (election_set_state false)
let election_set_result_hidden hidden uuid () =
let election_set_result_hidden f uuid x =
with_site_user (fun u ->
let%lwt metadata = Web_persist.get_election_metadata uuid in
if metadata.e_owner = Some u then (
let%lwt () = Web_persist.set_election_result_hidden uuid hidden in
redir_preapply election_admin uuid ()
try%lwt
let%lwt () = Web_persist.set_election_result_hidden uuid (f x) in
redir_preapply election_admin uuid ()
with
| Failure msg ->
let service = preapply election_admin uuid in
T.generic_page ~title:"Error" ~service msg () >>= Html.send
) else forbidden ()
)
let () = Any.register ~service:election_hide_result (election_set_result_hidden true)
let () = Any.register ~service:election_show_result (election_set_result_hidden false)
let parse_datetime_from_post x =
try datetime_of_string ("\"" ^ x ^ ".000000\"")
with _ -> Printf.ksprintf failwith "%s is not a valid date!" x
let () =
Any.register ~service:election_hide_result
(election_set_result_hidden
(fun x ->
let t = parse_datetime_from_post x in
let max = datetime_add (now ()) (day days_to_publish_result) in
if datetime_compare t max > 0 then
Printf.ksprintf failwith
"The date must be less than %d days in the future!"
days_to_publish_result
else
Some t
)
)
let () =
Any.register ~service:election_show_result
(election_set_result_hidden (fun () -> None))
let () =
Any.register ~service:election_auto_post
......@@ -1299,10 +1324,7 @@ let () =
try
let format x =
if x = "" then None
else Some (
try datetime_of_string ("\"" ^ x ^ ".000000\"")
with _ -> Printf.ksprintf failwith "%s is not a valid date!" x
)
else Some (parse_datetime_from_post x)
in
let auto_open = format auto_open in
let auto_close = format auto_close in
......@@ -1834,7 +1856,10 @@ let handle_pseudo_file uuid f site_user =
match f with
| ESRaw | ESKeys | ESTParams | ESBallots | ESETally | ESCreds -> return false
| ESRecords | ESVoters -> return true
| ESResult -> Web_persist.get_election_result_hidden uuid
| ESResult ->
match%lwt Web_persist.get_election_result_hidden uuid with
| None -> return false
| Some _ -> return true
in
let%lwt () =
if confidential then (
......
......@@ -1754,7 +1754,7 @@ let election_home election state () =
return (metadata.e_owner = site_user)
in
match result with
| Some r when not hidden || is_admin ->
| Some r when hidden = None || is_admin ->
let result = r.result in
let questions = Array.to_list election.e_params.e_questions in
return @@ div [
......@@ -1793,9 +1793,16 @@ let election_home election state () =
];
]
| Some _ ->
let t =
match hidden with
| Some t -> t
| None -> failwith "Impossible case in election_admin"
in
return @@
div [
pcdata "The result for this election is currently not publicly available.";
pcdata "The result of this election is currently not publicly available. It will be in ";
pcdata (format_period l (datetime_sub t now));
pcdata ".";
]
| None -> return go_to_the_booth
in
......@@ -2039,16 +2046,28 @@ let election_admin election metadata state get_tokens_decrypt () =
| `Tallied ->
let%lwt hidden = Web_persist.get_election_result_hidden uuid in
let form_toggle =
if hidden then
post_form ~service:election_show_result
(fun () ->
[input ~input_type:`Submit ~value:"Publish the result" string]
) uuid
else
post_form ~service:election_hide_result
(fun () ->
[input ~input_type:`Submit ~value:"Hide the result" string]
) uuid
match hidden with
| Some _ ->
post_form ~service:election_show_result
(fun () ->
[input ~input_type:`Submit ~value:"Publish the result now" string]
) uuid
| None ->
post_form ~service:election_hide_result
(fun date ->
[
div [
input ~input_type:`Submit ~value:"Hide the result until" string;
pcdata " ";
input ~name:date ~input_type:`Text string;
];
div [
pcdata "Enter the date in UTC, in format YYYY-MM-DD HH:MM:SS. For example, now is ";
pcdata (String.sub (string_of_datetime (now ())) 1 19);
pcdata ".";
];
]
) uuid
in
return @@ div [
pcdata "This election has been tallied.";
......
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