Merge pull request #31 from jestabro/vyconf-minimal

T6718: use the vyconf daemon for validation of set commands

1 files changed, 202 insertions, 20 deletions

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 4889734..0efaf56 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -8,21 +8,22 @@ 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]
+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;
-    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;
@@ -34,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
 
@@ -79,7 +80,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
@@ -118,7 +119,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
@@ -128,30 +129,30 @@ 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")
+        | _ -> raise (Bad_interface_definition ("Malformed constraint: " ^ Xml.to_string c))
     in Xml.fold aux d c
 
 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")
+        | _ -> raise (Bad_interface_definition ("Malformed constraint: " ^ Xml.to_string c))
     in Xml.fold aux d c
 
 let data_from_xml d x =
@@ -171,7 +172,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 =
@@ -229,6 +230,176 @@ 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
+
+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.
+
+   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 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
+    let rec aux node path acc =
+        let data = Vytree.data_of_node node in
+        match data.node_type with
+        | Leaf ->
+            begin
+            match path with
+            | [] ->
+                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 =
+                         try Value_checker.validate_any validators_dir data.constraints p
+                         with Value_checker.Bad_validator msg -> raise (Validation_error msg)
+                     in
+                     match res with
+                     | None -> ()
+                     | Some out ->
+                        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)
+            | _ ->
+                let msg = Printf.sprintf "Path %s is too long" (show_path acc)
+                in raise (Validation_error msg)
+            end
+        | Tag ->
+            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 =
+                        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
+                    | None ->
+                        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
+                    | Some out ->
+                        let msg =
+                            Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)
+                        in
+                        let ret = format_out [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 =
+                        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
+                    | None -> ()
+                    | Some out ->
+                        let msg =
+                            Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)
+                        in
+                        let ret = format_out [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 ->
+            begin
+            match path with
+            | [] -> ()
+            | 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 []
+
+(* 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
@@ -275,6 +446,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 =