T6718: update value_checker to return validator output on error

4 files changed, 165 insertions, 63 deletions

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