T6718: move validate_path from vyconf

6 files changed, 152 insertions, 20 deletions

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
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
diff --git a/src/util.ml b/src/util.ml
index 168589d..047cfc9 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -85,3 +85,19 @@ let lexical_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
+
+(** Convert a list of strings to a string of unquoted, space separated words *)
+let string_of_list ss =
+    let rec aux xs acc =
+        match xs with
+        | [] -> acc
+        | x :: xs' -> aux xs' (Printf.sprintf "%s %s" acc x)
+    in
+    match ss with
+    | [] -> ""
+    | x :: xs -> Printf.sprintf "%s%s" x (aux xs "")
+
+(** Convert a list of strings to JSON *)
+let json_of_list ss =
+    let ss = List.map (fun x -> `String x) ss in
+    Yojson.Safe.to_string (`List ss)
diff --git a/src/util.mli b/src/util.mli
index f9bfba6..e882607 100644
--- a/src/util.mli
+++ b/src/util.mli
@@ -9,3 +9,7 @@ val default : 'a -> 'a option -> 'a
 val lexical_numeric_compare : string -> string -> int
 
 val absolute_path : FilePath.filename -> FilePath.filename
+
+val string_of_list : string list -> string
+
+val json_of_list : string list -> string
diff --git a/src/value_checker.ml b/src/value_checker.ml
new file mode 100644
index 0000000..818185a
--- /dev/null
+++ b/src/value_checker.ml
@@ -0,0 +1,44 @@
+module F = Filename
+
+(*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"]
+    [@@deriving yojson]
+
+exception Bad_validator of string
+
+let validate_value dir value_constraint value =
+    match value_constraint with
+    | Regex s ->
+        (try
+           let _ = Pcre.exec ~pat: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.
+         *)
+        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
+        match result with
+        | Unix.WEXITED 0 -> true
+        | Unix.WEXITED 127 -> raise (Bad_validator (Printf.sprintf "Could not execute validator %s" validator))
+        | _ -> false
+
+(* If no constraints given, consider it valid.
+   Otherwise consider it valid if it satisfies at least
+   one constraint *)
+let validate_any validators constraints value =
+    let rec aux validators constraints value  =
+        match constraints with
+        | [] -> false
+        | c :: cs -> if validate_value validators c value then true
+                     else aux validators cs value
+    in
+    match constraints with
+    | [] -> true
+    | _ -> aux validators constraints value
diff --git a/src/value_checker.mli b/src/value_checker.mli
new file mode 100644
index 0000000..b5091f5
--- /dev/null
+++ b/src/value_checker.mli
@@ -0,0 +1,12 @@
+(*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"]
+    [@@deriving yojson]
+
+exception Bad_validator of string
+
+val validate_value : string -> value_constraint -> string -> bool
+
+val validate_any : string -> value_constraint list -> string -> bool