Commit 1bc91691 authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Cleaner configuration parsing

 - Eliom_config.(use get_config instead of parse_config)
 - presence of <source> is no longer technically enforced
 - simplify configuration of auth systems
 - auth systems directly register themselves
parent 4eccfcfb
......@@ -35,8 +35,8 @@
<static dir="_SRCDIR_/ext/booth" />
</site>
<eliom module="_build/src/web/server.cma">
<auth-dummy name="demo"/>
<auth-password name="local" db="demo/password_db.csv"/>
<auth name="demo"><dummy/></auth>
<auth name="local"><password db="demo/password_db.csv"/></auth>
<source file="../belenios.tar.gz"/>
<main-election uuid="6d122f00-2650-4de8-87de-30037a21f943"/>
<log file="_RUNDIR_/log/security.log"/>
......
......@@ -21,12 +21,13 @@
open Web_signatures
open Web_common
open Auth_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
......@@ -122,48 +123,27 @@ module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_IN
end
type instance = {
mutable name : string option;
mutable server : string option;
}
let init () =
let instances = ref [] in
let current_instance = ref None in
let push_current loc =
match !current_instance with
| None -> ()
| Some {name = Some name; server = Some server} ->
let module C : CONFIG = struct
let server = server
end in
instances := (name, (module C : CONFIG)) :: !instances;
current_instance := None
| _ -> failwith ("unexpected case in auth-cas/" ^ loc)
in
let spec =
let open Ocsigen_extensions.Configuration in
[
let init () =
push_current "init";
current_instance := Some {name = None; server = None}
and attributes = [
attribute ~name:"name" ~obligatory:true (fun s ->
match !current_instance with
| Some ({name = None; _} as i) -> i.name <- Some s
| _ -> failwith "unexpected case in auth-cas/name"
);
attribute ~name:"server" ~obligatory:true (fun s ->
match !current_instance with
| Some ({server = None; _} as i) -> i.server <- Some s
| _ -> failwith "unexpected case in auth-cas/server"
);
] in element ~name:"auth-cas" ~init ~attributes ();
]
and exec ~instantiate =
push_current "exec";
List.iter (fun (name, config) ->
let module X = Make ((val config : CONFIG)) in
instantiate name (module X : AUTH_SERVICE)
) !instances
in Auth_common.register_auth_system ~spec ~exec
let name = "cas"
let parse_config ~instance ~attributes =
match attributes with
| ["server", server] -> {server}
| _ ->
Printf.ksprintf failwith
"invalid configuration for instance %s of auth/%s"
instance name
let make {server} =
let module C = struct let server = server end in
(module Make (C) : AUTH_SERVICE)
type c = config
module A : AUTH_SYSTEM = struct
type config = c
let name = name
let parse_config = parse_config
let make = make
end
let () = Auth_common.register_auth_system (module A : AUTH_SYSTEM)
val init : unit -> unit
type config = { server : string }
include Web_signatures.AUTH_SYSTEM with type config := config
......@@ -30,23 +30,33 @@ open Web_common
let string_of_user {user_domain; user_name} =
user_domain ^ ":" ^ user_name
type instantiator = string -> (module AUTH_SERVICE) -> unit
let config_spec = ref []
let config_exec = ref []
let register_auth_system ~spec ~exec =
config_spec := spec @ !config_spec;
config_exec := exec :: !config_exec
let get_config_spec () = !config_spec
(* TODO: make the authentication system more flexible *)
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 auth_instance = {
auth_system : string;
auth_instance : string;
auth_config : (string * string) list;
}
module type CONFIG = sig
include NAME
val instances : auth_instance list
end
module Make (N : NAME) = struct
module Make (N : CONFIG) = struct
let instances = Hashtbl.create 10
let auth_systems = ref []
let auth_instances = Hashtbl.create 10
let auth_instance_names = ref []
let user = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
......@@ -63,7 +73,7 @@ module Make (N : NAME) = struct
module Services : AUTH_SERVICES = struct
let get_auth_systems () = !auth_systems
let get_auth_systems () = !auth_instance_names
let get_logged_user () = Eliom_reference.get user
......@@ -81,28 +91,38 @@ module Make (N : NAME) = struct
module Register (C : CONT_SERVICE) (T : TEMPLATES) : EMPTY = struct
let instantiate name auth =
if Hashtbl.mem instances name then (
failwith ("multiple instances with name " ^ name)
let () = 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 = X.parse_config ~instance ~attributes in
let auth = X.make config in
let module N = struct
let name = name
let path = N.path @ ["auth"; name]
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
Hashtbl.add instances name i;
auth_systems := name :: !auth_systems
Hashtbl.add auth_instances instance i;
auth_instance_names := instance :: !auth_instance_names
)
let () = List.iter (fun f -> f ~instantiate) !config_exec
) N.instances
let () = Eliom_registration.Any.register
~service:Services.login
(fun service () ->
let use name =
try
let i = Hashtbl.find instances name in
let i = Hashtbl.find auth_instances name in
let module A = (val i : AUTH_INSTANCE) in
A.handler ~on_success:(on_success false name) ()
with Not_found -> fail_http 404
......@@ -110,7 +130,7 @@ module Make (N : NAME) = struct
match service with
| Some name -> use name
| None ->
match !auth_systems with
match !auth_instance_names with
| [name] -> use name
| _ -> T.generic_login () >>= Eliom_registration.Html5.send
)
......
......@@ -26,17 +26,20 @@ open Web_signatures
val string_of_user : user -> string
type instantiator = string -> (module AUTH_SERVICE) -> unit
val register_auth_system : (module AUTH_SYSTEM) -> unit
val register_auth_system :
spec:(Ocsigen_extensions.Configuration.element list) ->
exec:(instantiate:instantiator -> unit) ->
unit
type auth_instance = {
auth_system : string;
auth_instance : string;
auth_config : (string * string) list;
}
val get_config_spec :
unit -> Ocsigen_extensions.Configuration.element list
module type CONFIG = sig
include NAME
val instances : auth_instance list
end
module Make (N : NAME) : sig
module Make (C : CONFIG) : sig
module Services : AUTH_SERVICES
module Register (S : CONT_SERVICE) (T : TEMPLATES) : EMPTY
end
......@@ -20,7 +20,18 @@
(**************************************************************************)
open Web_signatures
open Auth_common
type config = unit
let name = "dummy"
let parse_config ~instance ~attributes =
match attributes with
| [] -> ()
| _ ->
Printf.ksprintf failwith
"invalid configuration for instance %s of auth/%s"
instance name
module Make (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = struct
......@@ -59,19 +70,13 @@ module Make (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = stru
end
let init () =
let instances = ref [] in
let spec =
let open Ocsigen_extensions.Configuration in
[
let attributes = [
attribute ~name:"name" ~obligatory:true (fun s ->
instances := s :: !instances
);
] in element ~name:"auth-dummy" ~attributes ();
]
and exec ~instantiate =
List.iter (fun name ->
instantiate name (module Make : AUTH_SERVICE)
) !instances
in Auth_common.register_auth_system ~spec ~exec
let make () = (module Make : AUTH_SERVICE)
module A : AUTH_SYSTEM = struct
type config = unit
let name = name
let parse_config = parse_config
let make = make
end
let () = Auth_common.register_auth_system (module A : AUTH_SYSTEM)
val init : unit -> unit
type config = unit
include Web_signatures.AUTH_SYSTEM with type config := config
......@@ -22,7 +22,18 @@
open Util
open Web_signatures
open Web_common
open Auth_common
type config = { db : string }
let name = "password"
let parse_config ~instance ~attributes =
match attributes with
| ["db", db] -> {db}
| _ ->
Printf.ksprintf failwith
"invalid configuration for instance %s of auth/%s"
instance name
module type CONFIG = sig
val db : string
......@@ -82,48 +93,17 @@ module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_IN
end
type instance = {
mutable name : string option;
mutable db : string option;
}
let init () =
let instances = ref [] in
let current_instance = ref None in
let push_current loc =
match !current_instance with
| None -> ()
| Some {name = Some name; db = Some db} ->
let module C : CONFIG = struct
let db = db
end in
instances := (name, (module C : CONFIG)) :: !instances;
current_instance := None
| _ -> failwith ("unexpected case in auth-password/" ^ loc)
in
let spec =
let open Ocsigen_extensions.Configuration in
[
let init () =
push_current "init";
current_instance := Some {name = None; db = None}
and attributes = [
attribute ~name:"name" ~obligatory:true (fun s ->
match !current_instance with
| Some ({name = None; _} as i) -> i.name <- Some s
| _ -> failwith "unexpected case in auth-password/name"
);
attribute ~name:"db" ~obligatory:true (fun s ->
match !current_instance with
| Some ({db = None; _} as i) -> i.db <- Some s
| _ -> failwith "unexpected case in auth-password/db"
);
] in element ~name:"auth-password" ~init ~attributes ();
]
and exec ~instantiate =
push_current "exec";
List.iter (fun (name, config) ->
let module X = Make ((val config : CONFIG)) in
instantiate name (module X : AUTH_SERVICE)
) !instances
in Auth_common.register_auth_system ~spec ~exec
let make {db} =
let module C = struct let db = db end in
(module Make (C) : AUTH_SERVICE)
type c = config
module A : AUTH_SYSTEM = struct
type config = c
let name = name
let parse_config = parse_config
let make = make
end
let () = Auth_common.register_auth_system (module A : AUTH_SYSTEM)
val init : unit -> unit
type config = { db : string }
include Web_signatures.AUTH_SYSTEM with type config := config
......@@ -49,67 +49,38 @@ let file_exists x =
let populate accu f s = Lwt_stream.fold_s f s accu
let secure_logfile = ref None
let datadirs = ref []
let source_file = ref None
let main_election = ref None
let rewrite_src = ref None
let rewrite_dst = ref None
let auth_instances = ref []
let () = CalendarLib.Time_Zone.(change Local)
let () = Auth_dummy.init ()
let () = Auth_password.init ()
let () = Auth_cas.init ()
let config_spec =
let open Ocsigen_extensions.Configuration in
[
element
~name:"log"
~obligatory:true
~attributes:[
attribute ~name:"file" ~obligatory:true (fun s -> secure_logfile := Some s);
] ();
element
~name:"source"
~obligatory:true
~attributes:[
attribute ~name:"file" ~obligatory:true (fun s -> source_file := Some s);
] ();
element
~name:"data"
~obligatory:true
~attributes:[
attribute ~name:"dir" ~obligatory:true (fun s -> datadirs := s :: !datadirs);
] ();
element
~name:"rewrite-prefix"
~obligatory:false
~attributes:[
attribute ~name:"src" ~obligatory:true (fun s -> rewrite_src := Some s);
attribute ~name:"dst" ~obligatory:true (fun s -> rewrite_dst := Some s);
] ();
element
~name:"main-election"
~obligatory:false
~attributes:[
attribute ~name:"uuid" ~obligatory:true (fun s -> main_election := Some s);
] ();
] @ Auth_common.get_config_spec ()
let () = Eliom_config.parse_config config_spec
let () =
match !rewrite_src, !rewrite_dst with
| Some src, Some dst ->
Eliom_config.get_config () |>
let open Simplexmlparser in
List.iter @@ function
| PCData x ->
Ocsigen_extensions.Configuration.ignore_blank_pcdata ~in_tag:"belenios" x
| Element ("log", ["file", file], []) ->
Lwt_main.run (open_security_log file)
| Element ("source", ["file", file], []) ->
source_file := Some file
| Element ("data", ["dir", dir], []) ->
datadirs := dir :: !datadirs
| Element ("rewrite-prefix", ["src", src; "dst", dst], []) ->
set_rewrite_prefix ~src ~dst
| _, _ -> ()
lwt () =
match !secure_logfile with
| Some x -> open_security_log x
| None -> return ()
| Element ("main-election", ["uuid", uuid], []) ->
main_election := Some uuid
| Element ("auth", ["name", auth_instance],
[Element (auth_system, auth_config, [])]) ->
let open Auth_common in
let i = {auth_system; auth_instance; auth_config} in
auth_instances := i :: !auth_instances
| Element (tag, _, _) ->
Printf.ksprintf failwith
"invalid configuration for tag %s in belenios"
tag
let main_election = match !main_election with
| None -> None
......@@ -234,6 +205,7 @@ let can_vote m user =
module SAuth = Auth_common.Make (struct
let name = "site"
let path = []
let instances = !auth_instances
end)
module SSite = struct
......
......@@ -350,3 +350,16 @@ module type AUTH_SERVICE =
functor (S : CONT_SERVICE) ->
functor (T : TEMPLATES) ->
AUTH_INSTANCE
module type AUTH_SYSTEM = sig
type config
val name : string
val parse_config :
instance:string ->
attributes:(string * string) list ->
config
val make : config -> (module AUTH_SERVICE)
end
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