Commit f41718ae authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Make election state persistent

parent 00f86743
...@@ -16,6 +16,7 @@ Auth_password ...@@ -16,6 +16,7 @@ Auth_password
Auth_cas Auth_cas
Web_site_auth Web_site_auth
Web_templates Web_templates
Web_persist
Web_election Web_election
Web_site Web_site
Web_main Web_main
...@@ -127,13 +127,14 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct ...@@ -127,13 +127,14 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
Ocsipersist.add cred_table cred None Ocsipersist.add cred_table cred None
let do_cast rawballot (user, date) = let do_cast rawballot (user, date) =
lwt state = Web_persist.get_election_state uuid in
let voting_open = let voting_open =
let compare a b = let compare a b =
match a, b with match a, b with
| Some a, Some b -> datetime_compare a b | Some a, Some b -> datetime_compare a b
| _, _ -> -1 | _, _ -> -1
in in
!state = `Open && state = `Open &&
compare metadata.e_voting_starts_at (Some date) <= 0 && compare metadata.e_voting_starts_at (Some date) <= 0 &&
compare (Some date) metadata.e_voting_ends_at < 0 compare (Some date) metadata.e_voting_ends_at < 0
in in
...@@ -322,7 +323,9 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct ...@@ -322,7 +323,9 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
| Some result -> | Some result ->
Eliom_reference.unset cast_confirmed >> Eliom_reference.unset cast_confirmed >>
T.cast_confirmed (module W) ~result () >>= Html5.send T.cast_confirmed (module W) ~result () >>= Html5.send
| None -> T.election_home (module W) () >>= Html5.send | None ->
lwt state = Web_persist.get_election_state uuid in
T.election_home (module W) state () >>= Html5.send
) )
) )
...@@ -330,7 +333,8 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct ...@@ -330,7 +333,8 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
(fun () () -> (fun () () ->
match site_user with match site_user with
| Some u when W.metadata.e_owner = Some u -> | Some u when W.metadata.e_owner = Some u ->
T.election_admin (module W) ~is_featured () >>= Html5.send lwt state = Web_persist.get_election_state uuid in
T.election_admin (module W) ~is_featured state () >>= Html5.send
| _ -> forbidden () | _ -> forbidden ()
) )
......
open Lwt
let election_states = Ocsipersist.open_table "election_states"
let get_election_state x =
try_lwt Ocsipersist.find election_states x
with Not_found -> return `Open
let set_election_state x s =
Ocsipersist.add election_states x s
val get_election_state : string -> [ `Open | `Closed ] Lwt.t
val set_election_state : string -> [ `Open | `Closed ] -> unit Lwt.t
...@@ -120,7 +120,6 @@ end ...@@ -120,7 +120,6 @@ end
module type WEB_PARAMS = sig module type WEB_PARAMS = sig
val metadata : metadata val metadata : metadata
val dir : string val dir : string
val state : [ `Open | `Closed ] ref
end end
module type WEB_ELECTION_ = sig module type WEB_ELECTION_ = sig
......
...@@ -770,7 +770,8 @@ let () = ...@@ -770,7 +770,8 @@ let () =
let module W = (val w : WEB_ELECTION) in let module W = (val w : WEB_ELECTION) in
match_lwt get_user () with match_lwt get_user () with
| Some u when W.metadata.e_owner = Some u -> | Some u when W.metadata.e_owner = Some u ->
W.state := if state then `Open else `Closed; let state = if state then `Open else `Closed in
Web_persist.set_election_state uuid_s state >>
Redirection.send (preapply election_admin (uuid, ())) Redirection.send (preapply election_admin (uuid, ()))
| _ -> forbidden ()) | _ -> forbidden ())
......
...@@ -613,7 +613,7 @@ let make_login_box style auth links = ...@@ -613,7 +613,7 @@ let make_login_box style auth links =
election_dir election_dir
(W.election.e_params.e_uuid, x) (W.election.e_params.e_uuid, x)
let election_home w () = let election_home w state () =
let module W = (val w : WEB_ELECTION_) in let module W = (val w : WEB_ELECTION_) in
lwt user = W.S.get_user () in lwt user = W.S.get_user () in
let params = W.election.e_params and m = W.metadata in let params = W.election.e_params and m = W.metadata in
...@@ -672,7 +672,7 @@ let make_login_box style auth links = ...@@ -672,7 +672,7 @@ let make_login_box style auth links =
] ]
in in
let state = let state =
if !W.state = `Closed then if state = `Closed then
[ [
pcdata " "; pcdata " ";
b [pcdata "This election is currently closed."]; b [pcdata "This election is currently closed."];
...@@ -738,7 +738,7 @@ let make_login_box style auth links = ...@@ -738,7 +738,7 @@ let make_login_box style auth links =
lwt login_box = election_login_box w () in lwt login_box = election_login_box w () in
base ~title:params.e_name ~login_box ~content ~footer () base ~title:params.e_name ~login_box ~content ~footer ()
let election_admin w ~is_featured () = let election_admin w ~is_featured state () =
let module W = (val w : WEB_ELECTION_) in let module W = (val w : WEB_ELECTION_) in
let title = W.election.e_params.e_name ^ " — Administration" in let title = W.election.e_params.e_name ^ " — Administration" in
let feature_form = post_form ~service:election_set_featured let feature_form = post_form ~service:election_set_featured
...@@ -749,7 +749,7 @@ let make_login_box style auth links = ...@@ -749,7 +749,7 @@ let make_login_box style auth links =
]) (W.election.e_params.e_uuid, ()) ]) (W.election.e_params.e_uuid, ())
in in
let state_form = let state_form =
let checked = !W.state = `Open in let checked = state = `Open in
post_form post_form
~service:election_set_state ~service:election_set_state
(fun name -> (fun name ->
......
...@@ -35,8 +35,8 @@ val election_setup_questions : Uuidm.t -> Web_common.setup_election -> unit -> [ ...@@ -35,8 +35,8 @@ val election_setup_questions : Uuidm.t -> Web_common.setup_election -> unit -> [
val election_setup_credentials : string -> string -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val election_setup_credentials : string -> string -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_trustee : string -> string -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val election_setup_trustee : string -> string -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_home : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val election_home : (module WEB_ELECTION_) -> [ `Open | `Closed ] -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_admin : (module WEB_ELECTION_) -> is_featured:bool -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val election_admin : (module WEB_ELECTION_) -> is_featured:bool -> [ `Open | `Closed ] -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val update_credential : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val update_credential : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val cast_raw : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val cast_raw : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val cast_confirmation : (module WEB_ELECTION_) -> can_vote:bool -> string -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val cast_confirmation : (module WEB_ELECTION_) -> can_vote:bool -> string -> 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