From bff171c651592f27ea8e55db99c88f8ab076b0cd Mon Sep 17 00:00:00 2001
From: John Estabrook <jestabro@vyos.io>
Date: Thu, 24 Oct 2024 11:04:39 -0500
Subject: T6718: move validate_path from vyconf

---
 src/reference_tree.mli | 11 ++++-------
 1 file changed, 4 insertions(+), 7 deletions(-)

(limited to 'src/reference_tree.mli')

diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index a18d875..9d512db 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -3,11 +3,6 @@ type node_type =
     | 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"]
@@ -16,8 +11,8 @@ type completion_help_type =
 
 type ref_node_data = {
     node_type: node_type;
-    constraints: value_constraint list;
-    constraint_group: value_constraint list;
+    constraints: Value_checker.value_constraint list;
+    constraint_group: Value_checker.value_constraint list;
     constraint_error_message: string;
     completion_help: completion_help_type list;
     help: string;
@@ -43,6 +38,8 @@ val default : t
 
 val load_from_xml : t -> string -> t
 
+val validate_path : string -> t -> string list -> string list * string option
+
 val is_multi : t -> string list -> bool
 
 val is_hidden : t -> string list -> bool
-- 
cgit v1.2.3


From 223652d81e2e373d6aa518bc7215ea9ddf933af0 Mon Sep 17 00:00:00 2001
From: John Estabrook <jestabro@vyos.io>
Date: Thu, 24 Oct 2024 11:04:39 -0500
Subject: T6718: minor changes to support vyconf tests

---
 src/reference_tree.ml  | 10 +++++-----
 src/reference_tree.mli |  2 ++
 2 files changed, 7 insertions(+), 5 deletions(-)

(limited to 'src/reference_tree.mli')

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index d6249b8..89bf14e 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -74,7 +74,7 @@ let completion_help_type_of_string v s =
     | _ -> raise (Bad_interface_definition
                   (Printf.sprintf "list, path, or script expected, %s found" s))
 
-(** Find a child node in xml-lite *)
+(** Find a child node in xml-light *)
 let find_xml_child name xml =
     let find_aux e =
         match e with
@@ -113,7 +113,7 @@ let load_completion_help_from_xml d 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")
+        | _ -> raise (Bad_interface_definition ("Malformed completion help :" ^ Xml.to_string c))
     in Xml.fold aux [] c in
     let l = d.completion_help in
     let l' = l @ res in
@@ -131,7 +131,7 @@ let load_constraint_from_xml d c =
         | Xml.Element ("validator", [("name", n)], _) ->
             let cs = (Value_checker.External (n, None)) :: d.constraints in
             {d with constraints=cs}
-        | _ -> raise (Bad_interface_definition "Malformed constraint")
+        | _ -> raise (Bad_interface_definition ("Malformed constraint: " ^ Xml.to_string c))
     in Xml.fold aux d c
 
 let load_constraint_group_from_xml d c =
@@ -146,7 +146,7 @@ let load_constraint_group_from_xml d c =
         | Xml.Element ("validator", [("name", n)], _) ->
             let cs = (Value_checker.External (n, None)) :: d.constraint_group in
             {d with constraint_group=cs}
-        | _ -> raise (Bad_interface_definition "Malformed constraint")
+        | _ -> raise (Bad_interface_definition ("Malformed constraint: " ^ Xml.to_string c))
     in Xml.fold aux d c
 
 let data_from_xml d x =
@@ -166,7 +166,7 @@ let data_from_xml d x =
             {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")
+        | _ -> raise (Bad_interface_definition ("Malformed property tag: " ^ Xml.to_string x))
     in Xml.fold aux d x
 
 let rec insert_from_xml basepath reftree xml =
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index 9d512db..2c2a03d 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -38,6 +38,8 @@ val default : t
 
 val load_from_xml : t -> string -> t
 
+val find_xml_child : string -> Xml_light_types.xml -> Xml_light_types.xml option
+
 val validate_path : string -> t -> string list -> string list * string option
 
 val is_multi : t -> string list -> bool
-- 
cgit v1.2.3


From bcf21129981d4541f7ae9a88ae3bdb4b297bfc17 Mon Sep 17 00:00:00 2001
From: John Estabrook <jestabro@vyos.io>
Date: Thu, 24 Oct 2024 11:04:39 -0500
Subject: T6718: add functor for internal rep

---
 src/config_tree.ml     |  2 ++
 src/config_tree.mli    |  2 ++
 src/internal.ml        | 29 +++++++++++++++++++++++++++++
 src/internal.mli       | 15 +++++++++++++++
 src/reference_tree.ml  | 12 +++++++++---
 src/reference_tree.mli |  6 +++---
 6 files changed, 60 insertions(+), 6 deletions(-)
 create mode 100644 src/internal.ml
 create mode 100644 src/internal.mli

(limited to 'src/reference_tree.mli')

diff --git a/src/config_tree.ml b/src/config_tree.ml
index f12461c..89f85bf 100644
--- a/src/config_tree.ml
+++ b/src/config_tree.ml
@@ -22,6 +22,8 @@ let default_data = {
     leaf = false;
 }
 
+let default = Vytree.make default_data ""
+
 let make name = Vytree.make default_data name
 
 let op_to_string op =
diff --git a/src/config_tree.mli b/src/config_tree.mli
index 001c607..c05bab9 100644
--- a/src/config_tree.mli
+++ b/src/config_tree.mli
@@ -17,6 +17,8 @@ type t = config_node_data Vytree.t [@@deriving yojson]
 
 val default_data : config_node_data
 
+val default : t
+
 val make : string -> t
 
 val create_node : t -> string list -> t
diff --git a/src/internal.ml b/src/internal.ml
new file mode 100644
index 0000000..0c761e0
--- /dev/null
+++ b/src/internal.ml
@@ -0,0 +1,29 @@
+module type T =
+    sig
+        type t
+        val to_yojson : t -> Yojson.Safe.t
+        val of_yojson : Yojson.Safe.t -> t Ppx_deriving_yojson_runtime.error_or
+        val default : t
+    end
+
+module type FI = functor (M: T) ->
+    sig
+        val write_internal : M.t -> string -> unit
+        val read_internal : string -> M.t
+    end
+
+module Make : FI = functor (M: T) -> struct
+    let write_internal x file_name =
+        let yt = M.to_yojson x in
+        let ys = Yojson.Safe.to_string yt in
+        let oc = open_out file_name in
+        Printf.fprintf oc "%s" ys; close_out oc
+
+    let read_internal file_name =
+        let ic = open_in file_name in
+        let ys = really_input_string ic (in_channel_length ic) in
+        let yt = Yojson.Safe.from_string ys in
+        let ct_res = M.of_yojson yt in
+        let ct = Result.value ct_res ~default:M.default in
+        close_in ic; ct
+end
diff --git a/src/internal.mli b/src/internal.mli
new file mode 100644
index 0000000..33918c7
--- /dev/null
+++ b/src/internal.mli
@@ -0,0 +1,15 @@
+module type T =
+    sig
+        type t
+        val to_yojson : t -> Yojson.Safe.t
+        val of_yojson : Yojson.Safe.t -> t Ppx_deriving_yojson_runtime.error_or
+        val default : t
+    end
+
+module type FI = functor (M : T) ->
+    sig
+      val write_internal : M.t -> string -> unit
+      val read_internal : string -> M.t
+    end
+
+module Make : FI
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 89bf14e..e920209 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -8,11 +8,17 @@ let node_type_to_yojson = function
     | Tag -> `String "tag"
     | Other -> `String "other"
 
+let node_type_of_yojson = function
+    | `String "leaf" -> Ok Leaf
+    | `String "tag" -> Ok Tag
+    | `String "other" -> Ok Other
+    | json -> Error (Yojson.Safe.to_string json)
+
 type completion_help_type =
     | List of string [@name "list"]
     | Path of string [@name "path"]
     | Script of string [@name "script"]
-    [@@deriving to_yojson]
+    [@@deriving yojson]
 
 type ref_node_data = {
     node_type: node_type;
@@ -29,9 +35,9 @@ type ref_node_data = {
     default_value: string option;
     hidden: bool;
     secret: bool;
-} [@@deriving to_yojson]
+} [@@deriving yojson]
 
-type t = ref_node_data Vytree.t [@@deriving to_yojson]
+type t = ref_node_data Vytree.t [@@deriving yojson]
 
 exception Bad_interface_definition of string
 
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index 2c2a03d..129e5db 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -7,7 +7,7 @@ type completion_help_type =
     | List of string [@name "list"]
     | Path of string [@name "path"]
     | Script of string [@name "script"]
-    [@@deriving to_yojson]
+    [@@deriving yojson]
 
 type ref_node_data = {
     node_type: node_type;
@@ -24,9 +24,9 @@ type ref_node_data = {
     default_value: string option;
     hidden: bool;
     secret: bool;
-} [@@deriving to_yojson]
+} [@@deriving yojson]
 
-type t = ref_node_data Vytree.t [@@deriving to_yojson]
+type t = ref_node_data Vytree.t [@@deriving yojson]
 
 exception Bad_interface_definition of string
 
-- 
cgit v1.2.3


From bd64f4508d72d1b2f0c613b5012ad6dc9507f3c6 Mon Sep 17 00:00:00 2001
From: John Estabrook <jestabro@vyos.io>
Date: Thu, 24 Oct 2024 11:04:39 -0500
Subject: T6718: add function refpath: config path -> reference_tree path

---
 src/reference_tree.ml  | 11 +++++++++++
 src/reference_tree.mli |  2 ++
 2 files changed, 13 insertions(+)

(limited to 'src/reference_tree.mli')

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index e920209..353a152 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -340,6 +340,17 @@ let get_completion_data reftree path =
         (data.node_type, data.multi, data.help)
     in List.map aux (Vytree.children_of_node @@ Vytree.get reftree path)
 
+(* Convert from config path to reference tree path *)
+let refpath reftree path =
+    let rec aux acc p =
+    match acc, p with
+    | [], h :: tl -> aux (acc @ [h]) tl
+    | _, [h] -> if is_tag reftree acc then acc else acc @ [h]
+    | _, h :: h' :: tl -> if is_tag reftree acc then aux (acc @ [h']) tl
+                          else aux (acc @ [h]) ([h'] @ tl)
+    | _, [] -> acc
+    in aux [] path
+
 module JSONRenderer =
 struct
     let render_data data =
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index 129e5db..964380e 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -62,4 +62,6 @@ val get_value_help : t -> string list -> (string * string) list
 
 val get_completion_data : t -> string list -> (node_type * bool * string) list
 
+val refpath : t -> string list -> string list
+
 val render_json : t -> string
-- 
cgit v1.2.3


From 73e0836d9d64c9dbbf53b82d18ab84e525f59ad6 Mon Sep 17 00:00:00 2001
From: John Estabrook <jestabro@vyos.io>
Date: Thu, 24 Oct 2024 11:04:39 -0500
Subject: T6718: validate_path returns unit instead of (path, value)

Splitting of path arg into (path, value), as originally returned by
validate_path, is now handled by a utility function. validate_path
returns unit on success and raises error with output on failure.
---
 src/reference_tree.ml  | 57 ++++++++++++++++++++++++++++++++++++++++----------
 src/reference_tree.mli |  4 +++-
 src/value_checker.ml   |  8 +++----
 src/value_checker.mli  |  4 ++--
 4 files changed, 55 insertions(+), 18 deletions(-)

(limited to 'src/reference_tree.mli')

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 6472cb5..bda7b0e 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -261,20 +261,20 @@ let validate_path validators_dir node path =
             begin
             match path with
             | [] ->
-                if data.valueless then (List.rev acc, None)
+                if data.valueless then ()
                 else
                 let msg =
                     Printf.sprintf "Configuration path %s requires a value" (show_path acc)
                 in raise (Validation_error msg)
             | [p] ->
                  if not data.valueless then
-                     let res, out =
+                     let res =
                          try Value_checker.validate_any validators_dir data.constraints p
                          with Value_checker.Bad_validator msg -> raise (Validation_error msg)
                      in
                      match res with
-                     | true -> (List.rev acc, Some p)
-                     | false ->
+                     | None -> ()
+                     | Some out ->
                         raise (Validation_error (out ^ data.constraint_error_message))
                  else
                      let msg = Printf.sprintf "Node %s cannot have a value" (show_path acc)
@@ -294,13 +294,13 @@ let validate_path validators_dir node path =
                         Printf.sprintf "Illegal character \"%s\" in node name \"%s\"" c p
                     in raise (Validation_error msg)
                 | None ->
-                    let res, out =
+                    let res =
                         try Value_checker.validate_any validators_dir data.constraints p
                         with Value_checker.Bad_validator msg -> raise (Validation_error msg)
                     in
                     begin
                     match res with
-                    | true ->
+                    | None ->
                         let child = Vytree.find node p' in
                         begin
                         match child with
@@ -310,7 +310,7 @@ let validate_path validators_dir node path =
                                 Printf.sprintf "Node %s has no child %s" (show_path acc) p'
                             in raise (Validation_error msg)
                         end
-                    | false ->
+                    | Some out ->
                         let msg =
                             Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)
                         in
@@ -326,14 +326,14 @@ let validate_path validators_dir node path =
                         Printf.sprintf "Illegal character \"%s\" in node name \"%s\"" c p
                     in raise (Validation_error msg)
                 | None ->
-                    let res, out =
+                    let res =
                         try Value_checker.validate_any validators_dir data.constraints p
                         with Value_checker.Bad_validator msg -> raise (Validation_error msg)
                     in
                     begin
                     match res with
-                    | true -> (List.rev acc, None)
-                    | false ->
+                    | None -> ()
+                    | Some out ->
                         let msg =
                             Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)
                         in
@@ -349,7 +349,7 @@ let validate_path validators_dir node path =
         | Other ->
             begin
             match path with
-            | [] -> (List.rev acc, None)
+            | [] -> ()
             | p :: ps ->
                 let child = Vytree.find node p in
                 match child with
@@ -360,6 +360,41 @@ let validate_path validators_dir node path =
             end
     in aux node path []
 
+(* This is only to be used after the path has been validated *)
+let split_path node path =
+    let rec aux node path acc =
+        let data = Vytree.data_of_node node in
+        match data.node_type with
+        | Leaf ->
+            begin
+            match path with
+            | [] -> (List.rev acc, None)
+            | [p] -> (List.rev acc, Some p)
+            | _ -> (List.rev acc, None)
+            end
+        | Tag ->
+            begin
+            match path with
+            | p :: p' :: ps ->
+                (let child = Vytree.find node p' in
+                match child with
+                | Some c -> aux c ps (p' :: p :: acc)
+                | None -> (List.rev acc, None))
+            | [_] -> (List.rev acc, None)
+            | _ -> (List.rev acc, None)
+            end
+        | Other ->
+            begin
+            match path with
+            | [] -> (List.rev acc, None)
+            | p :: ps ->
+                let child = Vytree.find node p in
+                match child with
+                | Some c -> aux c ps (p :: acc)
+                | None -> (List.rev acc, None)
+            end
+    in aux node path []
+
 let is_multi reftree path =
     let data = Vytree.get_data reftree path in
     data.multi
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index 964380e..a8d4efa 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -40,7 +40,9 @@ val load_from_xml : t -> string -> t
 
 val find_xml_child : string -> Xml_light_types.xml -> Xml_light_types.xml option
 
-val validate_path : string -> t -> string list -> string list * string option
+val validate_path : string -> t -> string list -> unit
+
+val split_path : t -> string list -> string list * string option
 
 val is_multi : t -> string list -> bool
 
diff --git a/src/value_checker.ml b/src/value_checker.ml
index 69bfeec..65013d4 100644
--- a/src/value_checker.ml
+++ b/src/value_checker.ml
@@ -52,11 +52,11 @@ let validate_any validators constraints value =
     match validate_exists validators constraints value with
     | true ->
         let () = Buffer.clear buf in
-        true, ""
+        None
     | false ->
         let out = Buffer.contents buf in
         let () = Buffer.clear buf in
-        false, out
+        Some out
 
 (* If no constraints given, consider it valid.
    Otherwise consider it valid if it satisfies all constraints *)
@@ -71,8 +71,8 @@ let validate_all validators constraints value =
     match validate_forall validators constraints value with
     | true ->
         let () = Buffer.clear buf in
-        true, ""
+        None
     | false ->
         let out = Buffer.contents buf in
         let () = Buffer.clear buf in
-        false, out
+        Some out
diff --git a/src/value_checker.mli b/src/value_checker.mli
index 92a2f22..d4ae516 100644
--- a/src/value_checker.mli
+++ b/src/value_checker.mli
@@ -9,6 +9,6 @@ exception Bad_validator of string
 
 val validate_value : string -> Buffer.t -> value_constraint -> string -> bool
 
-val validate_any : string -> value_constraint list -> string -> bool * string
+val validate_any : string -> value_constraint list -> string -> string option
 
-val validate_all : string -> value_constraint list -> string -> bool * string
+val validate_all : string -> value_constraint list -> string -> string option
-- 
cgit v1.2.3