summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/reference_tree.ml8
-rw-r--r--src/reference_tree.mli2
-rw-r--r--src/session.ml8
-rw-r--r--src/session.mli3
-rw-r--r--src/value_checker.ml27
-rw-r--r--src/value_checker.mli4
-rw-r--r--src/vyconfd.ml17
7 files changed, 44 insertions, 25 deletions
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 69ddae7..48de53b 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -130,7 +130,7 @@ let load_from_xml reftree file =
5. It's a non-leaf, non-tag node with a name that doesn't exist
in the reference tree
*)
-let rec validate_path validators node path =
+let rec validate_path validators_dir node path =
let show_path p = Util.string_of_path (List.rev p) in
let rec aux node path acc =
let data = Vytree.data_of_node node in
@@ -143,7 +143,7 @@ let rec validate_path validators node path =
(Printf.sprintf "Node \"%s\" requires a value" (show_path acc) ))
| [p] ->
if not data.valueless then
- (if (Value_checker.validate_any validators data.constraints p) then (List.rev acc, Some p)
+ (if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, Some p)
else raise (Validation_error data.constraint_error_message))
else raise (Validation_error
(Printf.sprintf "Node %s cannot have a value" (show_path acc)))
@@ -151,13 +151,13 @@ let rec validate_path validators node path =
| Tag ->
(match path with
| p :: p' :: ps ->
- if (Value_checker.validate_any validators data.constraints p) then
+ if (Value_checker.validate_any validators_dir data.constraints p) then
let child = Vytree.find node p' in
(match child with
| Some c -> aux c ps (p' :: p :: acc)
| None -> raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p')))
else raise (Validation_error (Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)))
- | [p] -> if (Value_checker.validate_any validators data.constraints p) then (List.rev acc, None)
+ | [p] -> if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, None)
else raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p))
| _ -> raise (Validation_error (Printf.sprintf "Path %s is incomplete" (show_path acc))))
| Other ->
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index bffebad..f0d7807 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -20,6 +20,6 @@ val default_data : ref_node_data
val load_from_xml : t -> string -> t
-val validate_path : (string, string) Hashtbl.t -> t -> string list -> string list * string option
+val validate_path : string -> t -> string list -> string list * string option
val is_multi : t -> string list -> bool
diff --git a/src/session.ml b/src/session.ml
index ff1cce7..cc71116 100644
--- a/src/session.ml
+++ b/src/session.ml
@@ -1,5 +1,6 @@
module CT = Config_tree
module RT = Reference_tree
+module D = Directories
type cfg_op =
| CfgSet of string list * string option * CT.value_behaviour
@@ -8,7 +9,8 @@ type cfg_op =
type world = {
mutable running_config: CT.t;
reference_tree: RT.t;
- validators: (string, string) Hashtbl.t;
+ vyconf_config: Vyconf_config.t;
+ dirs: Directories.t
}
type session_data = {
@@ -40,14 +42,14 @@ let rec apply_changes changeset config =
| c :: cs -> apply_changes cs (apply_cfg_op c config)
let set w s path =
- let path, value = RT.validate_path w.validators w.reference_tree path in
+ let path, value = RT.validate_path D.(w.dirs.validators) w.reference_tree path in
let value_behaviour = if RT.is_multi w.reference_tree path then CT.AddValue else CT.ReplaceValue in
let op = CfgSet (path, value, value_behaviour) in
let config = apply_cfg_op op s.proposed_config in
{s with proposed_config=config; changeset=(op :: s.changeset)}
let delete w s path =
- let path, value = RT.validate_path w.validators w.reference_tree path in
+ let path, value = RT.validate_path D.(w.dirs.validators) w.reference_tree path in
let op = CfgDelete (path, value) in
let config = apply_cfg_op op s.proposed_config in
{s with proposed_config=config; changeset=(op :: s.changeset)}
diff --git a/src/session.mli b/src/session.mli
index 273d434..0180549 100644
--- a/src/session.mli
+++ b/src/session.mli
@@ -5,7 +5,8 @@ type cfg_op =
type world = {
mutable running_config: Config_tree.t;
reference_tree: Reference_tree.t;
- validators: (string, string) Hashtbl.t;
+ vyconf_config: Vyconf_config.t;
+ dirs: Directories.t
}
type session_data = {
diff --git a/src/value_checker.ml b/src/value_checker.ml
index 1c19c3d..d4f0ddd 100644
--- a/src/value_checker.ml
+++ b/src/value_checker.ml
@@ -1,21 +1,26 @@
+module F = Filename
+
type value_constraint = Regex of string | External of string * string
exception Bad_validator of string
-let validate_value validators value_constraint value =
+let validate_value dir value_constraint value =
match value_constraint with
- | Regex s ->
- (try
+ | Regex s ->
+ (try
let _ = Pcre.exec ~pat:s value in true
with Not_found -> false)
- | External (t, c) ->
- try
- let validator = Hashtbl.find validators t in
- let result = Unix.system (Printf.sprintf "%s %s %s" validator c value) in
- match result with
- | Unix.WEXITED 0 -> true
- | _ -> false
- with Not_found -> raise (Bad_validator t)
+ | External (v, c) ->
+ (* XXX: Using Unix.system is a bad idea on multiple levels,
+ especially when the input comes directly from the user...
+ We should do something about it.
+ *)
+ let validator = F.concat dir v in
+ let result = Unix.system (Printf.sprintf "%s %s %s" validator c value) in
+ match result with
+ | Unix.WEXITED 0 -> true
+ | Unix.WEXITED 127 -> raise (Bad_validator (Printf.sprintf "Could not execute validator %s" validator))
+ | _ -> false
(* If no constraints given, consider it valid.
Otherwise consider it valid if it satisfies at least
diff --git a/src/value_checker.mli b/src/value_checker.mli
index 115ec9f..62f5b6b 100644
--- a/src/value_checker.mli
+++ b/src/value_checker.mli
@@ -2,6 +2,6 @@ type value_constraint = Regex of string | External of string * string
exception Bad_validator of string
-val validate_value : (string, string) Hashtbl.t -> value_constraint -> string -> bool
+val validate_value : string -> value_constraint -> string -> bool
-val validate_any : (string, string) Hashtbl.t -> value_constraint list -> string -> bool
+val validate_any : string -> value_constraint list -> string -> bool
diff --git a/src/vyconfd.ml b/src/vyconfd.ml
index 9549a97..b5adb47 100644
--- a/src/vyconfd.ml
+++ b/src/vyconfd.ml
@@ -24,13 +24,22 @@ let args = [
]
let usage = "Usage: " ^ Sys.argv.(0) ^ " [options]"
+let panic msg =
+ Lwt_log.fatal msg |> Lwt.ignore_result;
+ exit 1
+
let load_config path =
let result = Vyconf_config.load path in
match result with
| Ok cfg -> cfg
| Error err ->
- Lwt_log.fatal (Printf.sprintf "Could not load the configuration file %s" err) |> Lwt.ignore_result;
- exit 1
+ panic (Printf.sprintf "Could not load the configuration file %s" err)
+
+let check_dirs dirs =
+ let res = Directories.test dirs in
+ match res with
+ | Ok _ -> ()
+ | Error err -> panic err
let setup_logger daemonize log_file template =
(*
@@ -56,11 +65,13 @@ let setup_logger daemonize log_file template =
let main_loop config () =
let%lwt () = setup_logger !daemonize !log_file !log_template in
- let%lwt () = Lwt_log.notice @@ Printf.sprintf "Loading %s" config.app_name in
+ let%lwt () = Lwt_log.notice @@ Printf.sprintf "Starting VyConf for %s" config.app_name in
Lwt.return_unit
let () =
let () = Arg.parse args (fun f -> ()) usage in
let config = load_config !config_file in
+ let dirs = Directories.make config in
+ check_dirs dirs;
Lwt_main.run @@ main_loop config ()
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-23 05:50:03 +0000