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

Remove "SITE" argument in Web_election functor

parent 1c5ecd1a
......@@ -50,7 +50,7 @@ let can_vote m user =
module type REGISTRATION = sig
module W : WEB_ELECTION_
module Register (S : SITE) (T : TEMPLATES) : ELECTION_HANDLERS
module Register (T : TEMPLATES) : ELECTION_HANDLERS
end
module type REGISTRABLE = sig
......@@ -274,7 +274,7 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
end
module Register (S : SITE) (T : TEMPLATES) : ELECTION_HANDLERS = struct
module Register (T : TEMPLATES) : ELECTION_HANDLERS = struct
open Eliom_registration
module L = struct
......@@ -327,11 +327,10 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
)
)
let admin =
let admin site_user is_featured =
(fun () () ->
match_lwt S.get_user () with
match site_user with
| Some u when W.metadata.e_owner = Some u ->
lwt is_featured = S.is_featured_election uuid in
T.admin ~is_featured () >>= Html5.send
| _ -> forbidden ()
)
......@@ -340,10 +339,10 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
| ESRaw | ESKeys | ESBallots -> "application/json"
| ESCreds | ESRecords -> "text/plain"
let handle_pseudo_file u f =
let handle_pseudo_file u f site_user =
lwt () =
if f = ESRecords then (
match_lwt S.get_user () with
match site_user with
| Some u when W.metadata.e_owner <> Some u -> forbidden ()
| _ -> return ()
) else return ()
......@@ -351,7 +350,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 election_dir =
let election_dir site_user =
(fun f () ->
let cont () () =
Redirection.send
......@@ -360,13 +359,12 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
(W.election.e_params.e_uuid, f))
in
Eliom_reference.set Web_services.cont cont >>
handle_pseudo_file () f
handle_pseudo_file () f site_user
)
let election_update_credential =
let election_update_credential site_user =
(fun () () ->
lwt user = S.get_user () in
match user with
match site_user with
| Some u ->
if W.metadata.e_owner = Some u then (
T.update_credential () >>= Html5.send
......@@ -376,10 +374,9 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
| _ -> forbidden ()
)
let election_update_credential_post =
let election_update_credential_post site_user =
(fun () (old, new_) ->
lwt user = S.get_user () in
match user with
match site_user with
| Some u ->
if W.metadata.e_owner = Some u then (
try_lwt
......
......@@ -27,7 +27,7 @@ open Web_signatures
module type REGISTRATION = sig
module W : WEB_ELECTION_
module Register (S : SITE) (T : TEMPLATES) : ELECTION_HANDLERS
module Register (T : TEMPLATES) : ELECTION_HANDLERS
end
module type REGISTRABLE = sig
......
......@@ -67,10 +67,10 @@ module type ELECTION_HANDLERS =
val login : string option -> unit -> content
val logout : unit -> unit -> content
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 admin : user option -> bool -> unit -> unit -> content
val election_dir : user option -> Web_common.election_file -> unit -> content
val election_update_credential : user option -> unit -> unit -> content
val election_update_credential_post : user option -> unit -> string * string -> content
val election_vote : unit -> unit -> content
val election_cast : unit -> unit -> content
val election_cast_post :
......@@ -171,19 +171,6 @@ module type REGISTRABLE_ELECTION = sig
val register : unit -> (module WEB_ELECTION) Lwt.t
end
module type SITE = sig
include AUTH_SERVICES
include AUTH_HANDLERS_PUBLIC
val import_election :
election_files -> (module REGISTRABLE_ELECTION) option Lwt.t
val set_main_election : string -> unit Lwt.t
val unset_main_election : unit -> unit Lwt.t
val add_featured_election : string -> unit Lwt.t
val remove_featured_election : string -> unit Lwt.t
val is_featured_election : string -> bool Lwt.t
val install_authentication : auth_config list -> unit
end
module type LOGIN_TEMPLATES = sig
val dummy :
......
......@@ -102,15 +102,7 @@ let delete_shallow_directory dir =
(* Forward reference *)
let install_authentication_ref = ref (fun _ -> assert false)
(* We use an intermediate module S that will be passed to Templates
and Web_election. S is not meant to leak and will be included
in the returned module later. *)
module S : SITE = struct
include Auth.Services
include Auth.Handlers
open Eliom_parameter
open Eliom_service.Http
let import_election f = !import_election_ref f
......@@ -144,11 +136,7 @@ let delete_shallow_directory dir =
let install_authentication xs = !install_authentication_ref xs
end
include S
module T = Web_templates.Make (S)
module T = Web_templates.Make (Auth.Services)
let register_election params web_params =
let module P = (val params : ELECTION_PARAMS) in
......@@ -167,7 +155,7 @@ let delete_shallow_directory dir =
(* 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 : ELECTION_HANDLERS = R.Register (S) (T) in
let module X : ELECTION_HANDLERS = R.Register (T) in
let module W = struct
include W
module Z = X
......@@ -303,7 +291,7 @@ let delete_shallow_directory dir =
end
let () = install_authentication_ref := fun auth_configs ->
let module T = T.Login (S) (L) in
let module T = T.Login (Auth.Services) (L) in
let templates = (module T : LOGIN_TEMPLATES) in
Auth.register templates auth_configs
......@@ -381,14 +369,14 @@ let delete_shallow_directory dir =
let () = Html5.register ~service:new_election
(fun () () ->
match_lwt S.get_user () with
match_lwt get_user () with
| None -> forbidden ()
| Some _ -> T.new_election ()
)
let () = Any.register ~service:new_election_post
(fun () (election, (metadata, (public_keys, public_creds))) ->
match_lwt S.get_user () with
match_lwt get_user () with
| Some u ->
let open Ocsigen_extensions in
let files = {
......@@ -398,7 +386,7 @@ let delete_shallow_directory dir =
f_public_creds = public_creds.tmp_filename;
} in
begin try_lwt
begin match_lwt S.import_election files with
begin match_lwt import_election files with
| None ->
T.new_election_failure `Exists () >>= Html5.send
| Some w ->
......@@ -418,7 +406,7 @@ let delete_shallow_directory dir =
let () = Html5.register ~service:election_setup_index
(fun () () ->
match_lwt S.get_user () with
match_lwt get_user () with
| Some u ->
lwt uuids =
Ocsipersist.fold_step (fun k v accu ->
......@@ -432,7 +420,7 @@ let delete_shallow_directory dir =
let () = Redirection.register ~service:election_setup_new
(fun () () ->
match_lwt S.get_user () with
match_lwt get_user () with
| Some u ->
let uuid = generate_uuid () in
let uuid_s = Uuidm.to_string uuid in
......@@ -473,7 +461,7 @@ let delete_shallow_directory dir =
let () = Html5.register ~service:election_setup
(fun uuid () ->
match_lwt S.get_user () with
match_lwt get_user () with
| Some u ->
let uuid_s = Uuidm.to_string uuid in
lwt se = Ocsipersist.find election_stable uuid_s in
......@@ -486,7 +474,7 @@ let delete_shallow_directory dir =
let election_setup_mutex = Lwt_mutex.create ()
let handle_setup f uuid x =
match_lwt S.get_user () with
match_lwt get_user () with
| Some u ->
let uuid_s = Uuidm.to_string uuid in
Lwt_mutex.with_lock election_setup_mutex (fun () ->
......@@ -531,7 +519,7 @@ let delete_shallow_directory dir =
Redirection.register
~service:election_setup_trustee_add
(fun uuid () ->
match_lwt S.get_user () with
match_lwt get_user () with
| Some u ->
let uuid_s = Uuidm.to_string uuid in
Lwt_mutex.with_lock election_setup_mutex (fun () ->
......@@ -648,7 +636,7 @@ let delete_shallow_directory dir =
Any.register
~service:election_setup_create
(fun uuid () ->
match_lwt S.get_user () with
match_lwt get_user () with
| None -> forbidden ()
| Some u ->
begin try_lwt
......@@ -716,7 +704,7 @@ let delete_shallow_directory dir =
) public_keys
) >>
(* actually create the election *)
begin match_lwt S.import_election files with
begin match_lwt import_election files with
| None ->
T.new_election_failure `Exists () >>= Html5.send
| Some w ->
......@@ -759,8 +747,8 @@ let delete_shallow_directory dir =
(fun (uuid, ()) featured ->
let uuid_s = Uuidm.to_string uuid in
lwt () =
if featured then S.add_featured_election uuid_s
else S.remove_featured_election uuid_s
if featured then add_featured_election uuid_s
else remove_featured_election uuid_s
in
Redirection.send
(preapply election_admin (uuid, ())))
......@@ -772,7 +760,9 @@ let delete_shallow_directory dir =
let uuid_s = Uuidm.to_string uuid in
let w = SMap.find uuid_s !election_table in
let module W = (val w : WEB_ELECTION) in
W.Z.admin () ())
lwt user = get_user () in
lwt is_featured = is_featured_election uuid_s in
W.Z.admin user is_featured () ())
let () =
Any.register
......@@ -799,7 +789,8 @@ let delete_shallow_directory dir =
let uuid_s = Uuidm.to_string uuid in
let w = SMap.find uuid_s !election_table in
let module W = (val w : WEB_ELECTION) in
W.Z.election_update_credential () ())
lwt user = get_user () in
W.Z.election_update_credential user () ())
let () =
Any.register
......@@ -808,7 +799,8 @@ let delete_shallow_directory dir =
let uuid_s = Uuidm.to_string uuid in
let w = SMap.find uuid_s !election_table in
let module W = (val w : WEB_ELECTION) in
W.Z.election_update_credential_post () x)
lwt user = get_user () in
W.Z.election_update_credential_post user () x)
let () =
Any.register
......@@ -853,4 +845,5 @@ let delete_shallow_directory dir =
let uuid_s = Uuidm.to_string uuid in
let w = SMap.find uuid_s !election_table in
let module W = (val w : WEB_ELECTION) in
W.Z.election_dir f x)
lwt user = get_user () in
W.Z.election_dir user f x)
......@@ -25,4 +25,11 @@ open Web_signatures
val source_file : string ref
val spool_dir : string ref
include SITE
val import_election :
election_files -> (module REGISTRABLE_ELECTION) option Lwt.t
val set_main_election : string -> unit Lwt.t
val unset_main_election : unit -> unit Lwt.t
val add_featured_election : string -> unit Lwt.t
val remove_featured_election : string -> unit Lwt.t
val is_featured_election : string -> bool Lwt.t
val install_authentication : auth_config list -> unit
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