Attention une mise à jour du serveur va être effectuée le lundi 17 mai entre 13h et 13h30. Cette mise à jour va générer une interruption du service de quelques minutes.

Commit dc50001d authored by Stephane Glondu's avatar Stephane Glondu

Give names to election service handlers

parent a22d1533
......@@ -48,8 +48,8 @@ let can_vote m user =
| Some u -> check_acl (Some acl) u
module type REGISTRATION = sig
module W : WEB_ELECTION
module Register (S : SITE) (T : TEMPLATES) : EMPTY
module W : WEB_ELECTION_
module Register (S : SITE) (T : TEMPLATES) : ELECTION_HANDLERS
end
module type REGISTRABLE = sig
......@@ -337,7 +337,7 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
end
module Register (S : SITE) (T : TEMPLATES) : EMPTY = struct
module Register (S : SITE) (T : TEMPLATES) : ELECTION_HANDLERS = struct
open Eliom_registration
let () = let module X : EMPTY = Auth.Register (S) (T.Login (W.S)) in ()
......@@ -356,7 +356,7 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
let ballot = Eliom_reference.eref ~scope None
let cast_confirmed = Eliom_reference.eref ~scope None
let () = Html5.register ~service:W.S.home
let home =
(if_eligible can_read
(fun user () ->
Eliom_reference.unset ballot >>
......@@ -365,12 +365,14 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
match_lwt Eliom_reference.get cast_confirmed with
| Some result ->
Eliom_reference.unset cast_confirmed >>
T.cast_confirmed ~result ()
| None -> T.home ()
T.cast_confirmed ~result () >>= Html5.send
| None -> T.home () >>= Html5.send
)
)
let () = Html5.register ~service:W.S.admin
let () = Any.register ~service:W.S.home home
let admin =
(fun () () ->
match_lwt S.get_user () with
| Some u when W.metadata.e_owner = Some u ->
......@@ -394,10 +396,12 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
)
in
lwt is_featured = S.is_featured_election uuid in
T.admin ~set_featured ~is_featured ()
T.admin ~set_featured ~is_featured () >>= Html5.send
| _ -> forbidden ()
)
let () = Any.register ~service:W.S.admin admin
let content_type_of_file = function
| ESRaw | ESKeys | ESBallots -> "application/json"
| ESCreds | ESRecords -> "text/plain"
......@@ -413,8 +417,7 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
let content_type = content_type_of_file f in
File.send ~content_type (W.dir / string_of_election_file f)
let () = Any.register
~service:W.S.election_dir
let election_dir =
(fun f () ->
let cont () () =
Eliom_service.preapply W.S.election_dir f |>
......@@ -424,22 +427,27 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
handle_pseudo_file () f
)
let () = Html5.register
~service:W.S.election_update_credential
let () = Any.register ~service:W.S.election_dir election_dir
let election_update_credential =
(fun () () ->
lwt user = S.get_user () in
match user with
| Some u ->
if W.metadata.e_owner = Some u then (
T.update_credential ()
T.update_credential () >>= Html5.send
) else (
forbidden ()
)
| _ -> forbidden ()
)
let () = String.register
~service:W.S.election_update_credential_post
let () =
Any.register
~service:W.S.election_update_credential
election_update_credential
let election_update_credential_post =
(fun () (old, new_) ->
lwt user = S.get_user () in
match user with
......@@ -447,26 +455,33 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
if W.metadata.e_owner = Some u then (
try_lwt
W.B.update_cred ~old ~new_ >>
return ("OK", "text/plain")
String.send ("OK", "text/plain")
with Error e ->
return ("Error: " ^ explain_error e, "text/plain")
) else (
String.send ("Error: " ^ explain_error e, "text/plain")
) >>= (fun x -> return @@ cast_unknown_content_kind x)
else (
forbidden ()
)
| _ -> forbidden ()
)
let () = Redirection.register
~service:W.S.election_vote
let () =
Any.register
~service:W.S.election_update_credential_post
election_update_credential_post
let election_vote =
(if_eligible can_read
(fun user () ->
Eliom_reference.unset ballot >>
let cont () () = Redirection.send W.S.election_vote in
Eliom_reference.set S.cont cont >>
return W.S.booth
Redirection.send W.S.booth
)
)
let () = Any.register ~service:W.S.election_vote election_vote
let do_cast () () =
match_lwt Eliom_reference.get ballot with
| Some the_ballot ->
......@@ -507,20 +522,20 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
let can_vote = can_vote W.metadata user in
T.cast_confirmation ~confirm ~can_vote ()
let () = Html5.register
~service:W.S.election_cast
let election_cast =
(if_eligible can_read
(fun user () ->
let cont () () = Redirection.send W.S.election_cast in
Eliom_reference.set S.cont cont >>
match_lwt Eliom_reference.get ballot with
| Some _ -> ballot_received user
| None -> T.cast_raw ()
| Some _ -> ballot_received user >>= Html5.send
| None -> T.cast_raw () >>= Html5.send
)
)
let () = Any.register
~service:W.S.election_cast_post
let () = Any.register ~service:W.S.election_cast election_cast
let election_cast_post =
(if_eligible can_read
(fun user (ballot_raw, ballot_file) ->
lwt the_ballot = match ballot_raw, ballot_file with
......@@ -539,6 +554,11 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
)
)
let () =
Any.register
~service:W.S.election_cast_post
election_cast_post
end
end
......
......@@ -26,8 +26,8 @@ open Web_serializable_t
open Web_signatures
module type REGISTRATION = sig
module W : WEB_ELECTION
module Register (S : SITE) (T : TEMPLATES) : EMPTY
module W : WEB_ELECTION_
module Register (S : SITE) (T : TEMPLATES) : ELECTION_HANDLERS
end
module type REGISTRABLE = sig
......
......@@ -401,6 +401,22 @@ module type ELECTION_SERVICES = sig
end
type content =
Eliom_registration.browser_content Eliom_registration.kind Lwt.t
module type ELECTION_HANDLERS =
sig
val home : unit -> unit -> content
val admin : unit -> unit -> content
val election_dir : Web_common.election_file -> unit -> content
val election_update_credential : unit -> unit -> content
val election_update_credential_post : unit -> string * string -> content
val election_vote : unit -> unit -> content
val election_cast : unit -> unit -> content
val election_cast_post :
unit -> string option * Eliom_lib.file_info option -> content
end
type service_handler = unit ->
Eliom_registration.browser_content Eliom_registration.kind Lwt.t
......@@ -475,7 +491,7 @@ module type WEB_PARAMS = sig
val dir : string
end
module type WEB_ELECTION = sig
module type WEB_ELECTION_ = sig
include ELECTION_DATA
include WEB_PARAMS
module E : ELECTION with type elt = G.t
......@@ -484,6 +500,11 @@ module type WEB_ELECTION = sig
module H : AUTH_HANDLERS_PUBLIC
end
module type WEB_ELECTION = sig
include WEB_ELECTION_
module Z : ELECTION_HANDLERS
end
module type SITE_SERVICES = sig
include CORE_SERVICES
include AUTH_SERVICES
......@@ -589,7 +610,7 @@ module type TEMPLATES = sig
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
module Login (S : AUTH_SERVICES) : LOGIN_TEMPLATES
module Election (W : WEB_ELECTION) : ELECTION_TEMPLATES
module Election (W : WEB_ELECTION_) : ELECTION_TEMPLATES
end
......
......@@ -282,7 +282,11 @@ module Make (C : CONFIG) : SITE = struct
(* starting from here, we do side-effects on the running server *)
let module R = R.Register (struct end) in
let module W = R.W in
let module X : EMPTY = R.Register (S) (T) in
let module X : ELECTION_HANDLERS = R.Register (S) (T) in
let module W = struct
include W
module Z = X
end in
let election = (module W : WEB_ELECTION) in
election_table := SMap.add uuid election !election_table;
election
......
......@@ -495,7 +495,7 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
let login_box = pcdata "" in
base ~title ~login_box ~content
module Election (W : WEB_ELECTION) = struct
module Election (W : WEB_ELECTION_) = struct
let election_login_box =
let auth = (module W.S : AUTH_SERVICES) in
......
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