From 27a2d5ad1afb7baac317672620ff138f9802ccbf Mon Sep 17 00:00:00 2001 From: Shon Feder Date: Tue, 17 Jan 2017 03:31:28 -0500 Subject: T231: Add a function for loading interface definitions from a directory (#5) * T231: Load directory of interface definitions * T231: Add ounit package to merlin config * T231: Add tests for loading dir of definitions * squash! T231: Load directory of interface definitions * squash! T231: Add tests for loading dir of definitions --- .merlin | 1 + _oasis | 8 +-- src/reference_tree.ml | 13 +++++ src/reference_tree.mli | 4 ++ src/util.ml | 3 ++ src/util.mli | 2 + test/data/interface_definitions/login_sample.xml | 23 +++++++++ test/data/interface_definitions/system_sample.xml | 63 +++++++++++++++++++++++ test/reference_tree_test.ml | 19 +++++++ 9 files changed, 132 insertions(+), 4 deletions(-) create mode 100644 test/data/interface_definitions/login_sample.xml create mode 100644 test/data/interface_definitions/system_sample.xml diff --git a/.merlin b/.merlin index cfbc4ed..bc91118 100644 --- a/.merlin +++ b/.merlin @@ -5,4 +5,5 @@ B _build/test PKG lwt lwt.unix PKG ppx_deriving.runtime ppx_deriving.show PKG fileutils pcre toml xml-light +PKG ounit EXT lwt ounit diff --git a/_oasis b/_oasis index e146012..65bdd4c 100644 --- a/_oasis +++ b/_oasis @@ -42,7 +42,7 @@ Executable "reference_tree_test" Build$: flag(tests) CompiledObject: best Install: false - BuildDepends: oUnit, ppx_deriving_yojson, xml-light, pcre + BuildDepends: oUnit, ppx_deriving_yojson, xml-light, pcre, fileutils Executable "config_tree_test" Path: test @@ -66,7 +66,7 @@ Executable "value_checker_test" Build$: flag(tests) CompiledObject: best Install: false - BuildDepends: oUnit, pcre + BuildDepends: oUnit, pcre, fileutils Executable "util_test" Path: test @@ -74,7 +74,7 @@ Executable "util_test" Build$: flag(tests) CompiledObject: best Install: false - BuildDepends: oUnit, vyconf, xml-light + BuildDepends: oUnit, vyconf, xml-light, fileutils Executable "vyconf_config_test" Path: test @@ -82,7 +82,7 @@ Executable "vyconf_config_test" Build$: flag(tests) CompiledObject: best Install: false - BuildDepends: oUnit, toml, ppx_deriving.runtime + BuildDepends: oUnit, toml, ppx_deriving.runtime, fileutils Executable "curly_parser_test" Path: test diff --git a/src/reference_tree.ml b/src/reference_tree.ml index 26b14b9..6f1a9c9 100644 --- a/src/reference_tree.ml +++ b/src/reference_tree.ml @@ -34,6 +34,8 @@ let default_data = { secret = false; } +let default = Vytree.make default_data "root" + (* Loading from XML *) let node_type_of_string s = @@ -120,6 +122,17 @@ let load_from_xml reftree file = | Xml.File_not_found msg -> raise (Bad_interface_definition msg) | Xml.Error e -> raise (Bad_interface_definition (Xml.error e)) +let load_interface_definitions dir = + let relative_paths = FileUtil.ls dir in + let absolute_paths = + try Ok (List.map Util.absolute_path relative_paths) + with Sys_error no_dir_msg -> Error no_dir_msg + in + try match absolute_paths with + | Ok paths -> Ok (List.fold_left load_from_xml default paths) + | Error msg -> Error msg + with Bad_interface_definition msg -> Error msg + (* Validation function *) let has_illegal_characters name = diff --git a/src/reference_tree.mli b/src/reference_tree.mli index f9b4b5e..6db696a 100644 --- a/src/reference_tree.mli +++ b/src/reference_tree.mli @@ -20,8 +20,12 @@ type t = ref_node_data Vytree.t val default_data : ref_node_data +val default : t + val load_from_xml : t -> string -> t +val load_interface_definitions : string -> (t, string) result + val validate_path : string -> t -> string list -> string list * string option val is_multi : t -> string list -> bool diff --git a/src/util.ml b/src/util.ml index 2bac3d6..afa0ef3 100644 --- a/src/util.ml +++ b/src/util.ml @@ -25,3 +25,6 @@ let substitute_default o d = match o with | None -> d | Some v -> v + +let absolute_path relative_path = + FilePath.make_absolute (Sys.getcwd ()) relative_path diff --git a/src/util.mli b/src/util.mli index 7d78a15..46fac71 100644 --- a/src/util.mli +++ b/src/util.mli @@ -3,3 +3,5 @@ val find_xml_child : string -> Xml.xml -> Xml.xml option val string_of_path : string list -> string val substitute_default : 'a option -> 'a -> 'a + +val absolute_path : FilePath.filename -> FilePath.filename diff --git a/test/data/interface_definitions/login_sample.xml b/test/data/interface_definitions/login_sample.xml new file mode 100644 index 0000000..b74a415 --- /dev/null +++ b/test/data/interface_definitions/login_sample.xml @@ -0,0 +1,23 @@ + + + + + + + User name + + [a-z][a-zA-Z0-9]+ + + User name must start with a letter and consist of letters and digits + + + + + User full name + + + + + + + diff --git a/test/data/interface_definitions/system_sample.xml b/test/data/interface_definitions/system_sample.xml new file mode 100644 index 0000000..c6185c0 --- /dev/null +++ b/test/data/interface_definitions/system_sample.xml @@ -0,0 +1,63 @@ + + + + + + + + + + User name + + [a-zA-Z][a-zA-Z0-9\-]+ + + User name must start with a letter and consist of letters and digits + + + + + User full name + + + + + + + A password + + + + + + + + + [a-zA-Z][a-zA-Z0-9\-] + + + + + + NTP server address + + + + + + + + Reboot automatically if kernel panic occurs + + + + + + Enable dangerous features + + + + + + + + diff --git a/test/reference_tree_test.ml b/test/reference_tree_test.ml index 8002bdf..a3125be 100644 --- a/test/reference_tree_test.ml +++ b/test/reference_tree_test.ml @@ -3,6 +3,10 @@ open Reference_tree let get_dir test_ctxt = in_testdata_dir test_ctxt ["validators"] +let ok_or_failure result = match result with + | Ok value -> value + | Error msg -> assert_failure msg + let raises_validation_error f = try ignore @@ f (); false with Validation_error _ -> true @@ -158,6 +162,19 @@ let test_get_help_string_default test_ctxt = let r = load_from_xml r (in_testdata_dir test_ctxt ["interface_definition_sample.xml"]) in assert_equal (get_help_string r ["system"; "host-name"]) ("No help available") +let test_load_interface_definitions_children test_ctxt = + let interface_definitions_dir = in_testdata_dir test_ctxt ["interface_definitions"] in + let r = ok_or_failure (load_interface_definitions interface_definitions_dir) in + let children = Vytree.list_children r in + assert_equal children ["system"; "login"] + +let test_load_interface_definitions_leaves test_ctxt = + let interface_definitions_dir = in_testdata_dir test_ctxt ["interface_definitions"] in + let r = ok_or_failure (load_interface_definitions interface_definitions_dir) in + let has_system_leaf = is_leaf r ["system"; "login"; "user"; "full-name"] in + let has_login_leaf = is_leaf r ["login"; "user"; "full-name"] in + assert_equal (has_system_leaf && has_login_leaf) true + let suite = "Util tests" >::: [ "test_load_valid_definition" >:: test_load_valid_definition; @@ -189,6 +206,8 @@ let suite = "test_get_owner_invalid" >:: test_get_owner_invalid; "test_get_help_string_valid" >:: test_get_help_string_valid; "test_get_help_string_default" >:: test_get_help_string_default; + "test_load_interface_definitions_children " >:: test_load_interface_definitions_children; + "test_load_interface_definitions_leaves" >:: test_load_interface_definitions_leaves ] let () = -- cgit v1.2.3