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

Generic authentication

This revision should be bisimilar to the previous one.

Summary:
 - each auth system registers $name and $service
 - $service stores a logout handler in Auth_common.user
 - the generic login service redirects to $service if its parameter
   matches $name
 - the generic logout service clears out Auth_common.user and invokes
   the stored logout handler
 - the default auth system is the one registered last
 - Templates directly query Auth_common for available auth systems

TODO:
 - enforce user_type = $name (currently not the case for CAS)
 - export Auth_common.register_auth_system
 - move existing auth systems out of Auth_common
 - integrate with config parsing
 - rework CAS
 - generic login should do security_log
 - do admin login
parent ac1999b9
......@@ -31,6 +31,7 @@ type user = {
type logged_user = {
user_admin : bool;
user_user : user;
user_logout : (module LOGOUT_HANDLER);
}
let string_of_user {user_type; user_name} =
......@@ -62,112 +63,220 @@ module Make (X : EMPTY) = struct
end
module Register (C : AUTH_CONFIG) (S : ALL_SERVICES) (T : TEMPLATES) = struct
let next_lf str i =
try Some (String.index_from str i '\n')
with Not_found -> None
let login_dummy = Eliom_service.service
~path:["login-dummy"]
~get_params:Eliom_parameter.unit
()
let auth_system_map = ref []
let login_password = Eliom_service.service
~path:["login-password"]
~get_params:Eliom_parameter.unit
()
let register_auth_system name service =
auth_system_map := (name, service) :: !auth_system_map
let login_admin = Eliom_service.service
~path:["login-admin"]
~get_params:Eliom_parameter.unit
()
let auth_systems = lazy (List.map fst !auth_system_map)
let cas_login = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "login"]
~get_params:Eliom_parameter.(string "service")
()
let get_auth_systems () = Lazy.force auth_systems
let cas_logout = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "logout"]
~get_params:Eliom_parameter.(string "service")
()
let get_default_auth_system () =
match !auth_system_map with
| [] -> fail_http 404
| (name, _) :: _ -> Lwt.return name
let cas_validate = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "validate"]
~get_params:Eliom_parameter.(string "service" ** string "ticket")
()
module Register (C : AUTH_CONFIG) (S : ALL_SERVICES) (T : TEMPLATES) = struct
let login_cas = Eliom_service.service
~path:["login-cas"]
~get_params:Eliom_parameter.(opt (string "ticket"))
()
let () = Eliom_registration.Redirection.register ~service:S.login
(fun service () ->
lwt x = match service with
| None -> get_default_auth_system ()
| Some x -> Lwt.return x
in
try Lwt.return (List.assoc x !auth_system_map)
with Not_found -> fail_http 404
)
let login_default =
if C.enable_dummy then login_dummy
else if C.password_db <> None then login_password
else Eliom_service.preapply login_cas None
let () = Eliom_registration.Redirection.register ~service:S.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.logout ()
| _ -> S.get ()
)
let auth_systems =
(if C.enable_cas then ["CAS", "cas"] else []) @
(if C.password_db <> None then ["password", "password"] else []) @
(if C.enable_dummy then ["dummy", "dummy"] else [])
module DefaultLogout : LOGOUT_HANDLER = struct
let logout = S.get
end
let () = Eliom_registration.Html5.register
~service:login_dummy
(fun () () ->
if C.enable_dummy then (
let service = create_string_login
~fallback:login_dummy
~post_params:Eliom_parameter.(string "username")
let () = if C.enable_dummy then (
let user_admin = false in
let user_type = "dummy" in
let user_logout = (module DefaultLogout : LOGOUT_HANDLER) in
let service = Eliom_service.service
~path:["login-dummy"]
~get_params:Eliom_parameter.unit
()
in
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
let () = Eliom_registration.Redirection.register ~service
~scope:Eliom_common.default_session_scope
(fun () user_name ->
let user_type = "dummy" in
let user_user = {user_type; user_name} in
let user_admin = false in
Eliom_reference.set user (Some {user_admin; user_user}) >>
let logged_user = {user_admin; user_user; user_logout} in
Eliom_reference.set user (Some logged_user) >>
Web_common.security_log (fun () ->
user_name ^ " successfully logged in using dummy"
) >>
S.get ())
in
T.string_login ~auth_systems ~service ~kind:`Dummy
) else Web_common.fail_http 404
)
) >> S.get ())
in T.string_login ~service ~kind:`Dummy
)
in register_auth_system "dummy" service
)
let () = Eliom_registration.Html5.register
~service:login_password
(fun () () ->
match C.password_db with
| Some db ->
let service = create_string_login
~fallback:login_password
~post_params:Eliom_parameter.(string "username" ** string "password")
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_type = "password" in
let user_user = {user_type; user_name} in
let user_admin = false in
Eliom_reference.set user (Some {user_admin; user_user}) >>
security_log (fun () ->
user_name ^ " successfully logged in using password"
) >> S.get ()
) else forbidden ())
in
T.password_login ~auth_systems ~service
| None -> fail_http 404
)
let () = match C.password_db with
| None -> ()
| Some db ->
let user_admin = false in
let user_type = "password" in
let user_logout = (module DefaultLogout : LOGOUT_HANDLER) in
let service = Eliom_service.service
~path:["login-password"]
~get_params:Eliom_parameter.unit
()
in
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}) >>
security_log (fun () ->
user_name ^ " successfully logged in using password"
) >> S.get ()
) else forbidden ())
in T.password_login ~service
)
in register_auth_system "password" service
let () = if C.enable_cas then (
let cas_login = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "login"]
~get_params:Eliom_parameter.(string "service")
()
in
let cas_logout = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "logout"]
~get_params:Eliom_parameter.(string "service")
()
in
let cas_validate = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "validate"]
~get_params:Eliom_parameter.(string "service" ** string "ticket")
()
in
let login_cas = Eliom_service.service
~path:["login-cas"]
~get_params:Eliom_parameter.(opt (string "ticket"))
()
in
let () = Eliom_registration.Redirection.register ~service:login_cas
(fun ticket () ->
match ticket with
| Some x ->
let me =
let service = Eliom_service.preapply login_cas None in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
C.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_type = "cas" in
let user_user = {user_type; user_name} in
let module L : LOGOUT_HANDLER = struct
let logout () =
lwt service = S.get () in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = C.rewrite_prefix uri in
security_log (fun () ->
string_of_user user_user ^ " logged out, redirecting to CAS"
) >>
Lwt.return (Eliom_service.preapply cas_logout uri)
end in
let user_logout = (module L : LOGOUT_HANDLER) in
let user_admin = false in
security_log (fun () ->
user_name ^ " successfully logged in using CAS"
) >>
Eliom_reference.set user
(Some {user_admin; user_user; user_logout}) >>
S.get ()
| None -> fail_http 502
)
| "no" -> fail_http 401
| _ -> fail_http 502
)
| None -> fail_http 502
)
| None -> fail_http 502
)
| None ->
let service = Eliom_service.preapply login_cas None in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = C.rewrite_prefix uri in
Lwt.return (Eliom_service.preapply cas_login uri)
)
in
let service = Eliom_service.preapply login_cas None in
register_auth_system "CAS" service
)
let login_admin = Eliom_service.service
~path:["login-admin"]
~get_params:Eliom_parameter.unit
()
let () = Eliom_registration.Html5.register
~service:login_admin
......@@ -182,9 +291,10 @@ module Register (C : AUTH_CONFIG) (S : ALL_SERVICES) (T : TEMPLATES) = struct
(fun () user_name ->
if sha256_hex user_name = C.admin_hash then (
let user_type = "password" in
let user_logout = (module DefaultLogout : LOGOUT_HANDLER) in
let user_user = {user_type; user_name} in
let user_admin = true in
Eliom_reference.set user (Some {user_admin; user_user}) >>
Eliom_reference.set user (Some {user_admin; user_user; user_logout}) >>
security_log (fun () ->
"admin successfully logged in"
) >>
......@@ -192,94 +302,7 @@ module Register (C : AUTH_CONFIG) (S : ALL_SERVICES) (T : TEMPLATES) = struct
) else forbidden ()
)
in
T.string_login ~auth_systems ~service ~kind:`Admin
)
let next_lf str i =
try Some (String.index_from str i '\n')
with Not_found -> None
let () = Eliom_registration.Redirection.register
~service:login_cas
(fun ticket () -> match ticket with
| Some x ->
let me =
let service = Eliom_service.preapply login_cas None in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
C.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_type = "cas" in
let user_user = {user_type; user_name} in
let user_admin = false in
security_log (fun () ->
user_name ^ " successfully logged in using CAS"
) >>
Eliom_reference.set user
(Some {user_admin; user_user}) >>
S.get ()
| None -> fail_http 502
)
| "no" -> fail_http 401
| _ -> fail_http 502
)
| None -> fail_http 502
)
| None -> fail_http 502
)
| None ->
let service = Eliom_service.preapply login_cas None in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = C.rewrite_prefix uri in
Lwt.return (Eliom_service.preapply cas_login uri)
)
let () = Eliom_registration.Redirection.register ~service:S.login
(fun service () ->
match service with
| None -> Lwt.return login_default
| Some "dummy" -> Lwt.return login_dummy
| Some "cas" -> Lwt.return (Eliom_service.preapply login_cas None)
| Some "password" -> Lwt.return login_password
| _ -> fail_http 404
)
let () = Eliom_registration.Redirection.register ~service:S.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 ->
if u.user_user.user_type = "cas" then (
lwt service = S.get () in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = C.rewrite_prefix uri in
security_log (fun () ->
string_of_user u.user_user ^ " logged out, redirecting to CAS"
) >>
Lwt.return (Eliom_service.preapply cas_logout uri)
) else (
security_log (fun () ->
string_of_user u.user_user ^ " logged out"
) >> S.get ()
)
| _ -> S.get ()
T.string_login ~service ~kind:`Admin
)
end
......@@ -19,6 +19,8 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Web_signatures
type user = {
user_type : string;
user_name : string;
......@@ -27,12 +29,13 @@ type user = {
type logged_user = {
user_admin : bool;
user_user : user;
user_logout : (module LOGOUT_HANDLER);
}
val string_of_user : user -> string
val user : logged_user option Eliom_reference.eref
open Web_signatures
val get_auth_systems : unit -> string list
module Make (X : EMPTY) : AUTH_SERVICES
module Register (C : AUTH_CONFIG) (S : ALL_SERVICES) (T : TEMPLATES) : AUTH_SYSTEMS
module Register (C : AUTH_CONFIG) (S : ALL_SERVICES) (T : TEMPLATES) : EMPTY
......@@ -367,7 +367,7 @@ let () =
Eliom_reference.unset Services.ballot >>
Eliom_reference.unset Services.saved_service >>
lwt featured = get_featured_elections () in
A.(T.index ~auth_systems ~featured)
T.index ~featured
)
| Some uuid -> Eliom_registration.Redirection.register ~service:S.home
(fun () () ->
......@@ -492,7 +492,7 @@ let () = Eliom_registration.Html5.register
(fun uuid election user () ->
Eliom_reference.unset Services.ballot >>
Eliom_reference.set Services.saved_service (Services.Election uuid) >>
A.(T.election_view ~auth_systems ~election ~user)
T.election_view ~election ~user
)
)
......@@ -528,7 +528,7 @@ let do_cast election uuid () =
with Error e -> return (`Error e)
in
Eliom_reference.unset Services.ballot >>
A.(T.do_cast_ballot ~auth_systems ~election ~result)
T.do_cast_ballot ~election ~result
) else forbidden ()
| None -> forbidden ()
end
......@@ -547,7 +547,7 @@ let ballot_received uuid election user =
in service
in
lwt can_vote = check_acl can_vote election.election_web user in
A.(T.ballot_received ~auth_systems ~election ~confirm ~user ~can_vote)
T.ballot_received ~election ~confirm ~user ~can_vote
let () = Eliom_registration.Html5.register
......@@ -556,7 +556,7 @@ let () = Eliom_registration.Html5.register
(fun uuid election user () ->
match_lwt Eliom_reference.get Services.ballot with
| Some _ -> ballot_received uuid election user
| None -> A.(T.election_cast_raw ~auth_systems ~election)
| None -> T.election_cast_raw ~election
)
)
......@@ -586,7 +586,7 @@ let () = Eliom_registration.Html5.register
match user with
| Some u when u.Auth_common.user_admin ->
lwt election = get_election_by_uuid uuid in
A.(T.election_update_credential ~auth_systems ~election)
T.election_update_credential ~election
| _ -> forbidden ()
)
......
......@@ -34,7 +34,7 @@ let format_user u =
module Make (S : Web_signatures.ALL_SERVICES) = struct
let base ~auth_systems ~title ~content =
let base ~title ~content =
lwt user = Eliom_reference.get Auth_common.user in
Lwt.return (html ~a:[a_dir `Ltr; a_xml_lang "en"]
(head (Eliom_content.Html5.F.title (pcdata title)) [])
......@@ -63,10 +63,10 @@ let base ~auth_systems ~title ~content =
div [
pcdata "Not logged in.";
];
let auth_systems = List.map (fun (name, service) ->
let service = Eliom_service.preapply S.login (Some service) in
let auth_systems = List.map (fun name ->
let service = Eliom_service.preapply S.login (Some name) in
a ~service [pcdata name] ()
) auth_systems in
) (Auth_common.get_auth_systems ()) in
div (
[ pcdata "Login: " ] @
list_join (pcdata ", ") auth_systems @
......@@ -95,7 +95,7 @@ let format_one_featured_election e =
p [pcdata e.e_description];
]
let index ~auth_systems ~featured =
let index ~featured =
lwt user = Eliom_reference.get Auth_common.user in
let featured_box = match featured with
| _::_ ->
......@@ -115,7 +115,7 @@ let index ~auth_systems ~featured =
featured_box;
];
] in
base ~auth_systems ~title:site_title ~content
base ~title:site_title ~content
let string_login ~kind ~service =
let title, field_name, input_type = match kind with
......@@ -177,7 +177,7 @@ let make_button ~service contents =
uri
contents
let election_view ~auth_systems ~election ~user =
let election_view ~election ~user =
let open Web_election in
let params = election.election.e_params in
let service = S.election_file params Services.ESRaw in
......@@ -261,7 +261,7 @@ let election_view ~auth_systems ~election ~user =
br ();
audit_info;
] in
base ~auth_systems ~title:params.e_name ~content
base ~title:params.e_name ~content
let election_cast_raw ~election =
let open Web_election in
......
......@@ -153,13 +153,6 @@ module type AUTH_SERVICES = sig
end
module type AUTH_SYSTEMS = sig
val auth_systems : (string * string) list
end
module type TEMPLATES = sig
val string_login :
......@@ -170,7 +163,6 @@ module type TEMPLATES = sig
Eliom_parameter.param_name,
[< Eliom_service.registrable ], 'c)
Eliom_service.service ->
auth_systems:(string * string) list ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
val password_login :
......@@ -182,7 +174,6 @@ module type TEMPLATES = sig
Eliom_parameter.param_name,
[< Eliom_service.registrable ], 'c)
Eliom_service.service ->
auth_systems:(string * string) list ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
end
......@@ -192,3 +183,15 @@ module type ALL_SERVICES = sig
include MAIN_SERVICES
include AUTH_SERVICES
end
module type LOGOUT_HANDLER = sig
val logout :
unit ->
(unit, unit,
[> `Attached of
([> `External | `Internal of [> `Service ] ], [> `Get ])
Eliom_service.a_s ],
[ `WithoutSuffix ], unit, unit, Eliom_service.registrable, 'a)
Eliom_service.service Lwt.t
end
Markdown is supported
0% or .