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