Commit 9f74cb42 authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Remove CONT_SERVICE argument of AUTH_SERVICE

 - rename AUTH_INSTANCE into AUTH_HANDLERS
 - add "logout" to it
 - rename existing "handler" into "login"
 - logged_user contains AUTH_HANDLER instead of CONT_SERVICE
parent 8a8aa812
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Web_signatures
open Web_common
......@@ -32,7 +33,7 @@ module type CONFIG = sig
val server : string
end
module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = struct
module Make (C : CONFIG) (N : NAME) (T : TEMPLATES) : AUTH_HANDLERS = struct
let cas_login = Eliom_service.external_service
~prefix:C.server
......@@ -62,11 +63,15 @@ module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_IN
let self =
Eliom_uri.make_string_uri ~absolute:true ~service () |> rewrite_prefix
let on_success_ref = Eliom_reference.eref
let login_cont = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
(fun ~user_name ~user_logout -> Lwt.return ())
None
let () = Eliom_registration.Redirection.register
let logout_cont = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
None
let () = Eliom_registration.Any.register
~service:login_cas
(fun ticket () ->
match ticket with
......@@ -87,20 +92,12 @@ module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_IN
(match next_lf info (i+1) with
| Some j ->
let user_name = String.sub info (i+1) (j-i-1) 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:%s logged out, redirecting to CAS [%s]"
N.name user_name C.server
) >> Lwt.return (Eliom_service.preapply cas_logout uri)
end in
let user_logout = (module L : CONT_SERVICE) in
lwt on_success = Eliom_reference.get on_success_ref in
on_success ~user_name ~user_logout >>
S.cont ()
(match_lwt Eliom_reference.get login_cont with
| Some cont ->
Eliom_reference.unset login_cont >>
cont user_name ()
| None -> fail_http 400
)
| None -> fail_http 502
)
| "no" -> fail_http 401
......@@ -110,13 +107,28 @@ module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_IN
)
| None -> fail_http 502
)
| None -> Lwt.return (Eliom_service.preapply cas_login self)
| None ->
match_lwt Eliom_reference.get logout_cont with
| None ->
Eliom_service.preapply cas_login self |>
Eliom_registration.Redirection.send
| Some cont ->
Eliom_reference.unset logout_cont >>
cont () ()
)
let handler ~on_success () =
Eliom_reference.set on_success_ref on_success >>
let login cont () =
Eliom_reference.set login_cont (Some cont) >>
Eliom_registration.Redirection.send service
let logout cont () =
security_log (fun () ->
Printf.sprintf "user logged out, redirecting to CAS [%s]" C.server
) >>
lwt () = Eliom_reference.set logout_cont (Some cont) in
Eliom_service.preapply cas_logout self |>
Eliom_registration.Redirection.send
end
let name = "cas"
......
......@@ -62,15 +62,6 @@ module Make (N : CONFIG) = struct
~scope:Eliom_common.default_session_scope
None
let on_success user_domain ~user_name ~user_logout =
let user_user = {user_domain; user_name} in
let logged_user = {user_user; user_logout} in
security_log (fun () ->
Printf.sprintf "%s successfully logged on %s using %s"
user_name N.name user_domain
) >>
Eliom_reference.set user (Some logged_user)
module Services : AUTH_SERVICES = struct
let get_auth_systems () = !auth_instance_names
......@@ -91,6 +82,16 @@ module Make (N : CONFIG) = struct
module Register (C : CONT_SERVICE) (T : TEMPLATES) : EMPTY = struct
let on_success user_domain user_handlers user_name () =
security_log (fun () ->
Printf.sprintf "%s successfully logged on %s using %s"
user_name N.name user_domain
) >>
let user_user = {user_domain; user_name} in
let logged_user = {user_user; user_handlers} in
Eliom_reference.set user (Some logged_user) >>
C.cont () >>= Eliom_registration.Redirection.send
let () = List.iter (fun auth_instance ->
let {
auth_system = name;
......@@ -110,8 +111,8 @@ module Make (N : CONFIG) = struct
let name = instance
let path = N.path @ ["auth"; instance]
end in
let module A = (val auth : AUTH_SERVICE) (N) (C) (T) in
let i = (module A : AUTH_INSTANCE) in
let module A = (val auth : AUTH_SERVICE) (N) (T) in
let i = (module A : AUTH_HANDLERS) in
Hashtbl.add auth_instances instance i;
auth_instance_names := instance :: !auth_instance_names
)
......@@ -123,8 +124,8 @@ module Make (N : CONFIG) = struct
let use name =
try
let i = Hashtbl.find auth_instances name in
let module A = (val i : AUTH_INSTANCE) in
A.handler ~on_success:(on_success name) ()
let module A = (val i : AUTH_HANDLERS) in
A.login (on_success name i) ()
with Not_found -> fail_http 404
in
match service with
......@@ -135,19 +136,24 @@ module Make (N : CONFIG) = struct
| _ -> T.login_choose () >>= Eliom_registration.Html5.send
)
let () = Eliom_registration.Redirection.register
let () = Eliom_registration.Any.register
~service:Services.logout
(fun () () ->
lwt u = Eliom_reference.get user in
(* should ballot be unset here or not? *)
Eliom_reference.unset user >>
match u with
| Some u ->
let module L = (val u.user_logout) in
security_log (fun () ->
string_of_user u.user_user ^ " logged out"
) >> L.cont ()
| _ -> C.cont ()
| Some u ->
security_log (fun () ->
string_of_user u.user_user ^ " logged out"
) >>
let module A = (val u.user_handlers) in
let cont () () =
C.cont () >>= Eliom_registration.Redirection.send
in
A.logout cont ()
| _ ->
C.cont () >>= Eliom_registration.Redirection.send
)
end
......
......@@ -19,7 +19,9 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Web_signatures
open Web_common
type config = unit
......@@ -33,18 +35,16 @@ let parse_config ~instance ~attributes =
"invalid configuration for instance %s of auth/%s"
instance name
module Make (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = struct
module Make (N : NAME) (T : TEMPLATES) : AUTH_HANDLERS = struct
let service = Eliom_service.service
~path:N.path
~get_params:Eliom_parameter.unit
()
let user_logout = (module S : CONT_SERVICE)
let on_success_ref = Eliom_reference.eref
let login_cont = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
(fun ~user_name ~user_logout -> Lwt.return ())
None
let () = Eliom_registration.Html5.register ~service
(fun () () ->
......@@ -55,19 +55,24 @@ module Make (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = stru
~fallback:service
~post_params ()
in
let () = Eliom_registration.Redirection.register ~service
let () = Eliom_registration.Any.register ~service
~scope:Eliom_common.default_session_scope
(fun () user_name ->
lwt on_success = Eliom_reference.get on_success_ref in
on_success ~user_name ~user_logout >>
S.cont ())
match_lwt Eliom_reference.get login_cont with
| Some cont ->
Eliom_reference.unset login_cont >>
cont user_name ()
| None -> fail_http 400
)
in T.login_dummy ~service ()
)
let handler ~on_success () =
Eliom_reference.set on_success_ref on_success >>
let login cont () =
Eliom_reference.set login_cont (Some cont) >>
Eliom_registration.Redirection.send service
let logout cont () = cont () ()
end
let make () = (module Make : AUTH_SERVICE)
......
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Util
open Web_signatures
open Web_common
......@@ -39,7 +40,7 @@ module type CONFIG = sig
val db : string
end
module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = struct
module Make (C : CONFIG) (N : NAME) (T : TEMPLATES) : AUTH_HANDLERS = struct
let service = Eliom_service.service
~path:N.path
......@@ -54,11 +55,9 @@ module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_IN
| _ -> failwith ("error while parsing db file for " ^ N.name)
) SMap.empty (Csv.load C.db)
let user_logout = (module S : CONT_SERVICE)
let on_success_ref = Eliom_reference.eref
let login_cont = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
(fun ~user_name ~user_logout -> Lwt.return ())
None
let () = Eliom_registration.Html5.register ~service
(fun () () ->
......@@ -71,7 +70,7 @@ module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_IN
~fallback:service
~post_params ()
in
let () = Eliom_registration.Redirection.register ~service
let () = Eliom_registration.Any.register ~service
~scope:Eliom_common.default_session_scope
(fun () (user_name, password) ->
if (
......@@ -80,17 +79,21 @@ module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_IN
sha256_hex (salt ^ password) = hashed
with Not_found -> false
) then (
lwt on_success = Eliom_reference.get on_success_ref in
on_success ~user_name ~user_logout >>
S.cont ()
match_lwt Eliom_reference.get login_cont with
| Some cont ->
Eliom_reference.unset login_cont >>
cont user_name ()
| None -> fail_http 400
) else forbidden ())
in T.login_password ~service ()
)
let handler ~on_success () =
Eliom_reference.set on_success_ref on_success >>
let login cont () =
Eliom_reference.set login_cont (Some cont) >>
Eliom_registration.Redirection.send service
let logout cont () = cont () ()
end
let make {db} =
......
......@@ -168,9 +168,21 @@ module type CONT_SERVICE = sig
Eliom_service.service Lwt.t
end
type service_handler = unit ->
(Eliom_registration.browser_content,
Eliom_registration.http_service
) Eliom_registration.kind Lwt.t
type 'a service_cont = ('a -> service_handler) -> service_handler
module type AUTH_HANDLERS = sig
val login : string service_cont
val logout : unit service_cont
end
type logged_user = {
user_user : user;
user_logout : (module CONT_SERVICE);
user_handlers : (module AUTH_HANDLERS);
}
module type AUTH_SERVICES = sig
......@@ -307,24 +319,10 @@ module type NAME = sig
val path : string list
end
type on_success_handler =
user_name:string -> user_logout:(module CONT_SERVICE) -> unit Lwt.t
module type AUTH_INSTANCE = sig
val handler :
on_success:on_success_handler -> unit ->
(Eliom_registration.browser_content,
Eliom_registration.http_service)
Eliom_registration.kind Lwt.t
end
module type AUTH_SERVICE =
functor (N : NAME) ->
functor (S : CONT_SERVICE) ->
functor (T : TEMPLATES) ->
AUTH_INSTANCE
AUTH_HANDLERS
module type AUTH_SYSTEM = sig
type config
......
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