diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/reference_tree.ml | 11 | ||||
-rw-r--r-- | src/reference_tree.mli | 4 | ||||
-rw-r--r-- | src/startup.ml | 21 | ||||
-rw-r--r-- | src/startup.mli | 2 | ||||
-rw-r--r-- | src/vyconfd.ml | 2 |
5 files changed, 26 insertions, 14 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 |