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

9 files changed, 132 insertions, 4 deletions

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 @@
+<?xml version="1.0"?>
+<interfaceDefinition>
+  <node name="login" owner="login">
+    <children>
+      <tagNode name="user">
+        <properties>
+          <help>User name</help>
+          <constraint>
+            <regex>[a-z][a-zA-Z0-9]+</regex>
+          </constraint>
+          <constraintErrorMessage>User name must start with a letter and consist of letters and digits</constraintErrorMessage>
+        </properties>
+        <children>
+          <leafNode name="full-name">
+            <properties>
+              <help>User full name</help>
+            </properties>
+          </leafNode>
+        </children>
+      </tagNode>
+    </children>
+  </node>
+</interfaceDefinition>
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 @@
+<?xml version="1.0"?>
+<interfaceDefinition>
+  <node name="system">
+    <children>
+      <node name="login" owner="login">
+        <children>
+          <tagNode name="user">
+            <keepChildOrder/>
+            <properties>
+              <help>User name</help>
+              <constraint>
+                <regex>[a-zA-Z][a-zA-Z0-9\-]+</regex>
+              </constraint>
+              <constraintErrorMessage>User name must start with a letter and consist of letters and digits</constraintErrorMessage>
+            </properties>
+            <children>
+              <leafNode name="full-name">
+                <properties>
+                  <help>User full name</help>
+                </properties>
+              </leafNode>
+            </children>
+          </tagNode>
+          <leafNode name="password">
+            <properties>
+              <help>A password</help>
+              <secret/>
+            </properties>
+          </leafNode>
+        </children>
+      </node>
+      <leafNode name="host-name">
+        <properties>
+          <constraint>
+            <regex>[a-zA-Z][a-zA-Z0-9\-]</regex>
+          </constraint>
+        </properties>
+      </leafNode>
+      <leafNode name="ntp-server">
+        <properties>
+          <help>NTP server address</help>
+          <multi/>
+        </properties>
+      </leafNode>
+      <node name="options">
+        <children>
+          <leafNode name="reboot-on-panic">
+            <properties>
+              <help>Reboot automatically if kernel panic occurs</help>
+              <valueless/>
+            </properties>
+          </leafNode>
+          <leafNode name="enable-dangerous-features">
+            <properties>
+              <help>Enable dangerous features</help>
+              <hidden/>
+            </properties>
+          </leafNode>
+        </children>
+      </node>
+    </children>
+  </node>
+</interfaceDefinition>
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 () =