Commit 14d08b4c authored by Stephane Glondu's avatar Stephane Glondu

Simplify handling of authentication configurations

parent 81bd83b0
Pipeline #53148 passed with stages
in 11 minutes and 43 seconds
......@@ -88,8 +88,8 @@ let password_handler () (name, password) =
match uuid with
| None ->
begin
match config with
| db :: _ -> check_password_with_file db name password
match List.assoc_opt "db" config with
| Some db -> check_password_with_file db name password
| _ -> failwith "invalid configuration for admin site"
end
| Some uuid ->
......@@ -106,10 +106,16 @@ let password_handler () (name, password) =
let () = Eliom_registration.Any.register ~service:password_post password_handler
let does_allow_signups c =
match List.assoc_opt "allowsignups" c with
| Some x -> bool_of_string x
| None -> false
let get_password_db_fname () =
let rec find = function
| [] -> None
| (_, ("password", db :: allowsignups :: _)) :: _ when bool_of_string allowsignups -> Some db
| { auth_system = "password"; auth_config = c; _ } :: _
when does_allow_signups c -> List.assoc_opt "db" c
| _ :: xs -> find xs
in find !site_auth_config
......@@ -230,8 +236,8 @@ let cas_handler ticket () =
let () = Eliom_registration.Any.register ~service:login_cas cas_handler
let cas_login_handler config () =
match config with
| [server] ->
match List.assoc_opt "server" config with
| Some server ->
let%lwt () = Eliom_reference.set cas_server (Some server) in
let cas_login = Eliom_service.extern
~prefix:server
......@@ -333,8 +339,9 @@ let split_prefix_path url =
String.sub url 0 i, [String.sub url (i+1) (n-i-1)]
let oidc_login_handler config () =
match config with
| [server; client_id; client_secret] ->
let get x = List.assoc_opt x config in
match get "server", get "client_id", get "client_secret" with
| Some server, Some client_id, Some client_secret ->
let%lwt ocfg = get_oidc_configuration server in
let%lwt state = generate_token () in
let%lwt () = Eliom_reference.set oidc_state (Some (ocfg, client_id, client_secret, state)) in
......@@ -362,6 +369,11 @@ let get_login_handler service uuid auth_system config =
| "oidc" -> oidc_login_handler config ()
| _ -> fail_http 404
let rec find_auth_instance x = function
| [] -> raise Not_found
| { auth_instance = i; auth_system = s; auth_config = c } :: _ when i = x -> s, c
| _ :: xs -> find_auth_instance x xs
let login_handler service uuid =
let myself service =
match uuid with
......@@ -380,13 +392,13 @@ let login_handler service uuid =
match service with
| Some s ->
let%lwt auth_system, config =
try return @@ List.assoc s c
try return @@ find_auth_instance s c
with Not_found -> fail_http 404
in
get_login_handler s uuid auth_system config
| None ->
match c with
| [s, _] -> Eliom_registration.(Redirection.send (Redirection (myself (Some s))))
| [s] -> Eliom_registration.(Redirection.send (Redirection (myself (Some s.auth_instance))))
| _ ->
let builder =
match uuid with
......@@ -395,7 +407,7 @@ let login_handler service uuid =
| Some u -> fun s ->
preapply Web_services.election_login ((u, ()), Some s)
in
Web_templates.login_choose (List.map fst c) builder () >>=
Web_templates.login_choose (List.map (fun x -> x.auth_instance) c) builder () >>=
Eliom_registration.Html.send
let logout_handler () =
......
......@@ -348,28 +348,6 @@ let rmdir dir =
let%lwt _ = Lwt_process.exec command in
return_unit
let compile_auth_config {auth_system; auth_instance; auth_config} =
match auth_system with
| "password" ->
let auth_config =
match auth_config with
| [] ->
(* election configuration *)
[]
| _ ->
(* site configuration *)
let db = List.assoc "db" auth_config in
let allowsignups =
match List.assoc_opt "allowsignups" auth_config with
| None -> false
| Some x -> bool_of_string x
in
[db; string_of_bool allowsignups]
in
auth_instance, (auth_system, auth_config)
| _ ->
auth_instance, (auth_system, List.map snd auth_config)
let urlize = String.map (function '+' -> '-' | '/' -> '_' | c -> c)
let unurlize = String.map (function '-' -> '+' | '_' -> '/' | c -> c)
......
......@@ -23,7 +23,7 @@ open Signatures
open Serializable_t
open Web_serializable_t
val site_auth_config : (string * (string * string list)) list ref
val site_auth_config : auth_config list ref
val spool_dir : string ref
val server_mail : string ref
val return_path : string option ref
......@@ -129,8 +129,6 @@ val write_file : ?uuid:uuid -> string -> string list -> unit Lwt.t
val cleanup_file : string -> unit Lwt.t
val rmdir : string -> unit Lwt.t
val compile_auth_config : auth_config -> string * (string * string list)
val urlize : string -> string
val unurlize : string -> string
......
......@@ -128,4 +128,4 @@ let%lwt default_group =
let () = Web_site.source_file := source_file
let () = Web_common.spool_dir := spool_dir
let () = Web_site.default_group := default_group
let () = Web_common.site_auth_config := (List.rev_map compile_auth_config !auth_instances)
let () = Web_common.site_auth_config := List.rev !auth_instances
......@@ -141,7 +141,7 @@ let get_auth_config uuid =
let%lwt metadata = get_election_metadata uuid in
match metadata.e_auth_config with
| None -> return []
| Some x -> return (List.map compile_auth_config x)
| Some x -> return x
type election_kind =
[ `Draft
......
......@@ -45,7 +45,7 @@ val set_partial_decryptions : uuid -> partial_decryptions -> unit Lwt.t
val get_decryption_tokens : uuid -> decryption_tokens option Lwt.t
val set_decryption_tokens : uuid -> decryption_tokens -> unit Lwt.t
val get_auth_config : uuid -> (string * (string * string list)) list Lwt.t
val get_auth_config : uuid -> auth_config list Lwt.t
val get_raw_election : uuid -> string option Lwt.t
val get_election_metadata : uuid -> metadata Lwt.t
......
......@@ -98,7 +98,7 @@ end
module Site_auth = struct
let get_user () = Web_state.get_site_user ()
let get_auth_systems () = return (List.map fst !site_auth_config)
let get_auth_systems () = return (List.map (fun x -> x.auth_instance) !site_auth_config)
end
let site_links = (module Site_links : AUTH_LINKS)
......@@ -1550,7 +1550,7 @@ let election_login_box uuid =
Web_state.get_election_user uuid
let get_auth_systems () =
let%lwt l = Web_persist.get_auth_config uuid in
return @@ List.map fst l
return @@ List.map (fun x -> x.auth_instance) l
end in
let auth = (module A : AUTH_SERVICES) in
let module L = struct
......
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