Commit f1eb6365 authored by Stephane Glondu's avatar Stephane Glondu

Remove Web_templates.Login functor

parent 08588459
......@@ -33,7 +33,7 @@ module type CONFIG = sig
val server : string
end
module Make (C : CONFIG) (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = struct
module Make (C : CONFIG) (N : NAME) (S : AUTH_SERVICES) (L : AUTH_LINKS) : AUTH_HANDLERS = struct
let scope = Eliom_common.default_session_scope
......
......@@ -32,7 +32,7 @@ let parse_config ~attributes =
| [] -> Some ()
| _ -> None
module Make (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = struct
module Make (N : NAME) (S : AUTH_SERVICES) (L : AUTH_LINKS) : AUTH_HANDLERS = struct
let scope = Eliom_common.default_session_scope
......@@ -60,7 +60,7 @@ module Make (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = struct
cont user_name ()
| None -> fail_http 400
)
in T.dummy ~service ()
in Web_templates.dummy ~service (module S : AUTH_SERVICES) (module L : AUTH_LINKS) ()
)
let login cont () =
......
......@@ -49,7 +49,7 @@ let load_db name file =
let ( / ) = Filename.concat
module Make (C : CONFIG) (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = struct
module Make (C : CONFIG) (N : NAME) (S : AUTH_SERVICES) (L : AUTH_LINKS) : AUTH_HANDLERS = struct
let scope = Eliom_common.default_session_scope
......@@ -97,7 +97,7 @@ module Make (C : CONFIG) (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = stru
| None -> fail_http 400
) else forbidden ())
in
T.password ~service ()
Web_templates.password ~service (module S : AUTH_SERVICES) (module L : AUTH_LINKS) ()
let bootstrap_service_handler () =
let post_params = Eliom_parameter.file "password_db" in
......@@ -126,7 +126,7 @@ module Make (C : CONFIG) (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = stru
| `Production _ -> forbidden ()
)
in
T.upload_password_db ~service:upload_service ()
Web_templates.upload_password_db ~service:upload_service (module S : AUTH_SERVICES) (module L : AUTH_LINKS) ()
let () = Eliom_registration.Html5.register ~service
(fun () () ->
......
......@@ -10,12 +10,12 @@ Election
Web_serializable_j
Web_common
Web_services
Web_templates
Web_auth
Auth_dummy
Auth_password
Auth_cas
Web_site_auth
Web_templates
Web_persist
Web_election
Web_site
......
......@@ -54,9 +54,8 @@ module Make (N : NAME) = struct
(* Forward reference, will be set to eponymous template *)
let login_choose = ref (fun () -> assert false)
let register templates xs =
let module T = (val templates : LOGIN_TEMPLATES) in
login_choose := T.choose;
let register auth_services links xs =
login_choose := Web_templates.choose auth_services links;
List.iter
(fun auth_instance ->
let {
......@@ -87,7 +86,9 @@ module Make (N : NAME) = struct
let path = N.path @ ["auth"; instance]
let kind = N.kind
end in
let module A = (val auth : AUTH_SERVICE) (N) (T) in
let module S = (val auth_services : AUTH_SERVICES) in
let module L = (val links : AUTH_LINKS) in
let module A = (val auth : AUTH_SERVICE) (N) (S) (L) in
let i = (module A : AUTH_HANDLERS) in
Hashtbl.add auth_instances instance i;
auth_instance_names := instance :: !auth_instance_names
......
......@@ -27,7 +27,7 @@ open Web_signatures
val register_auth_system : (module AUTH_SYSTEM) -> unit
module Make (C : NAME) : sig
val register : (module LOGIN_TEMPLATES) -> auth_config list -> unit
val register : (module AUTH_SERVICES) -> (module AUTH_LINKS) -> auth_config list -> unit
module Services : AUTH_SERVICES
module Handlers : AUTH_HANDLERS_PUBLIC
end
......@@ -283,9 +283,7 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
end
let () =
let module T = Web_templates.Login (W.S) (L) in
let templates = (module T : LOGIN_TEMPLATES) in
Auth.register templates N.auth_config
Auth.register (module W.S : AUTH_SERVICES) (module L : AUTH_LINKS) N.auth_config
let login service () =
lwt cont = Eliom_reference.get Web_services.cont in
......@@ -334,7 +332,7 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
match site_user with
| Some u when W.metadata.e_owner = Some u ->
lwt state = Web_persist.get_election_state uuid in
T.election_admin (module W) ~is_featured state () >>= Html5.send
T.election_admin (module W) ~is_featured state (module Web_site_auth : AUTH_SERVICES) () >>= Html5.send
| _ -> forbidden ()
)
......@@ -370,7 +368,7 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
match site_user with
| Some u ->
if W.metadata.e_owner = Some u then (
T.update_credential (module W) () >>= Html5.send
T.update_credential (module W) (module Web_site_auth : AUTH_SERVICES) () >>= Html5.send
) else (
forbidden ()
)
......
......@@ -147,45 +147,6 @@ module type REGISTRABLE_ELECTION = sig
val register : unit -> (module WEB_ELECTION) Lwt.t
end
module type LOGIN_TEMPLATES = sig
val dummy :
service:(unit, 'a, [< Eliom_service.post_service_kind ],
[< Eliom_service.suff ], 'b,
[< string Eliom_parameter.setoneradio ]
Eliom_parameter.param_name,
[< Eliom_service.registrable ],
[< Eliom_service.non_ocaml_service ])
Eliom_service.service ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val password :
service:(unit, 'a, [< Eliom_service.post_service_kind ],
[< Eliom_service.suff ], 'b,
[< string Eliom_parameter.setoneradio ]
Eliom_parameter.param_name *
[< string Eliom_parameter.setoneradio ]
Eliom_parameter.param_name,
[< Eliom_service.registrable ],
[< Eliom_service.non_ocaml_service ])
Eliom_service.service ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val upload_password_db :
service:(unit, 'a, [< Eliom_service.post_service_kind ],
[< Eliom_service.suff ], 'b,
[< Eliom_lib.file_info Eliom_parameter.setoneradio ]
Eliom_parameter.param_name,
[< Eliom_service.registrable ],
[< Eliom_service.non_ocaml_service ])
Eliom_service.service ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val choose :
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
end
module type NAME = sig
val name : string
val path : string list
......@@ -194,7 +155,8 @@ end
module type AUTH_SERVICE =
functor (N : NAME) ->
functor (T : LOGIN_TEMPLATES) ->
functor (S : AUTH_SERVICES) ->
functor (L : AUTH_LINKS) ->
AUTH_HANDLERS
module type AUTH_SYSTEM = sig
......
......@@ -230,9 +230,7 @@ module L = struct
end
let install_authentication auth_configs =
let module T = T.Login (Web_site_auth) (L) in
let templates = (module T : LOGIN_TEMPLATES) in
Web_site_auth.register templates auth_configs
Web_site_auth.register (module Web_site_auth : AUTH_SERVICES) (module L : AUTH_LINKS) auth_configs
let () = Any.register ~service:home
(fun () () ->
......@@ -267,7 +265,7 @@ let () = Html5.register ~service:admin
)
) !election_table [] |> List.rev |> return
in
T.admin ~elections ()
T.admin ~elections (module Web_site_auth : AUTH_SERVICES) ()
)
let () = File.register
......@@ -299,7 +297,7 @@ let () = Html5.register ~service:new_election
(fun () () ->
match_lwt Web_site_auth.get_user () with
| None -> forbidden ()
| Some _ -> T.new_election ()
| Some _ -> T.new_election (module Web_site_auth : AUTH_SERVICES) ()
)
let () = Any.register ~service:new_election_post
......@@ -316,7 +314,7 @@ let () = Any.register ~service:new_election_post
begin try_lwt
begin match_lwt import_election files with
| None ->
T.new_election_failure `Exists () >>= Html5.send
T.new_election_failure `Exists (module Web_site_auth : AUTH_SERVICES) () >>= Html5.send
| Some w ->
let module W = (val w : REGISTRABLE_ELECTION) in
lwt w = W.register () in
......@@ -325,7 +323,7 @@ let () = Any.register ~service:new_election_post
(preapply election_admin (W.election.e_params.e_uuid, ()))
end
with e ->
T.new_election_failure (`Exception e) () >>= Html5.send
T.new_election_failure (`Exception e) (module Web_site_auth : AUTH_SERVICES) () >>= Html5.send
end
| None -> forbidden ()
)
......@@ -342,7 +340,7 @@ let () = Html5.register ~service:election_setup_index
then return (uuid_of_string k :: accu)
else return accu
) election_stable []
in T.election_setup_index uuids ()
in T.election_setup_index uuids (module Web_site_auth : AUTH_SERVICES) ()
| None -> forbidden ()
)
......@@ -394,7 +392,7 @@ let () = Html5.register ~service:election_setup
let uuid_s = Uuidm.to_string uuid in
lwt se = Ocsipersist.find election_stable uuid_s in
if se.se_owner = u
then T.election_setup uuid se ()
then T.election_setup uuid se (module Web_site_auth : AUTH_SERVICES) ()
else forbidden ()
| None -> forbidden ()
)
......@@ -445,7 +443,7 @@ let () =
let uuid_s = Uuidm.to_string uuid in
lwt se = Ocsipersist.find election_stable uuid_s in
if se.se_owner = u
then T.election_setup_questions uuid se ()
then T.election_setup_questions uuid se (module Web_site_auth : AUTH_SERVICES) ()
else forbidden ()
| None -> forbidden ()
)
......@@ -648,7 +646,7 @@ let () =
(* actually create the election *)
begin match_lwt import_election files with
| None ->
T.new_election_failure `Exists () >>= Html5.send
T.new_election_failure `Exists (module Web_site_auth : AUTH_SERVICES) () >>= Html5.send
| Some w ->
let module W = (val w : REGISTRABLE_ELECTION) in
lwt w = W.register () in
......@@ -670,7 +668,7 @@ let () =
end
)
with e ->
T.new_election_failure (`Exception e) () >>= Html5.send
T.new_election_failure (`Exception e) (module Web_site_auth : AUTH_SERVICES) () >>= Html5.send
end
)
......
open Web_serializable_t
open Web_signatures
val register : (module LOGIN_TEMPLATES) -> auth_config list -> unit
val register : (module AUTH_SERVICES) -> (module AUTH_LINKS) -> auth_config list -> unit
include AUTH_SERVICES
......@@ -74,9 +74,7 @@ let make_login_box style auth links =
]
)
let site_login_box =
let auth = (module Web_site_auth : AUTH_SERVICES) in
let site_login_box auth =
let module L = struct
let login x = Eliom_service.preapply site_login x
let logout = Eliom_service.preapply site_logout ()
......@@ -151,7 +149,7 @@ let home ~featured () =
let login_box = pcdata "" in
base ~title:site_title ~login_box ~content ()
let admin ~elections () =
let admin ~elections auth () =
let title = site_title ^ " — Administration" in
let elections =
match elections with
......@@ -166,20 +164,17 @@ let admin ~elections () =
elections;
];
] in
lwt login_box = site_login_box () in
lwt login_box = site_login_box auth () in
base ~title ~login_box ~content ()
module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES = struct
let login_box =
let auth = (module S : AUTH_SERVICES) in
let links = (module L : AUTH_LINKS) in
let login_box auth links =
let module S = (val auth : AUTH_SERVICES) in
let style =
if S.auth_realm = "site" then admin_background else ""
in
fun () -> make_login_box style auth links
make_login_box style auth links
let dummy ~service () =
let dummy ~service auth links () =
let title, field_name, input_type =
"Dummy login", "Username:", `Text
in
......@@ -200,10 +195,10 @@ module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES = struct
let content = [
form;
] in
lwt login_box = login_box () in
lwt login_box = login_box auth links in
base ~title ~login_box ~content ()
let password ~service () =
let password ~service auth links () =
let form = post_form ~service
(fun (llogin, lpassword) ->
[
......@@ -225,10 +220,10 @@ module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES = struct
let content = [
form;
] in
lwt login_box = login_box () in
lwt login_box = login_box auth links in
base ~title:"Password login" ~login_box ~content ()
let upload_password_db ~service () =
let upload_password_db ~service auth links () =
let title = "Upload password database" in
let form = post_form ~service
(fun password_db ->
......@@ -244,10 +239,12 @@ module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES = struct
let content = [
div [form];
] in
lwt login_box = site_login_box () in
lwt login_box = login_box auth links in
base ~title ~login_box ~content ()
let choose () =
let choose auth links () =
let module S = (val auth : AUTH_SERVICES) in
let module L = (val links : AUTH_LINKS) in
let auth_systems =
S.get_auth_systems () |>
List.map (fun name ->
......@@ -259,11 +256,9 @@ module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES = struct
[pcdata "Please log in: ["] @ auth_systems @ [pcdata "]"]
)]
] in
lwt login_box = login_box () in
lwt login_box = login_box auth links in
base ~title:"Log in" ~login_box ~content ()
end
let format_date = Platform.format_datetime "%a, %d %b %Y %T %z"
let make_button ~service contents =
......@@ -273,7 +268,7 @@ let make_button ~service contents =
uri
contents
let new_election () =
let new_election auth () =
let title = "Create new election" in
lwt body =
let form = post_form ~service:new_election_post
......@@ -318,10 +313,10 @@ let new_election () =
let content = [
div body;
] in
lwt login_box = site_login_box () in
lwt login_box = site_login_box auth () in
base ~title ~login_box ~content ()
let new_election_failure reason () =
let new_election_failure reason auth () =
let title = "Create new election" in
let reason =
match reason with
......@@ -334,10 +329,10 @@ let new_election_failure reason () =
p [reason];
]
] in
lwt login_box = site_login_box () in
lwt login_box = site_login_box auth () in
base ~title ~login_box ~content ()
let election_setup_index uuids () =
let election_setup_index uuids auth () =
let service = election_setup in
let title = "Elections being prepared" in
let uuids =
......@@ -353,7 +348,7 @@ let election_setup_index uuids () =
let content = [
div [list];
] in
lwt login_box = site_login_box () in
lwt login_box = site_login_box auth () in
base ~title ~login_box ~content ()
let generic_error_page message () =
......@@ -364,7 +359,7 @@ let generic_error_page message () =
let login_box = pcdata "" in
base ~title ~login_box ~content ()
let election_setup uuid se () =
let election_setup uuid se auth () =
let title = "Preparation of election " ^ Uuidm.to_string uuid in
let make_form ?a service value title =
post_form ?a ~service
......@@ -438,10 +433,10 @@ let election_setup uuid se () =
div_questions;
form_create;
] in
lwt login_box = site_login_box () in
lwt login_box = site_login_box auth () in
base ~title ~login_box ~content ()
let election_setup_questions uuid se () =
let election_setup_questions uuid se auth () =
let title = "Questions for election " ^ Uuidm.to_string uuid in
let form =
let value = string_of_template se.se_questions in
......@@ -474,7 +469,7 @@ let election_setup_questions uuid se () =
form;
link;
] in
lwt login_box = site_login_box () in
lwt login_box = site_login_box auth () in
base ~title ~login_box ~content ()
let election_setup_credentials token uuid se () =
......@@ -738,7 +733,7 @@ let election_home w state () =
lwt login_box = election_login_box w () in
base ~title:params.e_name ~login_box ~content ~footer ()
let election_admin w ~is_featured state () =
let election_admin w ~is_featured state auth () =
let module W = (val w : WEB_ELECTION_) in
let title = W.election.e_params.e_name ^ " — Administration" in
let feature_form = post_form ~service:election_set_featured
......@@ -773,10 +768,10 @@ let election_admin w ~is_featured state () =
div [feature_form];
div [state_form];
] in
lwt login_box = site_login_box () in
lwt login_box = site_login_box auth () in
base ~title ~login_box ~content ()
let update_credential w () =
let update_credential w auth () =
let module W = (val w : WEB_ELECTION_) in
let params = W.election.e_params in
let form = post_form ~service:election_update_credential_post
......@@ -814,7 +809,7 @@ let update_credential w () =
let content = [
form;
] in
lwt login_box = site_login_box () in
lwt login_box = site_login_box auth () in
base ~title:params.e_name ~login_box ~content ()
let cast_raw w () =
......
......@@ -22,25 +22,62 @@
open Web_signatures
val home : featured:(module WEB_ELECTION) list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val admin : elections:(module WEB_ELECTION) list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val admin : elections:(module WEB_ELECTION) list -> (module AUTH_SERVICES) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val new_election : unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val new_election_failure : [ `Exists | `Exception of exn ] -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val new_election : (module AUTH_SERVICES) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val new_election_failure : [ `Exists | `Exception of exn ] -> (module AUTH_SERVICES) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val generic_error_page : string -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_index : Uuidm.t list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup : Uuidm.t -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_questions : Uuidm.t -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_index : Uuidm.t list -> (module AUTH_SERVICES) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup : Uuidm.t -> Web_common.setup_election -> (module AUTH_SERVICES) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_questions : Uuidm.t -> Web_common.setup_election -> (module AUTH_SERVICES) -> 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_home : (module WEB_ELECTION_) -> [ `Open | `Closed ] -> 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 election_admin : (module WEB_ELECTION_) -> is_featured:bool -> [ `Open | `Closed ] -> (module AUTH_SERVICES) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val update_credential : (module WEB_ELECTION_) -> (module AUTH_SERVICES) -> 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_confirmed : (module WEB_ELECTION_) -> result:[< `Error of Web_common.error | `Valid of string ] -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val pretty_ballots : (module WEB_ELECTION_) -> string list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES
val dummy :
service:(unit, 'a, [< Eliom_service.post_service_kind ],
[< Eliom_service.suff ], 'b,
[< string Eliom_parameter.setoneradio ]
Eliom_parameter.param_name,
[< Eliom_service.registrable ],
[< Eliom_service.non_ocaml_service ])
Eliom_service.service ->
(module AUTH_SERVICES) -> (module AUTH_LINKS) ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val password :
service:(unit, 'a, [< Eliom_service.post_service_kind ],
[< Eliom_service.suff ], 'b,
[< string Eliom_parameter.setoneradio ]
Eliom_parameter.param_name *
[< string Eliom_parameter.setoneradio ]
Eliom_parameter.param_name,
[< Eliom_service.registrable ],
[< Eliom_service.non_ocaml_service ])
Eliom_service.service ->
(module AUTH_SERVICES) -> (module AUTH_LINKS) ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val upload_password_db :
service:(unit, 'a, [< Eliom_service.post_service_kind ],
[< Eliom_service.suff ], 'b,
[< Eliom_lib.file_info Eliom_parameter.setoneradio ]
Eliom_parameter.param_name,
[< Eliom_service.registrable ],
[< Eliom_service.non_ocaml_service ])
Eliom_service.service ->
(module AUTH_SERVICES) -> (module AUTH_LINKS) ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val choose :
(module AUTH_SERVICES) -> (module AUTH_LINKS) ->
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