T212: use a directory (normally $program_dir/validators) for external validators.

What's bad is that right now way too many things are aware of the nature of external validators,
and the validators dir (formerly validators hashtable) is passed around a lot.
We'll need to think it through.

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 ()