diff options
| -rw-r--r-- | _oasis | 8 | ||||
| -rw-r--r-- | src/reference_tree.ml | 8 | ||||
| -rw-r--r-- | src/reference_tree.mli | 2 | ||||
| -rw-r--r-- | src/session.ml | 8 | ||||
| -rw-r--r-- | src/session.mli | 3 | ||||
| -rw-r--r-- | src/value_checker.ml | 27 | ||||
| -rw-r--r-- | src/value_checker.mli | 4 | ||||
| -rw-r--r-- | src/vyconfd.ml | 17 | ||||
| -rwxr-xr-x | test/data/validators/anything | 3 | ||||
| -rwxr-xr-x | test/data/validators/nothing | 3 | ||||
| -rw-r--r-- | test/reference_tree_test.ml | 18 | ||||
| -rw-r--r-- | test/value_checker_test.ml | 25 |
12 files changed, 79 insertions, 47 deletions
@@ -55,6 +55,12 @@ Library "vyconf_config" FindlibParent: vyconf BuildDepends: toml, ppx_deriving.show +Library "directories" + Path: src + Modules: Directories + FindlibParent: vyconf + BuildDepends: fileutils + Library "message" Path: src Modules: Message @@ -65,7 +71,7 @@ Executable "vyconfd" Path: src MainIs: vyconfd.ml CompiledObject: best - BuildDepends: ppx_deriving.runtime, ppx_deriving_yojson.runtime, lwt, lwt.unix, lwt.ppx, toml, vyconf + BuildDepends: ppx_deriving.runtime, ppx_deriving_yojson.runtime, lwt, lwt.unix, lwt.ppx, toml, fileutils, vyconf Executable "vytree_test" Path: test 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 () diff --git a/test/data/validators/anything b/test/data/validators/anything new file mode 100755 index 0000000..c52d3c2 --- /dev/null +++ b/test/data/validators/anything @@ -0,0 +1,3 @@ +#!/bin/sh + +exit 0 diff --git a/test/data/validators/nothing b/test/data/validators/nothing new file mode 100755 index 0000000..2bb8d86 --- /dev/null +++ b/test/data/validators/nothing @@ -0,0 +1,3 @@ +#!/bin/sh + +exit 1 diff --git a/test/reference_tree_test.ml b/test/reference_tree_test.ml index 1e9a624..0616378 100644 --- a/test/reference_tree_test.ml +++ b/test/reference_tree_test.ml @@ -1,12 +1,10 @@ open OUnit2 open Reference_tree -let validators = Hashtbl.create 256 -let () = Hashtbl.add validators "anything" "true"; - Hashtbl.add validators "nothing" "false" +let get_dir test_ctxt = in_testdata_dir test_ctxt ["validators"] let raises_validation_error f = - try f (); false + try ignore @@ f (); false with Validation_error _ -> true let test_load_valid_definition test_ctxt = @@ -18,34 +16,34 @@ let test_load_valid_definition test_ctxt = let test_validate_path_leaf_valid test_ctxt = let r = Vytree.make default_data "root" in let r = load_from_xml r (in_testdata_dir test_ctxt ["interface_definition_sample.xml"]) in - assert_equal (validate_path validators r ["system"; "host-name"; "test"]) (["system"; "host-name"], Some "test") + assert_equal (validate_path (get_dir test_ctxt) r ["system"; "host-name"; "test"]) (["system"; "host-name"], Some "test") let test_validate_path_leaf_invalid test_ctxt = let r = Vytree.make default_data "root" in let r = load_from_xml r (in_testdata_dir test_ctxt ["interface_definition_sample.xml"]) in - assert_equal (raises_validation_error (fun () -> ignore @@ validate_path validators r ["system"; "host-name"; "1234"])) true + assert_equal (raises_validation_error (fun () -> ignore @@ validate_path (get_dir test_ctxt) r ["system"; "host-name"; "1234"])) true let test_validate_path_leaf_incomplete test_ctxt = let r = Vytree.make default_data "root" in let r = load_from_xml r (in_testdata_dir test_ctxt ["interface_definition_sample.xml"]) in - assert_equal (raises_validation_error (fun () -> ignore @@ validate_path validators r ["system"; "host-name"])) true + assert_equal (raises_validation_error (fun () -> ignore @@ validate_path (get_dir test_ctxt) r ["system"; "host-name"])) true let test_validate_path_tag_node_complete_valid test_ctxt = let r = Vytree.make default_data "root" in let r = load_from_xml r (in_testdata_dir test_ctxt ["interface_definition_sample.xml"]) in - assert_equal (validate_path validators r ["system"; "login"; "user"; "test"; "full-name"; "test user"]) + assert_equal (validate_path (get_dir test_ctxt) r ["system"; "login"; "user"; "test"; "full-name"; "test user"]) (["system"; "login"; "user"; "test"; "full-name";], Some "test user") let test_validate_path_tag_node_invalid_name test_ctxt = let r = Vytree.make default_data "root" in let r = load_from_xml r (in_testdata_dir test_ctxt ["interface_definition_sample.xml"]) in - assert_equal (raises_validation_error (fun () -> ignore @@ validate_path validators r ["system"; "login"; "user"; "999"; "full-name"; "test user"])) + assert_equal (raises_validation_error (fun () -> ignore @@ validate_path (get_dir test_ctxt) r ["system"; "login"; "user"; "999"; "full-name"; "test user"])) true let test_validate_path_tag_node_incomplete test_ctxt = let r = Vytree.make default_data "root" in let r = load_from_xml r (in_testdata_dir test_ctxt ["interface_definition_sample.xml"]) in - assert_equal (raises_validation_error (fun () -> ignore @@ validate_path validators r ["system"; "login"; "user"])) true + assert_equal (raises_validation_error (fun () -> ignore @@ validate_path (get_dir test_ctxt) r ["system"; "login"; "user"])) true let suite = diff --git a/test/value_checker_test.ml b/test/value_checker_test.ml index 169ed86..3479150 100644 --- a/test/value_checker_test.ml +++ b/test/value_checker_test.ml @@ -1,46 +1,49 @@ open OUnit2 open Value_checker -let validators = Hashtbl.create 256 -let () = Hashtbl.add validators "anything" "true"; - Hashtbl.add validators "nothing" "false" +let get_dir test_ctxt = in_testdata_dir test_ctxt ["validators"] + +let raises_bad_validator f = + try ignore @@ f (); false + with Bad_validator _ -> true let test_check_regex_valid test_ctxt = let c = Regex "[a-z]+" in let v = "fgsfds" in - assert_equal (validate_value validators c v) true + assert_equal (validate_value (get_dir test_ctxt) c v) true let test_check_regex_invalid test_ctxt = let c = Regex "[a-z]+" in let v = "FGSFDS" in - assert_equal (validate_value validators c v) false + assert_equal (validate_value (get_dir test_ctxt) c v) false let test_check_external_valid test_ctxt = let c = External ("anything", "") in let v = "fgsfds" in - assert_equal (validate_value validators c v) true + assert_equal (validate_value (get_dir test_ctxt) c v) true let test_check_external_invalid test_ctxt = let c = External ("nothing", "") in let v = "fgsfds" in - assert_equal (validate_value validators c v) false + assert_equal (validate_value (get_dir test_ctxt) c v) false let test_check_external_bad_validator test_ctxt = let c = External ("invalid", "") in let v = "fgsfds" in - assert_raises (Bad_validator "invalid") (fun () -> validate_value validators c v) + assert_bool "Invalid validator was executed successfully" + (raises_bad_validator (fun () -> validate_value (get_dir test_ctxt) c v)) let test_validate_any_valid test_ctxt = let cs = [Regex "\\d+"; Regex "[a-z]+"; External ("anything", "")] in - assert_equal (validate_any validators cs "AAAA") true + assert_equal (validate_any (get_dir test_ctxt) cs "AAAA") true let test_validate_any_invalid test_ctxt = let cs = [Regex "\\d+"; Regex "[a-z]+"] in - assert_equal (validate_any validators cs "AAAA") false + assert_equal (validate_any (get_dir test_ctxt) cs "AAAA") false let test_validate_any_no_constraints test_ctxt = let cs = [] in - assert_equal (validate_any validators cs "foo") true + assert_equal (validate_any (get_dir test_ctxt) cs "foo") true let suite = "VyConf value checker tests" >::: [ |