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.ml | 85 +++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 72 insertions(+), 13 deletions(-)

(limited to 'src/reference_tree.ml')

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 4889734..d6249b8 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -8,11 +8,6 @@ let node_type_to_yojson = function
     | 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"]
@@ -21,8 +16,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;
@@ -128,13 +123,13 @@ 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
+            let cs = (Value_checker.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
+            let cs = (Value_checker.External (n, Some a)) :: d.constraints in
             {d with constraints=cs}
         | Xml.Element ("validator", [("name", n)], _) ->
-            let cs = (External (n, None)) :: d.constraints in
+            let cs = (Value_checker.External (n, None)) :: d.constraints in
             {d with constraints=cs}
         | _ -> raise (Bad_interface_definition "Malformed constraint")
     in Xml.fold aux d c
@@ -143,13 +138,13 @@ let load_constraint_group_from_xml d c =
     let aux d c =
         match c with
         | Xml.Element ("regex", _, [Xml.PCData s]) ->
-            let cs = (Regex s) :: d.constraint_group in
+            let cs = (Value_checker.Regex s) :: d.constraint_group in
             {d with constraint_group=cs}
         | Xml.Element ("validator", [("name", n); ("argument", a)], _) ->
-            let cs = (External (n, Some a)) :: d.constraint_group in
+            let cs = (Value_checker.External (n, Some a)) :: d.constraint_group in
             {d with constraint_group=cs}
         | Xml.Element ("validator", [("name", n)], _) ->
-            let cs = (External (n, None)) :: d.constraint_group in
+            let cs = (Value_checker.External (n, None)) :: d.constraint_group in
             {d with constraint_group=cs}
         | _ -> raise (Bad_interface_definition "Malformed constraint")
     in Xml.fold aux d c
@@ -229,6 +224,70 @@ let load_from_xml reftree file =
         let s = Printf.sprintf ": line %d in file %s" pos.eline file in
         raise (Bad_interface_definition ((Xml.error_msg msg)^s))
 
+(* Validation function *)
+
+let has_illegal_characters name =
+    (** Checks if string name has illegal characters in it.
+        All whitespace, curly braces, square brackets, and quotes
+        are disallowed due to their special significance to the curly config
+        format parser *)
+    try Some (Pcre.get_substring (Pcre.exec ~pat:"[\\s\\{\\}\\[\\]\"\'#]" name) 0)
+    with Not_found -> None
+
+(** Takes a list of string that represents a configuration path that may have
+    node value at the end, validates it, and splits it into path and value parts.
+
+   A list of strings is a valid path that can be created in the config tree unless:
+     1. It's a tag node without a child
+     2. It's a non-valueless leaf node without a value
+     3. It's a valueless node with a value
+     4. It's a non-valueless leaf node with garbage after the value
+     5. It's a non-leaf, non-tag node with a name that doesn't exist
+        in the reference tree
+ *)
+let validate_path validators_dir node path =
+    let show_path p = Printf.sprintf "[%s]" @@ Util.string_of_list (List.rev p) in
+    let rec aux node path acc =
+        let data = Vytree.data_of_node node in
+        match data.node_type with
+        | Leaf ->
+            (match path with
+             | [] ->
+                 if data.valueless then (List.rev acc, None)
+                 else raise (Validation_error
+                   (Printf.sprintf "Node %s requires a value" (show_path acc) ))
+             | [p] ->
+                 if not data.valueless then
+                     (if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, Some p)
+                     else raise (Validation_error data.constraint_error_message))
+                 else raise (Validation_error
+                   (Printf.sprintf "Node %s cannot have a value" (show_path acc)))
+             | _ -> raise (Validation_error (Printf.sprintf "Path %s is too long" (show_path acc))))
+        | Tag ->
+            (match path with
+             | p :: p' :: ps ->
+                 (match (has_illegal_characters p) with
+                 | Some c -> raise (Validation_error (Printf.sprintf "Illegal character \"%s\" in node name \"%s\"" c p))
+                 | None ->
+                     if (Value_checker.validate_any validators_dir data.constraints p) then
+                         let child = Vytree.find node p' in
+                         (match child with
+                          | Some c -> aux c ps (p' :: p :: acc)
+                          | None -> raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p')))
+                     else raise (Validation_error (Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc))))
+             | [p] -> if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, None)
+                          else raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p))
+             | _ -> raise (Validation_error (Printf.sprintf "Path %s is incomplete" (show_path acc))))
+        | Other ->
+            (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 -> raise (Validation_error ((Printf.sprintf "Path %s is incomplete" (show_path acc))))))
+    in aux node path []
+
 let is_multi reftree path =
     let data = Vytree.get_data reftree path in
     data.multi
-- 
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.ml')

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.ml')

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.ml')

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 8bb9e607eb1c7b0a701292a36583c91f4a0cdc7b Mon Sep 17 00:00:00 2001
From: John Estabrook <jestabro@vyos.io>
Date: Thu, 24 Oct 2024 11:04:39 -0500
Subject: T6718: update value_checker to return validator output on error

---
 src/dune              |   2 +-
 src/reference_tree.ml | 140 +++++++++++++++++++++++++++++++++++++-------------
 src/value_checker.ml  |  80 ++++++++++++++++++++---------
 src/value_checker.mli |   6 ++-
 4 files changed, 165 insertions(+), 63 deletions(-)

(limited to 'src/reference_tree.ml')

diff --git a/src/dune b/src/dune
index 2bbe602..0932138 100644
--- a/src/dune
+++ b/src/dune
@@ -6,7 +6,7 @@
 (library
  (name vyos1x)
  (public_name vyos1x-config)
- (libraries yojson menhirLib fileutils pcre xml-light)
+ (libraries yojson menhirLib fileutils pcre xml-light unix containers)
  (preprocess (pps ppx_deriving_yojson))
  (foreign_stubs
   (language c)
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 353a152..6472cb5 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -245,11 +245,12 @@ let has_illegal_characters name =
 
    A list of strings is a valid path that can be created in the config tree unless:
      1. It's a tag node without a child
-     2. It's a non-valueless leaf node without a value
-     3. It's a valueless node with a value
-     4. It's a non-valueless leaf node with garbage after the value
-     5. It's a non-leaf, non-tag node with a name that doesn't exist
-        in the reference tree
+     2. It's a tag node with an invalid tag value
+     3. It's a non-valueless leaf node without a value
+     4. It's a valueless leaf node with a value
+     5. It's a non-valueless leaf node with an invalid value
+     6. It's a node that is neither leaf nor tag value with a name that
+        doesn't exist in the reference tree
  *)
 let validate_path validators_dir node path =
     let show_path p = Printf.sprintf "[%s]" @@ Util.string_of_list (List.rev p) in
@@ -257,41 +258,106 @@ let validate_path validators_dir node path =
         let data = Vytree.data_of_node node in
         match data.node_type with
         | Leaf ->
-            (match path with
-             | [] ->
-                 if data.valueless then (List.rev acc, None)
-                 else raise (Validation_error
-                   (Printf.sprintf "Node %s requires a value" (show_path acc) ))
-             | [p] ->
+            begin
+            match path with
+            | [] ->
+                if data.valueless then (List.rev acc, None)
+                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
-                     (if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, Some p)
-                     else raise (Validation_error data.constraint_error_message))
-                 else raise (Validation_error
-                   (Printf.sprintf "Node %s cannot have a value" (show_path acc)))
-             | _ -> raise (Validation_error (Printf.sprintf "Path %s is too long" (show_path acc))))
+                     let res, out =
+                         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 ->
+                        raise (Validation_error (out ^ data.constraint_error_message))
+                 else
+                     let msg = Printf.sprintf "Node %s cannot have a value" (show_path acc)
+                     in raise (Validation_error msg)
+            | _ ->
+                let msg = Printf.sprintf "Path %s is too long" (show_path acc)
+                in raise (Validation_error msg)
+            end
         | Tag ->
-            (match path with
-             | p :: p' :: ps ->
-                 (match (has_illegal_characters p) with
-                 | Some c -> raise (Validation_error (Printf.sprintf "Illegal character \"%s\" in node name \"%s\"" c p))
-                 | None ->
-                     if (Value_checker.validate_any validators_dir data.constraints p) then
-                         let child = Vytree.find node p' in
-                         (match child with
-                          | Some c -> aux c ps (p' :: p :: acc)
-                          | None -> raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p')))
-                     else raise (Validation_error (Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc))))
-             | [p] -> if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, None)
-                          else raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p))
-             | _ -> raise (Validation_error (Printf.sprintf "Path %s is incomplete" (show_path acc))))
+            begin
+            match path with
+            | p :: p' :: ps ->
+                begin
+                match (has_illegal_characters p) with
+                | Some c ->
+                    let msg =
+                        Printf.sprintf "Illegal character \"%s\" in node name \"%s\"" c p
+                    in raise (Validation_error msg)
+                | None ->
+                    let res, out =
+                        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 ->
+                        let child = Vytree.find node p' in
+                        begin
+                        match child with
+                        | Some c -> aux c ps (p' :: p :: acc)
+                        | None ->
+                            let msg =
+                                Printf.sprintf "Node %s has no child %s" (show_path acc) p'
+                            in raise (Validation_error msg)
+                        end
+                    | false ->
+                        let msg =
+                            Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)
+                        in
+                        let ret = Printf.sprintf "%s\n%s\n%s" out data.constraint_error_message msg
+                        in raise (Validation_error ret)
+                    end
+                end
+            | [p] ->
+                begin
+                match (has_illegal_characters p) with
+                | Some c ->
+                    let msg =
+                        Printf.sprintf "Illegal character \"%s\" in node name \"%s\"" c p
+                    in raise (Validation_error msg)
+                | None ->
+                    let res, out =
+                        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 ->
+                        let msg =
+                            Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)
+                        in
+                        let ret = Printf.sprintf "%s\n%s\n%s" out data.constraint_error_message msg
+                        in raise (Validation_error ret)
+                    end
+                end
+            | _ ->
+                let msg =
+                    Printf.sprintf "Configuration path %s requires a value" (show_path acc)
+                in raise (Validation_error msg)
+            end
         | Other ->
-            (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 -> raise (Validation_error ((Printf.sprintf "Path %s is incomplete" (show_path acc))))))
+            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 ->
+                    let msg = Printf.sprintf "Path %s is incomplete" (show_path acc)
+                    in raise (Validation_error msg)
+            end
     in aux node path []
 
 let is_multi reftree path =
diff --git a/src/value_checker.ml b/src/value_checker.ml
index 818185a..69bfeec 100644
--- a/src/value_checker.ml
+++ b/src/value_checker.ml
@@ -1,7 +1,6 @@
 module F = Filename
 
-(*type value_constraint = Regex of string | External of string * string
-option*)
+(*type value_constraint = Regex of string | External of string * string option*)
 type value_constraint =
     | Regex of string [@name "regex"]
     | External of string * string option [@name "exec"]
@@ -9,36 +8,71 @@ type value_constraint =
 
 exception Bad_validator of string
 
-let validate_value dir value_constraint value =
+let validate_value dir buf value_constraint value =
     match value_constraint with
     | Regex s ->
-        (try
-           let _ = Pcre.exec ~pat:s value in true
+      (try
+          let _ = Pcre.exec ~pat:(Printf.sprintf "^%s$" s) value in true
        with Not_found -> false)
     | External (v, c) ->
-        (* XXX: Using Unix.system is a bad idea on multiple levels,
-                especially when the input comes directly from the user...
-                We should do something about it.
-         *)
+      (* XXX: Unix.open_process_in is "shelling out", which is a bad idea on multiple levels,
+         especially when the input comes directly from the user...
+         We should do something about it.
+       *)
         let validator = F.concat dir v in
-        let arg = Option.value c ~default:"" in
-        let safe_arg = Printf.sprintf "'%s'" (Pcre.qreplace ~pat:"\"" ~templ:"\\\"" arg) in
-        let result = Unix.system (Printf.sprintf "%s %s %s" validator safe_arg value) in
+        let cmd =
+            match c with
+            | Some arg ->
+                let safe_arg = Printf.sprintf "'%s'" (Pcre.qreplace ~pat:"\"" ~templ:"\\\"" arg) in
+                Printf.sprintf "%s %s \'%s\' 2>&1" validator safe_arg value
+            | None ->
+                Printf.sprintf "%s \'%s\' 2>&1" validator value
+        in
+        let chan = Unix.open_process_in cmd in
+        let out = try CCIO.read_all chan with _ -> "" in
+        let result = Unix.close_process_in chan in
         match result with
         | Unix.WEXITED 0 -> true
-        | Unix.WEXITED 127 -> raise (Bad_validator (Printf.sprintf "Could not execute validator %s" validator))
-        | _ -> false
+        | Unix.WEXITED 127 ->
+            raise (Bad_validator (Printf.sprintf "Could not execute validator %s" validator))
+        | _ ->
+            let () = Buffer.add_string buf out in
+            false
 
 (* If no constraints given, consider it valid.
-   Otherwise consider it valid if it satisfies at least
-   one constraint *)
+   Otherwise consider it valid if it satisfies at least one constraint *)
 let validate_any validators constraints value =
-    let rec aux validators constraints value  =
+    let buf = Buffer.create 4096 in
+    let validate_exists validators constraints value =
         match constraints with
-        | [] -> false
-        | c :: cs -> if validate_value validators c value then true
-                     else aux validators cs value
+        | [] -> true
+        | _ ->
+            List.exists (fun c -> validate_value validators buf c value) constraints
     in
-    match constraints with
-    | [] -> true
-    | _ -> aux validators constraints value
+    match validate_exists validators constraints value with
+    | true ->
+        let () = Buffer.clear buf in
+        true, ""
+    | false ->
+        let out = Buffer.contents buf in
+        let () = Buffer.clear buf in
+        false, out
+
+(* If no constraints given, consider it valid.
+   Otherwise consider it valid if it satisfies all constraints *)
+let validate_all validators constraints value =
+    let buf = Buffer.create 4096 in
+    let validate_forall validators constraints value =
+        match constraints with
+        | [] -> true
+        | _ ->
+            List.for_all (fun c -> validate_value validators buf c value) constraints
+    in
+    match validate_forall validators constraints value with
+    | true ->
+        let () = Buffer.clear buf in
+        true, ""
+    | false ->
+        let out = Buffer.contents buf in
+        let () = Buffer.clear buf in
+        false, out
diff --git a/src/value_checker.mli b/src/value_checker.mli
index b5091f5..92a2f22 100644
--- a/src/value_checker.mli
+++ b/src/value_checker.mli
@@ -7,6 +7,8 @@ type value_constraint =
 
 exception Bad_validator of string
 
-val validate_value : string -> value_constraint -> string -> bool
+val validate_value : string -> Buffer.t -> value_constraint -> string -> bool
 
-val validate_any : string -> value_constraint list -> string -> bool
+val validate_any : string -> value_constraint list -> string -> bool * string
+
+val validate_all : string -> value_constraint list -> string -> bool * 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.ml')

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


From 9ff89e508f81ce71c9073f096fd27c73d4259987 Mon Sep 17 00:00:00 2001
From: John Estabrook <jestabro@vyos.io>
Date: Thu, 24 Oct 2024 11:04:39 -0500
Subject: T6718: format error output

---
 src/reference_tree.ml | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

(limited to 'src/reference_tree.ml')

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index bda7b0e..0efaf56 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -240,6 +240,10 @@ let has_illegal_characters name =
     try Some (Pcre.get_substring (Pcre.exec ~pat:"[\\s\\{\\}\\[\\]\"\'#]" name) 0)
     with Not_found -> None
 
+let format_out l =
+    let fl = List.filter (fun s -> (String.length s) > 0) l in
+    String.concat "\n\n" fl
+
 (** Takes a list of string that represents a configuration path that may have
     node value at the end, validates it, and splits it into path and value parts.
 
@@ -275,7 +279,8 @@ let validate_path validators_dir node path =
                      match res with
                      | None -> ()
                      | Some out ->
-                        raise (Validation_error (out ^ data.constraint_error_message))
+                        let ret = format_out [out; data.constraint_error_message]
+                        in raise (Validation_error ret)
                  else
                      let msg = Printf.sprintf "Node %s cannot have a value" (show_path acc)
                      in raise (Validation_error msg)
@@ -314,7 +319,7 @@ let validate_path validators_dir node path =
                         let msg =
                             Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)
                         in
-                        let ret = Printf.sprintf "%s\n%s\n%s" out data.constraint_error_message msg
+                        let ret = format_out [out; data.constraint_error_message; msg]
                         in raise (Validation_error ret)
                     end
                 end
@@ -337,7 +342,7 @@ let validate_path validators_dir node path =
                         let msg =
                             Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)
                         in
-                        let ret = Printf.sprintf "%s\n%s\n%s" out data.constraint_error_message msg
+                        let ret = format_out [out; data.constraint_error_message; msg]
                         in raise (Validation_error ret)
                     end
                 end
-- 
cgit v1.2.3