Commit 621149de authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Simplification of AUTH_INSTANCE

There were 3 phases: configuration parsing, service definition and
service registration. The last two can be merged, since there is no
direct external reference to the service of a specific auth system. As
a consequence, there is no need for a Register sub-fonctor in
AUTH_INSTANCE: service definition and registration occur directly in
the Make function, called by instantiate.
parent 16b29f94
......@@ -31,7 +31,7 @@ module type CONFIG = sig
val server : string
end
module Make (C : CONFIG) (N : NAME) : AUTH_INSTANCE = struct
module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = struct
let user_admin = false
let user_type = N.name
......@@ -61,64 +61,60 @@ module Make (C : CONFIG) (N : NAME) : AUTH_INSTANCE = struct
let service = Eliom_service.preapply login_cas None
module Register (S : CONT_SERVICE) (T : TEMPLATES) = struct
let () = Eliom_registration.Redirection.register
~service:login_cas
(fun ticket () ->
match ticket with
| Some x ->
let me =
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
rewrite_prefix uri
in
let validation =
let service = Eliom_service.preapply cas_validate (me, x) in
Eliom_uri.make_string_uri ~absolute:true ~service ()
in
lwt reply = Ocsigen_http_client.get_url validation in
(match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
(match next_lf info 0 with
| Some i ->
(match String.sub info 0 i with
| "yes" ->
(match next_lf info (i+1) with
| Some j ->
let user_name = String.sub info (i+1) (j-i-1) in
let user_user = {user_type; user_name} in
let module L : CONT_SERVICE = struct
let cont () =
lwt service = S.cont () in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = rewrite_prefix uri in
security_log (fun () ->
Printf.sprintf "%s logged out, redirecting to CAS [%s]"
(string_of_user user_user) C.server
) >> Lwt.return (Eliom_service.preapply cas_logout uri)
end in
let user_logout = (module L : CONT_SERVICE) in
Eliom_reference.set user
(Some {user_admin; user_user; user_logout}) >>
S.cont ()
| None -> fail_http 502
)
| "no" -> fail_http 401
| _ -> fail_http 502
)
| None -> fail_http 502
)
| None -> fail_http 502
)
| None ->
let () = Eliom_registration.Redirection.register
~service:login_cas
(fun ticket () ->
match ticket with
| Some x ->
let me =
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = rewrite_prefix uri in
Lwt.return (Eliom_service.preapply cas_login uri)
)
end
rewrite_prefix uri
in
let validation =
let service = Eliom_service.preapply cas_validate (me, x) in
Eliom_uri.make_string_uri ~absolute:true ~service ()
in
lwt reply = Ocsigen_http_client.get_url validation in
(match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
(match next_lf info 0 with
| Some i ->
(match String.sub info 0 i with
| "yes" ->
(match next_lf info (i+1) with
| Some j ->
let user_name = String.sub info (i+1) (j-i-1) in
let user_user = {user_type; user_name} in
let module L : CONT_SERVICE = struct
let cont () =
lwt service = S.cont () in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = rewrite_prefix uri in
security_log (fun () ->
Printf.sprintf "%s logged out, redirecting to CAS [%s]"
(string_of_user user_user) C.server
) >> Lwt.return (Eliom_service.preapply cas_logout uri)
end in
let user_logout = (module L : CONT_SERVICE) in
Eliom_reference.set user
(Some {user_admin; user_user; user_logout}) >>
S.cont ()
| None -> fail_http 502
)
| "no" -> fail_http 401
| _ -> fail_http 502
)
| None -> fail_http 502
)
| None -> fail_http 502
)
| None ->
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = rewrite_prefix uri in
Lwt.return (Eliom_service.preapply cas_login uri)
)
end
......
......@@ -59,25 +59,6 @@ module Make (X : EMPTY) = struct
let instances = Hashtbl.create 10
let auth_systems = ref []
let instantiate name auth =
if Hashtbl.mem instances name then (
failwith ("multiple instances with name " ^ name)
) else (
let module N = struct let name = name end in
let module A = (val auth : AUTH_SERVICE) in
let i = (module A (N) : AUTH_INSTANCE) in
Hashtbl.add instances name i;
auth_systems := name :: !auth_systems
)
let () = List.iter (fun f -> f ~instantiate) !config_exec
let default_auth_system = lazy (
match !auth_systems with
| [name] -> name
| _ -> failwith "several (or no) instances of auth systems"
)
module Services : AUTH_SERVICES = struct
let get_auth_systems () = !auth_systems
......@@ -96,11 +77,24 @@ module Make (X : EMPTY) = struct
module Register (C : CONT_SERVICE) (T : TEMPLATES) : EMPTY = struct
let () = Hashtbl.iter (fun name i ->
let module A = (val i : AUTH_INSTANCE) in
let module X : EMPTY = A.Register (C) (T) in
()
) instances
let instantiate name auth =
if Hashtbl.mem instances name then (
failwith ("multiple instances with name " ^ name)
) else (
let module N = struct let name = name end in
let module A = (val auth : AUTH_SERVICE) (N) (C) (T) in
let i = (module A : AUTH_INSTANCE) in
Hashtbl.add instances name i;
auth_systems := name :: !auth_systems
)
let () = List.iter (fun f -> f ~instantiate) !config_exec
let default_auth_system = lazy (
match !auth_systems with
| [name] -> name
| _ -> failwith "several (or no) instances of auth systems"
)
let () = Eliom_registration.Redirection.register
~service:Services.login
......
......@@ -22,7 +22,7 @@
open Web_signatures
open Auth_common
module Make (N : NAME) : AUTH_INSTANCE = struct
module Make (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = struct
let user_admin = false
let user_type = N.name
......@@ -32,30 +32,26 @@ module Make (N : NAME) : AUTH_INSTANCE = struct
~get_params:Eliom_parameter.unit
()
module Register (S : CONT_SERVICE) (T : TEMPLATES) = struct
let user_logout = (module S : CONT_SERVICE)
let user_logout = (module S : CONT_SERVICE)
let () = Eliom_registration.Html5.register ~service
(fun () () ->
let post_params = Eliom_parameter.(string "username") in
let service = Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope:Eliom_common.default_session_scope
~fallback:service
~post_params ()
in
let () = Eliom_registration.Redirection.register ~service
~scope:Eliom_common.default_session_scope
(fun () user_name ->
let user_user = {user_type; user_name} in
let logged_user = {user_admin; user_user; user_logout} in
Eliom_reference.set user (Some logged_user) >>
S.cont ())
in T.string_login ~service ~kind:`Dummy
)
end
let () = Eliom_registration.Html5.register ~service
(fun () () ->
let post_params = Eliom_parameter.(string "username") in
let service = Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope:Eliom_common.default_session_scope
~fallback:service
~post_params ()
in
let () = Eliom_registration.Redirection.register ~service
~scope:Eliom_common.default_session_scope
(fun () user_name ->
let user_user = {user_type; user_name} in
let logged_user = {user_admin; user_user; user_logout} in
Eliom_reference.set user (Some logged_user) >>
S.cont ())
in T.string_login ~service ~kind:`Dummy
)
end
......
......@@ -28,7 +28,7 @@ module type CONFIG = sig
val db : string
end
module Make (C : CONFIG) (N : NAME) : AUTH_INSTANCE = struct
module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = struct
let user_admin = false
let user_type = N.name
......@@ -46,38 +46,34 @@ module Make (C : CONFIG) (N : NAME) : AUTH_INSTANCE = struct
| _ -> failwith ("error while parsing db file for " ^ N.name)
) SMap.empty (Csv.load C.db)
module Register (S : CONT_SERVICE) (T : TEMPLATES) = struct
let user_logout = (module S : CONT_SERVICE)
let user_logout = (module S : CONT_SERVICE)
let () = Eliom_registration.Html5.register ~service
(fun () () ->
let post_params = Eliom_parameter.(
string "username" ** string "password"
) in
let service = Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope:Eliom_common.default_session_scope
~fallback:service
~post_params ()
in
let () = Eliom_registration.Redirection.register ~service
~scope:Eliom_common.default_session_scope
(fun () (user_name, password) ->
if (
try
let salt, hashed = SMap.find user_name db in
sha256_hex (salt ^ password) = hashed
with Not_found -> false
) then (
let user_user = {user_type; user_name} in
Eliom_reference.set user (Some {user_admin; user_user; user_logout}) >>
S.cont ()
) else forbidden ())
in T.password_login ~service
)
end
let () = Eliom_registration.Html5.register ~service
(fun () () ->
let post_params = Eliom_parameter.(
string "username" ** string "password"
) in
let service = Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope:Eliom_common.default_session_scope
~fallback:service
~post_params ()
in
let () = Eliom_registration.Redirection.register ~service
~scope:Eliom_common.default_session_scope
(fun () (user_name, password) ->
if (
try
let salt, hashed = SMap.find user_name db in
sha256_hex (salt ^ password) = hashed
with Not_found -> false
) then (
let user_user = {user_type; user_name} in
Eliom_reference.set user (Some {user_admin; user_user; user_logout}) >>
S.cont ()
) else forbidden ())
in T.password_login ~service
)
end
......
......@@ -202,8 +202,10 @@ module type AUTH_INSTANCE = sig
Eliom_service.registrable, 'a)
Eliom_service.service
module Register (S : CONT_SERVICE) (T : TEMPLATES) : EMPTY
end
module type AUTH_SERVICE = functor (N : NAME) -> AUTH_INSTANCE
module type AUTH_SERVICE =
functor (N : NAME) ->
functor (S : CONT_SERVICE) ->
functor (T : TEMPLATES) ->
AUTH_INSTANCE
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