(* $Id: netplex_config.ml 1405 2010-02-12 01:02:27Z gerd $ *)
open Netplex_types
open Genlex
exception Config_error of string
class address = object end
let is_win32 =
match Sys.os_type with
| "Win32" -> true
| _ -> false;;
let parse_config_file filename =
let rec parse_tree =
parser
| [< 'Ident id;
v = parse_rhs
>] ->
( match v with
| `Section tl -> `Section(new address, id, tl)
| `Parameter p -> `Parameter(new address, id, p)
)
and parse_tree_list =
parser
| [< t = parse_tree;
r = semi_parse_tree_list
>] ->
t :: r
| [< >] ->
[]
and semi_parse_tree_list =
parser
| [< 'Kwd ";";
tl = parse_tree_list;
>] -> tl
| [< >] -> []
and parse_tree_semi =
parser
| [< t = parse_tree;
_ = semi_list
>] -> t
and semi_list =
parser
| [< 'Kwd ";"; _ = semi_list >] -> ()
| [< >] -> ()
and parse_rhs =
parser
| [< 'Kwd "=";
v = parse_param_value;
>] ->
`Parameter v
| [< 'Kwd "{";
tl = parse_tree_list;
'Kwd "}"
>] ->
`Section tl
and parse_param_value =
parser
| [< 'Int n >] -> `Int n
| [< 'Float f >] -> `Float f
| [< 'String s >] -> `String s
| [< 'Ident "false" >] -> `Bool false
| [< 'Ident "true" >] -> `Bool true
in
let ch = open_in filename in
let s = Stream.of_channel ch in
let lexer = Genlex.make_lexer [ "{"; "}"; "="; ";" ] s in
try
let tree =
parse_tree_semi lexer in
Stream.empty lexer;
tree
with
(* TODO: would be nice if the error contained the line number *)
| Stream.Failure ->
raise(Config_error(filename ^ ": Syntax error"))
| Stream.Error _ ->
raise(Config_error(filename ^ ": Syntax error"))
;;
let rec iter_config_tree f prefix cnt (tree : config_tree) =
match tree with
| `Section(addr, name, tl) ->
let n =
try
Hashtbl.find cnt name
with
| Not_found ->
Hashtbl.add cnt name 0;
0 in
Hashtbl.replace cnt name (n+1);
let fullname =
if prefix <> "" then
prefix ^ "." ^ name ^ "[" ^ string_of_int n ^ "]"
else
name in
f addr fullname tree;
List.iter (iter_config_tree f fullname (Hashtbl.create 10)) tl
| `Parameter(addr, name, v) ->
let fullname = if prefix <> "" then prefix ^ "." ^ name else name in
if Hashtbl.mem cnt name then
raise(Config_error("Parameter defined twice: " ^ fullname));
Hashtbl.add cnt name 0;
f addr fullname tree;
;;
class config_file filename : Netplex_types.config_file =
let tree = parse_config_file filename in
object(self)
val addresses = Hashtbl.create 100
initializer (
try
iter_config_tree
(fun addr fullname subtree ->
Hashtbl.add addresses addr (fullname,subtree)
)
""
(Hashtbl.create 10)
tree
with
| Config_error msg ->
raise(Config_error (filename ^ ": " ^ msg))
)
method filename = filename
method tree = tree
method root_addr =
match tree with
| `Section(a,_,_) -> a
| `Parameter(a,_,_) -> a
method root_name =
match tree with
| `Section(_,n,_) -> n
| `Parameter(_,n,_) -> n
method resolve_section addr name =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#resolve_section" in
match subtree with
| `Section(_,_,tl) ->
List.map
(function
| `Section(addr,_,_) -> addr
| _ -> assert false
)
(List.filter
(function
| `Section(_,n,_) -> n = name
| _ -> false)
tl
)
| `Parameter _ ->
[]
method restrict_subsections addr names =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#restrict_subsections" in
match subtree with
| `Section(_,_,tl) ->
List.iter
(function
| `Section(a,n,_) ->
if not (List.mem n names) then
raise(Config_error(filename ^ ": Section " ^
self#print addr ^
" must not contain subsection '" ^
n ^ "'"))
| _ -> ())
tl
| _ ->
failwith "#restrict_subsections"
method restrict_parameters addr names =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#restrict_parameters" in
match subtree with
| `Section(_,_,tl) ->
List.iter
(function
| `Parameter(a,n,_) ->
if not (List.mem n names) then
raise(Config_error(filename ^ ": Section " ^
self#print addr ^
" must not contain parameter '" ^
n ^ "'"))
| _ -> ())
tl
| _ ->
failwith "#restrict_parameters"
method resolve_parameter addr name =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#resolve_parameter" in
match subtree with
| `Section(_,_,tl) ->
let vl =
List.map
(function
| `Parameter(addr,_,_) -> addr
| _ -> assert false
)
(List.filter
(function
| `Parameter(_,n,_) -> n = name
| _ -> false)
tl
) in
( match vl with
| [] -> raise Not_found
| [v] -> v
| _ ->
raise(Config_error(filename ^ ": Several definitions for parameter " ^ fullname ^ " found"))
)
| `Parameter _ ->
raise Not_found
method print addr =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#print" in
fullname
method string_param addr =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#string_param" in
match subtree with
| `Parameter(_,_,`String s) -> s
| _ ->
raise(Config_error(filename ^ ": Parameter " ^ fullname ^
" is not a string"))
method int_param addr =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#int_param" in
match subtree with
| `Parameter(_,_,`Int s) -> s
| _ ->
raise(Config_error(filename ^ ": Parameter " ^ fullname ^
" is not an integer"))
method float_param addr =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#float_param" in
match subtree with
| `Parameter(_,_,`Float s) -> s
| _ ->
raise(Config_error(filename ^ ": Parameter " ^ fullname ^
" is not a floating-point number"))
method bool_param addr =
let (fullname, subtree) =
try
Hashtbl.find addresses addr
with
| Not_found ->
failwith "#bool_param" in
match subtree with
| `Parameter(_,_,`Bool b) -> b
| _ ->
raise(Config_error(filename ^ ": Parameter " ^ fullname ^
" is not a boolean value"))
end
let read_config_file filename =
new config_file filename
let inet4_binding =
Pcre.regexp "^([0-9.]*):([0-9]+)$" ;;
let inet6_binding =
Pcre.regexp "^\\[([0-9a-fA-F.:]*)\\]:([0-9]+)$" ;;
let host_binding =
Pcre.regexp "^(.*):([0-9]+)$" ;;
let is_letter =
function
| 'a'..'z' -> true
| 'A'..'Z' -> true
| _ -> false
let mk_absolute dir path =
let is_abs =
if is_win32 then
String.length path >= 3 &&
is_letter path.[0] &&
path.[1] = ':' &&
(path.[2] = '/' || path.[2] = '\\')
else
path <> "" && path.[0] = '/'
in
if is_abs then
path
else
Filename.concat dir path
let extract_address socket_dir service_name proto_name cf addraddr =
let typ =
try
cf # string_param
(cf # resolve_parameter addraddr "type")
with
| Not_found ->
failwith ("Missing parameter: " ^ cf#print addraddr ^ ".type") in
let get_path() =
try
mk_absolute socket_dir
(cf # string_param
(cf # resolve_parameter addraddr "path"))
with
| Not_found ->
failwith ("Missing parameter: " ^ cf#print addraddr ^ ".path") in
( match typ with
| "local" ->
cf # restrict_subsections addraddr [];
cf # restrict_parameters addraddr [ "type"; "path" ];
let path = get_path() in
( match Sys.os_type with
| "Win32" ->
[ `W32_pipe_file path ]
| _ ->
[ `Socket (Unix.ADDR_UNIX path) ]
)
| "unixdomain" ->
cf # restrict_subsections addraddr [];
cf # restrict_parameters addraddr [ "type"; "path" ];
let path = get_path() in
[ `Socket (Unix.ADDR_UNIX path) ]
| "socket_file" ->
cf # restrict_subsections addraddr [];
cf # restrict_parameters addraddr [ "type"; "path" ];
let path = get_path() in
[ `Socket_file path ]
| "w32_pipe" ->
cf # restrict_subsections addraddr [];
cf # restrict_parameters addraddr [ "type"; "path" ];
let path = get_path() in
[ `W32_pipe path ]
| "w32_pipe_file" ->
cf # restrict_subsections addraddr [];
cf # restrict_parameters addraddr [ "type"; "path" ];
let path = get_path() in
[ `W32_pipe_file path ]
| "container" ->
cf # restrict_subsections addraddr [];
cf # restrict_parameters addraddr [ "type" ];
[ `Container(socket_dir,service_name,proto_name,`Any) ]
| "internet" ->
cf # restrict_subsections addraddr [];
cf # restrict_parameters addraddr [ "type"; "bind" ];
let bind =
try
cf # string_param
(cf # resolve_parameter addraddr "bind")
with
| Not_found ->
failwith ("Missing parameter: " ^ cf#print addraddr ^ ".bind") in
( match Netstring_pcre.string_match inet4_binding bind 0 with
| Some m ->
( try
let a =
Unix.inet_addr_of_string
(Netstring_pcre.matched_group m 1 bind) in
let p =
int_of_string
(Netstring_pcre.matched_group m 2 bind) in
[ `Socket (Unix.ADDR_INET(a,p)) ]
with
| _ ->
failwith ("Cannot parse " ^ cf#print addraddr ^
".bind")
)
| None ->
( match Netstring_pcre.string_match inet6_binding bind 0 with
| Some m ->
( try
let a =
Unix.inet_addr_of_string
(Netstring_pcre.matched_group m 1 bind) in
let p =
int_of_string
(Netstring_pcre.matched_group m 2 bind) in
[ `Socket (Unix.ADDR_INET(a,p)) ]
with
| _ ->
failwith ("Cannot parse " ^ cf#print addraddr ^
".bind")
)
| None ->
( match Netstring_pcre.string_match host_binding bind 0 with
| Some m ->
( try
let h =
Netstring_pcre.matched_group m 1 bind in
let p =
int_of_string
(Netstring_pcre.matched_group m 2 bind) in
let entry =
Unix.gethostbyname h in
let al =
Array.to_list
entry.Unix.h_addr_list in
List.map
(fun a ->
`Socket(Unix.ADDR_INET(a,p))
)
al
with
| _ ->
failwith ("Cannot parse or resolve " ^ cf#print addraddr ^
".bind")
)
| None ->
failwith ("Cannot parse " ^ cf#print addraddr ^
".bind")
)
)
)
| _ ->
failwith ("Bad parameter: " ^ cf#print addraddr ^ ".type")
)
;;
let read_netplex_config_ ptype c_logger_cfg c_wrkmng_cfg c_proc_cfg cf =
if cf # root_name <> "netplex" then
failwith ("Not a netplex configuration file");
(* - Additional subsections of the root are intentionally allowed!
cf # restrict_subsections cf#root_addr [ "controller"; "service" ];
*)
cf # restrict_parameters cf#root_addr [];
let ctrl_cfg = Netplex_controller.extract_config c_logger_cfg cf in
let socket_dir = ctrl_cfg # socket_directory in
let services =
List.map
(fun addr ->
cf # restrict_subsections addr [ "protocol"; "processor";
"workload_manager" ];
cf # restrict_parameters addr [ "name"; "user"; "group" ];
let service_name =
try
cf # string_param (cf # resolve_parameter addr "name")
with
| Not_found ->
failwith ("Missing parameter: " ^ cf#print addr ^ ".name") in
let user_opt =
try
Some(cf # string_param (cf # resolve_parameter addr "user"))
with
| Not_found -> None in
let group_opt =
try
Some(cf # string_param (cf # resolve_parameter addr "group"))
with
| Not_found -> None in
let user_group_opt =
match (user_opt, group_opt) with
| Some user, Some group ->
let user_ent =
try Unix.getpwnam user
with Not_found ->
failwith ("Unknown user: " ^ cf#print addr ^ ".user") in
let group_ent =
try Unix.getgrnam user
with Not_found ->
failwith ("Unknown group: " ^ cf#print addr ^ ".group") in
Some(user_ent.Unix.pw_uid, group_ent.Unix.gr_gid)
| Some user, None ->
let user_ent =
try Unix.getpwnam user
with Not_found ->
failwith ("Unknown user: " ^ cf#print addr ^ ".user") in
Some(user_ent.Unix.pw_uid, user_ent.Unix.pw_gid)
| None, Some _ ->
failwith("Missing user parameter for: " ^ cf#print addr ^
".group")
| None, None -> None in
if user_group_opt <> None then (
if Unix.geteuid() <> 0 then
failwith "Cannot set user and group if not running as root";
);
let startup_timeout =
try
cf # float_param (cf # resolve_parameter addr "startup_timeout")
with
| Not_found -> 60.0 in
let protocols =
List.map
(fun protaddr ->
cf # restrict_subsections protaddr [ "address" ];
cf # restrict_parameters protaddr [ "name";
"lstn_backlog";
"lstn_reuseaddr";
"so_keepalive"
];
let prot_name =
try
cf # string_param (cf # resolve_parameter protaddr "name")
with
| Not_found ->
failwith ("Missing parameter: " ^ cf#print protaddr ^ ".name") in
let lstn_backlog =
try
cf # int_param (cf # resolve_parameter protaddr "lstn_backlog")
with
| Not_found -> 20 in
let lstn_reuseaddr =
try
cf # bool_param (cf # resolve_parameter protaddr "lstn_reuseaddr")
with
| Not_found -> true in
let so_keepalive =
try
cf # bool_param (cf # resolve_parameter protaddr "so_keepalive")
with
| Not_found -> true in
let addresses =
List.flatten
(List.map
(extract_address socket_dir service_name prot_name cf)
(cf # resolve_section protaddr "address")) in
( object
method name = prot_name
method addresses = Array.of_list addresses
method lstn_backlog = lstn_backlog
method lstn_reuseaddr = lstn_reuseaddr
method so_keepalive = so_keepalive
method configure_slave_socket _ = ()
end
)
)
(cf # resolve_section addr "protocol") in
if protocols = [] then
failwith ("Section " ^ cf#print addr ^ " requires a sub-section 'protocol'");
let sockserv_config =
( object
method name = service_name
method protocols = protocols
method change_user_to = user_group_opt
method startup_timeout = startup_timeout
method controller_config = ctrl_cfg
end
) in
let procaddr =
match cf # resolve_section addr "processor" with
| [] ->
failwith ("Missing section: " ^ cf#print addr ^ ".processor")
| [a] -> a
| _ ->
failwith ("Only one section allowed: " ^ cf#print addr ^
".processor") in
let processor_type =
try
cf # string_param (cf # resolve_parameter procaddr "type")
with
| Not_found ->
failwith ("Missing parameter: " ^ cf#print procaddr ^ ".type")
in
let create_processor_config =
try
List.find
(fun cfg -> cfg # name = processor_type)
c_proc_cfg
with
| Not_found ->
failwith ("No such processor type: " ^ processor_type) in
let wrkmngaddr =
match cf # resolve_section addr "workload_manager" with
| [] ->
failwith ("Missing section: " ^ cf#print addr ^
".workload_manager")
| [a] -> a
| _ ->
failwith ("Only one section allowed: " ^ cf#print addr ^
".workload_manager") in
let wrkmng_type =
try
cf # string_param (cf # resolve_parameter wrkmngaddr "type")
with
| Not_found ->
failwith ("Missing parameter: " ^ cf#print wrkmngaddr ^ ".type")
in
let create_wrkmng_config =
try
List.find
(fun cfg -> cfg # name = wrkmng_type)
c_wrkmng_cfg
with
| Not_found ->
failwith ("No such workload_manager type: " ^ wrkmng_type) in
( sockserv_config,
(procaddr, create_processor_config),
(wrkmngaddr, create_wrkmng_config) )
)
(cf # resolve_section cf#root_addr "service") in
( object
method ptype = ptype
method controller_config = ctrl_cfg
method services = services
end
: netplex_config
)
;;
let read_netplex_config ptype c_logger_cfg c_wrkmng_cfg c_proc_cfg cf =
try
read_netplex_config_ ptype c_logger_cfg c_wrkmng_cfg c_proc_cfg cf
with
| Failure msg ->
raise (Config_error(cf#filename ^ ": " ^ msg))
;;
