Merge pull request #17 from jestabro/reference-tree

T5194: add support for reference tree

9 files changed, 397 insertions, 1 deletions

diff --git a/src/dune b/src/dune
index c6042e2..2bbe602 100644
--- a/src/dune
+++ b/src/dune
@@ -6,7 +6,7 @@
 (library
  (name vyos1x)
  (public_name vyos1x-config)
- (libraries yojson menhirLib)
+ (libraries yojson menhirLib fileutils pcre xml-light)
  (preprocess (pps ppx_deriving_yojson))
  (foreign_stubs
   (language c)
diff --git a/src/generate.ml b/src/generate.ml
new file mode 100644
index 0000000..53ab35f
--- /dev/null
+++ b/src/generate.ml
@@ -0,0 +1,36 @@
+(* Load interface definitions from a directory into a reference tree *)
+exception Load_error of string
+exception Write_error of string
+
+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 =
+        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
+
+let reference_tree_to_json from_dir to_file =
+    let ref_tree_result =
+        load_interface_definitions from_dir
+    in
+    let ref_tree =
+    match ref_tree_result with
+        | Ok ref -> ref
+        | Error msg -> raise (Load_error msg)
+    in
+    let out = Reference_tree.render_json ref_tree in
+    let oc =
+        try
+            open_out to_file
+        with Sys_error msg -> raise (Write_error msg)
+    in
+    Printf.fprintf oc "%s" out;
+    close_out oc
diff --git a/src/generate.mli b/src/generate.mli
new file mode 100644
index 0000000..e121d1f
--- /dev/null
+++ b/src/generate.mli
@@ -0,0 +1,5 @@
+exception Load_error of string
+exception Write_error of string
+
+val load_interface_definitions : string -> (Reference_tree.t, string) result
+val reference_tree_to_json : string -> string -> unit
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
new file mode 100644
index 0000000..e47e9d8
--- /dev/null
+++ b/src/reference_tree.ml
@@ -0,0 +1,278 @@
+type node_type =
+    | Leaf
+    | Tag
+    | Other
+
+let node_type_to_yojson = function
+    | Leaf -> `String "leaf"
+    | Tag -> `String "tag"
+    | Other -> `String "other"
+
+type value_constraint =
+    | Regex of string [@name "regex"]
+    | External of string * string option [@name "exec"]
+    [@@deriving yojson]
+
+type completion_help_type =
+    | List of string [@name "list"]
+    | Path of string [@name "path"]
+    | Script of string [@name "script"]
+    [@@deriving to_yojson]
+
+type ref_node_data = {
+    node_type: node_type;
+    constraints: value_constraint list;
+    constraint_error_message: string;
+    completion_help: completion_help_type list;
+    help: string;
+    value_help: (string * string) list;
+    multi: bool;
+    valueless: bool;
+    owner: string option;
+    priority: string option;
+    default_value: string option;
+    hidden: bool;
+    secret: bool;
+} [@@deriving to_yojson]
+
+type t = ref_node_data Vytree.t [@@deriving to_yojson]
+
+exception Bad_interface_definition of string
+
+exception Validation_error of string
+
+let default_data = {
+    node_type = Other;
+    constraints = [];
+    constraint_error_message = "Invalid value";
+    completion_help = [];
+    help = "No help available";
+    value_help = [];
+    multi = false;
+    valueless = false;
+    owner = None;
+    priority = None;
+    default_value = None;
+    hidden = false;
+    secret = false;
+}
+
+let default = Vytree.make default_data ""
+
+(* Loading from XML *)
+
+let node_type_of_string s =
+    match s with
+    | "node" -> Other
+    | "tagNode" -> Tag
+    | "leafNode" -> Leaf
+    | _ -> raise (Bad_interface_definition
+                  (Printf.sprintf "node, tagNode, or leafNode expected, %s found" s))
+
+let completion_help_type_of_string v s =
+    match v with
+    | "list" -> List s
+    | "path" -> Path s
+    | "script" -> Script s
+    | _ -> raise (Bad_interface_definition
+                  (Printf.sprintf "list, path, or script expected, %s found" s))
+
+(** Find a child node in xml-lite *)
+let find_xml_child name xml =
+    let find_aux e =
+        match e with
+        | Xml.Element (name', _, _) when name' = name -> true
+        | _ -> false
+    in
+    match xml with
+    | Xml.Element (_, _, children) -> Vylist.find find_aux children
+    | Xml.PCData _ -> None
+
+(* handle possible empty elements *)
+let try_pcdata x =
+    match x with
+    | [] -> ""
+    | _ ->
+    try
+        Xml.pcdata (List.hd x)
+    with Xml.Not_pcdata _ -> ""
+
+let get_pcdata_child name xml =
+    let c = find_xml_child name xml in
+    match c with
+    | Some Xml.Element(_, _, x_data) -> try_pcdata x_data
+    | _ -> raise (Bad_interface_definition (Printf.sprintf "No child named %s" name))
+
+let load_value_help_from_xml d x =
+    let fmt = get_pcdata_child "format" x in
+    let descr = get_pcdata_child "description" x in
+    let vhs = d.value_help in
+    let vhs' = (fmt, descr) :: vhs in
+    {d with value_help=vhs'}
+
+let load_completion_help_from_xml d c =
+    let res =
+    let aux l c =
+        match c with
+        | Xml.Element (_, _, [Xml.PCData s]) ->
+                l @ [completion_help_type_of_string (Xml.tag c) s]
+        | _ -> raise (Bad_interface_definition "Malformed completion help")
+    in Xml.fold aux [] c in
+    let l = d.completion_help in
+    let l' = l @ res in
+    {d with completion_help=l'}
+
+let load_constraint_from_xml d c =
+    let aux d c =
+        match c with
+        | Xml.Element ("regex", _, [Xml.PCData s]) ->
+            let cs = (Regex s) :: d.constraints in
+            {d with constraints=cs}
+        | Xml.Element ("validator", [("name", n); ("argument", a)], _) ->
+            let cs = (External (n, Some a)) :: d.constraints in
+            {d with constraints=cs}
+        | Xml.Element ("validator", [("name", n)], _) ->
+            let cs = (External (n, None)) :: d.constraints in
+            {d with constraints=cs}
+        | _ -> raise (Bad_interface_definition "Malformed constraint")
+    in Xml.fold aux d c
+
+let data_from_xml d x =
+    let aux d x =
+        match x with
+        | Xml.Element ("help", _, [Xml.PCData s]) -> {d with help=s}
+        | Xml.Element ("valueHelp", _, _) -> load_value_help_from_xml d x
+        | Xml.Element ("completionHelp", _, _) ->
+            load_completion_help_from_xml d x
+        | Xml.Element ("multi", _, _) -> {d with multi=true}
+        | Xml.Element ("valueless", _, _) -> {d with valueless=true}
+        | Xml.Element ("constraintErrorMessage", _, [Xml.PCData s]) ->
+            {d with constraint_error_message=s}
+        | Xml.Element ("constraint", _, _) -> load_constraint_from_xml d x
+        | Xml.Element ("priority", _, [Xml.PCData i]) ->
+            {d with priority=Some i}
+        | Xml.Element ("hidden", _, _) -> {d with hidden=true}
+        | Xml.Element ("secret", _, _) -> {d with secret=true}
+        | _ -> raise (Bad_interface_definition "Malformed property tag")
+    in Xml.fold aux d x
+
+let rec insert_from_xml basepath reftree xml =
+    match xml with
+    | Xml.Element ("syntaxVersion", _, _) -> reftree
+    | Xml.Element (_, _,  _) ->
+        let props = find_xml_child "properties" xml in
+        let data =
+            (match props with
+            | None -> default_data
+            | Some p -> data_from_xml default_data p)
+        in
+        let node_type = node_type_of_string (Xml.tag xml) in
+        let node_owner = try let o = Xml.attrib xml "owner" in Some o
+                         with _ -> None
+        in
+        let default_value_elem = find_xml_child "defaultValue" xml in
+        let default_value =
+            (match default_value_elem with
+            | Some (Xml.Element (_, _, [Xml.PCData s])) -> Some s
+            | _ -> None)
+        in
+        let data = {data with node_type=node_type; owner=node_owner; default_value=default_value} in
+        let name = Xml.attrib xml "name" in
+        let path = basepath @ [name] in
+        let new_tree = Vytree.insert_maybe reftree path data in
+        (match node_type with
+        | Leaf -> new_tree
+        | _ ->
+            let children = find_xml_child "children" xml in
+            (match children with
+             | None -> raise (Bad_interface_definition (Printf.sprintf "Node %s has no children" name))
+             | Some c ->  List.fold_left (insert_from_xml path) new_tree (Xml.children c)))
+    | _ -> raise (Bad_interface_definition "PCData not allowed here")
+
+let load_from_xml reftree file =
+    let xml_to_reftree xml reftree =
+        match xml with
+        | Xml.Element ("interfaceDefinition", _, children) ->
+            List.fold_left (insert_from_xml []) reftree children
+        | _ -> raise (Bad_interface_definition "Should start with <interfaceDefinition>")
+    in
+    try
+        let xml = Xml.parse_file file in
+        xml_to_reftree xml reftree
+    with
+    | Xml.File_not_found msg -> raise (Bad_interface_definition msg)
+    | Xml.Error e -> raise (Bad_interface_definition (Xml.error e))
+
+let is_multi reftree path =
+    let data = Vytree.get_data reftree path in
+    data.multi
+
+let is_hidden reftree path =
+    let data = Vytree.get_data reftree path in
+    data.hidden
+
+let is_secret reftree path =
+    let data = Vytree.get_data reftree path in
+    data.secret
+
+let is_tag reftree path =
+    let data = Vytree.get_data reftree path in
+    match data.node_type with
+    | Tag -> true
+    | _ -> false
+
+let is_leaf reftree path =
+    let data = Vytree.get_data reftree path in
+    match data.node_type with
+    | Leaf -> true
+    | _ -> false
+
+let is_valueless reftree path =
+    let data = Vytree.get_data reftree path in
+    data.valueless
+
+let get_owner reftree path =
+    let data = Vytree.get_data reftree path in
+    data.owner
+
+let get_help_string reftree path =
+    let data = Vytree.get_data reftree path in
+    data.help
+
+let get_value_help reftree path =
+    let data = Vytree.get_data reftree path in
+    data.value_help
+
+let get_completion_data reftree path =
+    let aux node =
+        let data = Vytree.data_of_node node in
+        (data.node_type, data.multi, data.help)
+    in List.map aux (Vytree.children_of_node @@ Vytree.get reftree path)
+
+module JSONRenderer =
+struct
+    let render_data data =
+        ref_node_data_to_yojson data |> Yojson.Safe.to_string
+
+    let rec render_node node =
+        let name = Vytree.name_of_node node in
+        let children = Vytree.children_of_node node in
+        let data = Vytree.data_of_node node in
+        let data_str = render_data data in
+        let children_strs = List.map render_node children in
+        let children_str = String.concat "," children_strs in
+        if children_str <> "" then
+            Printf.sprintf "\"%s\": {\"node_data\": %s, %s}" name data_str children_str
+        else
+            Printf.sprintf "\"%s\": {\"node_data\": %s}" name data_str
+
+    let render_json node =
+        let data = Vytree.data_of_node node in
+        let data_str = render_data data in
+        let children = Vytree.children_of_node node in
+        let child_configs = List.map render_node children in
+        let child_config = String.concat "," child_configs in
+        Printf.sprintf "{\"node_data\": %s, %s}" data_str child_config
+end (* JSONRenderer *)
+
+let render_json = JSONRenderer.render_json
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
new file mode 100644
index 0000000..0e70ff5
--- /dev/null
+++ b/src/reference_tree.mli
@@ -0,0 +1,65 @@
+type node_type =
+    | Leaf
+    | Tag
+    | Other
+
+type value_constraint =
+    | Regex of string [@name "regex"]
+    | External of string * string option [@name "exec"]
+    [@@deriving yojson]
+
+type completion_help_type =
+    | List of string [@name "list"]
+    | Path of string [@name "path"]
+    | Script of string [@name "script"]
+    [@@deriving to_yojson]
+
+type ref_node_data = {
+    node_type: node_type;
+    constraints: value_constraint list;
+    constraint_error_message: string;
+    completion_help: completion_help_type list;
+    help: string;
+    value_help: (string * string) list;
+    multi: bool;
+    valueless: bool;
+    owner: string option;
+    priority: string option;
+    default_value: string option;
+    hidden: bool;
+    secret: bool;
+} [@@deriving to_yojson]
+
+type t = ref_node_data Vytree.t [@@deriving to_yojson]
+
+exception Bad_interface_definition of string
+
+exception Validation_error of string
+
+val default_data : ref_node_data
+
+val default : t
+
+val load_from_xml : t -> string -> t
+
+val is_multi : t -> string list -> bool
+
+val is_hidden : t -> string list -> bool
+
+val is_secret : t -> string list -> bool
+
+val is_tag : t -> string list -> bool
+
+val is_leaf : t -> string list -> bool
+
+val is_valueless : t -> string list -> bool
+
+val get_owner : t -> string list -> string option
+
+val get_help_string : t -> string list -> string
+
+val get_value_help : t -> string list -> (string * string) list
+
+val get_completion_data : t -> string list -> (node_type * bool * string) list
+
+val render_json : t -> string
diff --git a/src/util.ml b/src/util.ml
index bb30645..9c5df23 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -34,3 +34,7 @@ let default default_value opt =
 
 let lexical_numeric_compare s t =
     lex_numeric_compare s t
+
+(** Convert a relative path to an absolute path based on the current working directory *)
+let absolute_path relative_path =
+    FilePath.make_absolute (Sys.getcwd ()) relative_path
diff --git a/src/util.mli b/src/util.mli
index f51adb1..f9bfba6 100644
--- a/src/util.mli
+++ b/src/util.mli
@@ -7,3 +7,5 @@ val escape_string : string -> string
 val default : 'a -> 'a option -> 'a
 
 val lexical_numeric_compare : string -> string -> int
+
+val absolute_path : FilePath.filename -> FilePath.filename
diff --git a/src/vytree.ml b/src/vytree.ml
index bd73776..ace587b 100644
--- a/src/vytree.ml
+++ b/src/vytree.ml
@@ -88,6 +88,10 @@ let rec insert ?(position=Default) ?(children=[]) node path data =
             let s = Printf.sprintf "Non-existent intermediary node: \'%s\'" name in
             raise (Insert_error s)
 
+let insert_maybe ?(position=Default) node path data =
+    try insert ~position:position node path data
+    with Duplicate_child -> node
+
 let sorted_children_of_node cmp node =
     let names = list_children node in
     let names = List.sort cmp names in
diff --git a/src/vytree.mli b/src/vytree.mli
index 377c9aa..a7bf680 100644
--- a/src/vytree.mli
+++ b/src/vytree.mli
@@ -23,6 +23,8 @@ val replace : 'a t -> 'a t -> 'a t
 
 val insert : ?position:position -> ?children:('a t list) -> 'a t -> string list -> 'a -> 'a t
 
+val insert_maybe : ?position:position -> 'a t -> string list -> 'a -> 'a t
+
 val insert_multi_level : 'a -> 'a t -> string list -> string list -> 'a -> 'a t
 
 val merge_children : ('a -> 'a -> 'a) -> (string -> string -> int) -> 'a t -> 'a t