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

Remove Web_templates.Login functor

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