Commit d7aaa27d authored by Stephane Glondu's avatar Stephane Glondu

Remove traces of old authentication system

parent 3482da56
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Web_signatures
open Web_common
let next_lf str i =
try Some (String.index_from str i '\n')
with Not_found -> None
type config = { server : string }
module type CONFIG = sig
val server : string
end
module Make (C : CONFIG) (N : NAME) (S : AUTH_SERVICES) : AUTH_INSTANCE_HANDLERS = struct
let scope = Eliom_common.default_session_scope
let cas_login = Eliom_service.Http.external_service
~prefix:C.server
~path:["login"]
~get_params:Eliom_parameter.(string "service" ** opt (bool "renew"))
()
let cas_logout = Eliom_service.Http.external_service
~prefix:C.server
~path:["logout"]
~get_params:Eliom_parameter.(string "service")
()
let cas_validate = Eliom_service.Http.external_service
~prefix:C.server
~path:["validate"]
~get_params:Eliom_parameter.(string "service" ** string "ticket")
()
let login_cas = Eliom_service.Http.service
~path:N.path
~get_params:Eliom_parameter.(opt (string "ticket"))
()
let service = Eliom_service.preapply login_cas None
let self =
lazy (Eliom_uri.make_string_uri ~absolute:true ~service () |> rewrite_prefix)
let login_cont = Eliom_reference.eref ~scope None
let logout_cont = Eliom_reference.eref ~scope None
let () = Eliom_registration.Any.register
~service:login_cas
(fun ticket () ->
match ticket with
| Some x ->
let validation =
let service = Eliom_service.preapply cas_validate (Lazy.force self, 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
(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
| _ -> fail_http 502
)
| None -> fail_http 502
)
| None -> fail_http 502
)
| None ->
match_lwt Eliom_reference.get logout_cont with
| None ->
lwt () = security_log (fun () ->
Printf.sprintf
"user is trying to log in, redirecting to CAS [%s]"
C.server
) in
Eliom_service.preapply cas_login (Lazy.force self, Some true) |>
Eliom_registration.Redirection.send
| Some cont ->
Eliom_reference.unset logout_cont >>
cont () ()
)
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 (Lazy.force self) |>
Eliom_registration.Redirection.send
end
let name = "cas"
let parse_config ~attributes =
match attributes with
| ["server", server] -> Some {server}
| _ -> None
let make {server} =
let module C = struct let server = server end in
(module Make (C) : AUTH_MAKE_INSTANCE)
type c = config
module A : AUTH_SYSTEM = struct
type config = c
let name = name
let parse_config = parse_config
let make = make
end
let () = Web_auth.register_auth_system (module A : AUTH_SYSTEM)
type config = { server : string }
include Web_signatures.AUTH_SYSTEM with type config := config
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Web_signatures
open Web_common
type config = unit
let name = "dummy"
let parse_config ~attributes =
match attributes with
| [] -> Some ()
| _ -> None
module Make (N : NAME) (S : AUTH_SERVICES) : AUTH_INSTANCE_HANDLERS = struct
module L = Web_auth.MakeLinks (N)
let scope = Eliom_common.default_session_scope
let service = Eliom_service.Http.service
~path:N.path
~get_params:Eliom_parameter.unit
()
let login_cont = Eliom_reference.eref ~scope None
let () = Eliom_registration.Html5.register ~service
(fun () () ->
let post_params = Eliom_parameter.(string "username") in
let service = Eliom_service.Http.post_coservice
~csrf_safe:true
~csrf_scope:scope
~fallback:service
~post_params ()
in
let () = Eliom_registration.Any.register ~service ~scope
(fun () user_name ->
match_lwt Eliom_reference.get login_cont with
| Some cont ->
Eliom_reference.unset login_cont >>
cont user_name ()
| None -> fail_http 400
)
in Web_templates.dummy ~service (module S : AUTH_SERVICES) (module L : AUTH_LINKS) ()
)
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_MAKE_INSTANCE)
module A : AUTH_SYSTEM = struct
type config = unit
let name = name
let parse_config = parse_config
let make = make
end
let () = Web_auth.register_auth_system (module A : AUTH_SYSTEM)
type config = unit
include Web_signatures.AUTH_SYSTEM with type config := config
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Platform
open Common
open Web_signatures
open Web_common
type config = { db : string }
let name = "password"
let parse_config ~attributes =
match attributes with
| ["db", db] -> Some {db}
| _ -> None
module type CONFIG = sig
val db : string
end
let load_db name file =
(* FIXME: not cooperative *)
List.fold_left (fun accu line ->
match line with
| username :: salt :: password :: _ ->
SMap.add username (salt, password) accu
| _ -> failwith ("error while parsing db file for " ^ name)
) SMap.empty (Csv.load file)
let ( / ) = Filename.concat
module Make (C : CONFIG) (N : NAME) (S : AUTH_SERVICES) : AUTH_INSTANCE_HANDLERS = struct
module L = Web_auth.MakeLinks (N)
let scope = Eliom_common.default_session_scope
let service = Eliom_service.Http.service
~path:N.path
~get_params:Eliom_parameter.unit
()
let db =
ref @@ match N.kind with
| `Site -> `Production (load_db N.name C.db)
| `Election (_, dir) ->
(* hash the user-input name to avoid all kinds of injection *)
let fname = dir / sha256_hex C.db in
try
`Production (load_db N.name fname)
with _ ->
(* Maybe we should filter the kind of error...? *)
`Bootstrap fname
let login_cont = Eliom_reference.eref ~scope None
let production_service_handler db =
let post_params = Eliom_parameter.(
string "username" ** string "password"
) in
let service = Eliom_service.Http.post_coservice
~csrf_safe:true
~csrf_scope:scope
~fallback:service
~post_params ()
in
let () = Eliom_registration.Any.register ~service ~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 (
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
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
let upload_service = Eliom_service.Http.post_coservice
~csrf_safe:true
~csrf_scope:scope
~fallback:service
~post_params ()
in
let () = Eliom_registration.Any.register ~service:upload_service ~scope
(fun () password_db ->
match !db with
| `Bootstrap db_fname ->
let fname = password_db.Ocsigen_extensions.tmp_filename in
let the_db = load_db N.name fname in
(* loading was successful, we copy the file for future reference *)
lwt () =
Lwt_io.(with_file Output db_fname (fun oc ->
with_file Input fname (fun ic ->
read_chars ic |> write_chars oc
)
))
in
db := `Production the_db;
Eliom_registration.Redirection.send service
| `Production _ -> forbidden ()
)
in
Web_templates.upload_password_db ~service:upload_service (module S : AUTH_SERVICES) (module L : AUTH_LINKS) ()
let () = Eliom_registration.Html5.register ~service
(fun () () ->
match !db with
| `Bootstrap _ -> bootstrap_service_handler ()
| `Production db -> production_service_handler db
)
let login cont () =
Eliom_reference.set login_cont (Some cont) >>
Eliom_registration.Redirection.send service
let logout cont () = cont () ()
end
let make {db} =
let module C = struct let db = db end in
(module Make (C) : AUTH_MAKE_INSTANCE)
type c = config
module A : AUTH_SYSTEM = struct
type config = c
let name = name
let parse_config = parse_config
let make = make
end
let () = Web_auth.register_auth_system (module A : AUTH_SYSTEM)
type config = { db : string }
include Web_signatures.AUTH_SYSTEM with type config := config
......@@ -13,10 +13,6 @@ Web_persist
Web_services
Web_auth_state
Web_templates
Web_auth
Auth_dummy
Auth_password
Auth_cas
Web_site_auth
Web_election
Web_site
......
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Serializable_t
open Signatures
open Common
open Web_serializable_t
open Web_signatures
open Web_common
let auth_systems = Hashtbl.create 10
let register_auth_system auth_system =
let module X = (val auth_system : AUTH_SYSTEM) in
if Hashtbl.mem auth_systems X.name then (
Printf.ksprintf failwith
"multiple authentication systems with name %s"
X.name
) else (
Hashtbl.add auth_systems X.name auth_system
)
type logged_user = {
user_user : user;
user_handlers : (module AUTH_INSTANCE_HANDLERS);
}
module MakeLinks (N : NAME) = struct
let login, logout =
match N.kind with
| `Site ->
(fun x -> Eliom_service.preapply Web_services.site_login x),
(Eliom_service.preapply Web_services.site_logout ())
| `Election (uuid, _) ->
(fun x ->
Eliom_service.preapply
Web_services.election_login
((uuid, ()), x)),
(Eliom_service.preapply
Web_services.election_logout
(uuid, ()))
end
module Make (N : NAME) = struct
module L = MakeLinks (N)
let links = (module L : AUTH_LINKS)
let scope = Eliom_common.default_session_scope
let auth_instances = Hashtbl.create 10
let auth_instance_names = ref []
let user = Eliom_reference.eref ~scope None
let do_login_using user_domain cont =
try
let user_handlers = Hashtbl.find auth_instances user_domain in
let cont user_name () =
let user_user = {user_domain; user_name} in
let logged_user = {user_user; user_handlers} in
security_log (fun () ->
Printf.sprintf "[%s] %s logged in"
N.name (string_of_user user_user)
) >>
Eliom_reference.set user (Some logged_user) >>
cont () ()
in
let module A = (val user_handlers : AUTH_INSTANCE_HANDLERS) in
A.login cont ()
with Not_found -> fail_http 404
module Services : AUTH_SERVICES = struct
let auth_realm = N.name
let get_auth_systems () = return !auth_instance_names
let get_user () =
match_lwt Eliom_reference.get user with
| Some u -> return (Some u.user_user)
| None -> return None
end
let auth_services = (module Services : AUTH_SERVICES)
let configure xs =
List.iter
(fun auth_instance ->
let {
auth_system = name;
auth_instance = instance;
auth_config = attributes;
} = auth_instance in
if Hashtbl.mem auth_instances instance then (
Printf.ksprintf
failwith
"multiple instances with name %s"
instance
) else (
let auth_system = Hashtbl.find auth_systems name in
let module X = (val auth_system : AUTH_SYSTEM) in
let config =
match X.parse_config ~attributes with
| Some x -> x
| None ->
Printf.ksprintf
failwith
"invalid configuration for instance %s of auth/%s"
instance X.name
in
let auth = X.make config in
let module N = struct
let name = instance
let path = N.path @ ["auth"; instance]
let kind = N.kind
end in
let module A = (val auth : AUTH_MAKE_INSTANCE) (N) (Services) in
let i = (module A : AUTH_INSTANCE_HANDLERS) in
Hashtbl.add auth_instances instance i;
auth_instance_names := instance :: !auth_instance_names
)
) xs
module Handlers : AUTH_HANDLERS = struct
let login service cont () =
let cont () () =
match service with
| Some name -> do_login_using name cont
| None ->
match !auth_instance_names with
| [name] -> do_login_using name cont
| _ ->
Web_templates.choose auth_services links () >>=
Eliom_registration.Html5.send
in
match_lwt Eliom_reference.get user with
| Some u ->
let module A = (val u.user_handlers) in
A.logout cont ()
| None -> cont () ()
let logout cont () =
match_lwt Eliom_reference.get user with
| Some u ->
security_log (fun () ->
Printf.sprintf "[%s] %s logged out"
N.name (string_of_user u.user_user)
) >>
Eliom_reference.unset user >>
let module A = (val u.user_handlers) in
A.logout cont ()
| None -> cont () ()
end
end
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Serializable_t
open Signatures
open Web_serializable_t
open Web_signatures
val register_auth_system : (module AUTH_SYSTEM) -> unit
module MakeLinks (N : NAME) : AUTH_LINKS
module Make (C : NAME) : sig
val configure : auth_config list -> unit
module Services : AUTH_SERVICES
module Handlers : AUTH_HANDLERS
end
......@@ -66,7 +66,6 @@ let () =
)
| Element ("auth", ["name", auth_instance],