Add logging of interface definition file loading.

Move the high level load_interface_definitions function from Reference_tree
to Startup.

6 files changed, 27 insertions, 30 deletions

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 8c8e515..45789eb 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -122,17 +122,6 @@ 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 6db696a..33813d5 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -14,6 +14,8 @@ type ref_node_data = {
     secret: bool;
 }
 
+exception Bad_interface_definition of string
+
 exception Validation_error of string
 
 type t = ref_node_data Vytree.t
@@ -24,8 +26,6 @@ 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/startup.ml b/src/startup.ml
index 69849e0..34c1127 100644
--- a/src/startup.ml
+++ b/src/startup.ml
@@ -5,6 +5,9 @@ let panic msg =
     Lwt_log.fatal msg |> Lwt.ignore_result;
     exit 1
 
+let log_info msg = Lwt_log.info msg |> Lwt.ignore_result; ()
+
+
 (** Setup the default logger *)
 let setup_logger daemonize log_file template =
     (** 
@@ -84,3 +87,21 @@ let load_config_failsafe main fallback =
             | Ok config -> config
             | Error msg -> panic (Printf.sprintf "Failed to load fallback config %s: %s, exiting" fallback msg)
         end
+
+(* Load interface definitions from a directory into a reference tree *)
+let load_interface_definitions dir =
+    let open Reference_tree in
+    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
+    let load_aux tree file =
+        log_info @@ Printf.sprintf "Loading interface definitions from %s" file;
+        load_from_xml tree file
+    in
+    try begin match absolute_paths with
+        | Ok paths  -> Ok (List.fold_left load_aux default paths)
+        | Error msg -> Error msg end
+    with Bad_interface_definition msg -> Error msg
+
diff --git a/src/startup.mli b/src/startup.mli
index 2191bdb..c32ddea 100644
--- a/src/startup.mli
+++ b/src/startup.mli
@@ -15,3 +15,5 @@ val create_server :
 val load_config : string -> (Config_tree.t, string) result
 
 val load_config_failsafe : string -> string -> Config_tree.t
+
+val load_interface_definitions : string -> (Reference_tree.t, string) result
diff --git a/src/vyconfd.ml b/src/vyconfd.ml
index 3f0c62b..81dd2aa 100644
--- a/src/vyconfd.ml
+++ b/src/vyconfd.ml
@@ -180,7 +180,7 @@ let main_loop basepath world () =
 
 let load_interface_definitions dir =
     let open Session in
-    let reftree = Reference_tree.load_interface_definitions dir in
+    let reftree = Startup.load_interface_definitions dir in
     match reftree with
     | Ok r -> r
     | Error s -> Startup.panic s
diff --git a/test/reference_tree_test.ml b/test/reference_tree_test.ml
index b95a0ac..1186130 100644
--- a/test/reference_tree_test.ml
+++ b/test/reference_tree_test.ml
@@ -162,19 +162,6 @@ 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 (Vylist.in_list children "system") true;
-    assert_equal (Vylist.in_list children "login") true
-
-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" >::: [
@@ -206,9 +193,7 @@ let suite =
         "test_get_owner_valid" >:: test_get_owner_valid;
         "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
+        "test_get_help_string_default" >:: test_get_help_string_default
     ]
 
 let () =