summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/config_diff.ml26
-rw-r--r--src/config_diff.mli10
-rw-r--r--src/config_tree.ml48
-rw-r--r--src/config_tree.mli11
-rw-r--r--src/dune2
-rw-r--r--src/generate.ml9
-rw-r--r--src/generate.mli2
-rw-r--r--src/internal.ml29
-rw-r--r--src/internal.mli15
-rw-r--r--src/reference_tree.ml230
-rw-r--r--src/reference_tree.mli22
-rw-r--r--src/util.ml25
-rw-r--r--src/util.mli6
-rw-r--r--src/value_checker.ml84
-rw-r--r--src/value_checker.mli14
-rw-r--r--src/vyos1x_parser.mly4
-rw-r--r--vyos1x-config.opam2
17 files changed, 489 insertions, 50 deletions
diff --git a/src/config_diff.ml b/src/config_diff.ml
index 3529a5d..6fd57c6 100644
--- a/src/config_diff.ml
+++ b/src/config_diff.ml
@@ -27,6 +27,7 @@ module Diff_cstore = struct
type t = { left: Config_tree.t;
right: Config_tree.t;
handle: int;
+ out: string;
}
end
@@ -43,19 +44,23 @@ let eval_result : type a. a result -> a = function
type 'a diff_func = ?recurse:bool -> string list -> 'a result -> change -> 'a result
let make_diff_trees l r = Diff_tree { left = l; right = r;
- add = (Config_tree.make "");
- sub = (Config_tree.make "");
- del = (Config_tree.make "");
- inter = (Config_tree.make "");
+ add = (Config_tree.make "");
+ sub = (Config_tree.make "");
+ del = (Config_tree.make "");
+ inter = (Config_tree.make "");
}
-let make_diff_string l r = Diff_string {
- left = l; right = r;
- skel = (Config_tree.make "");
- ppath = [];
- udiff = "";
+let make_diff_string l r = Diff_string { left = l; right = r;
+ skel = (Config_tree.make "");
+ ppath = [];
+ udiff = "";
}
+let make_diff_cstore l r h = Diff_cstore { left = l; right = r;
+ handle = h;
+ out = "";
+}
+
let name_of n = Vytree.name_of_node n
let data_of n = Vytree.data_of_node n
let children_of n = Vytree.children_of_node n
@@ -75,6 +80,9 @@ module TreeOrd = struct
end
module ChildrenS = Set.Make(TreeOrd)
+(* unordered set of values *)
+module ValueSet = Set.Make(String)
+
let (^~) (node : Config_tree.t) (node' : Config_tree.t) =
name_of node = name_of node' &&
(data_of node).values <> (data_of node').values
diff --git a/src/config_diff.mli b/src/config_diff.mli
index 6adf5a7..af8f87d 100644
--- a/src/config_diff.mli
+++ b/src/config_diff.mli
@@ -1,3 +1,4 @@
+type change = Unchanged | Added | Subtracted | Updated of string list
module Diff_tree : sig
type t = { left: Config_tree.t;
@@ -11,7 +12,7 @@ end
module Diff_string : sig
type t = { left: Config_tree.t;
- right : Config_tree.t;
+ right: Config_tree.t;
skel: Config_tree.t;
ppath: string list;
udiff: string;
@@ -22,6 +23,7 @@ module Diff_cstore : sig
type t = { left: Config_tree.t;
right: Config_tree.t;
handle: int;
+ out: string;
}
end
@@ -30,6 +32,11 @@ type _ result =
| Diff_string : Diff_string.t -> Diff_string.t result
| Diff_cstore : Diff_cstore.t -> Diff_cstore.t result
+val eval_result : 'a result -> 'a
+
+type 'a diff_func = ?recurse:bool -> string list -> 'a result -> change -> 'a result
+val diff : string list -> 'a diff_func -> 'a result -> Config_tree.t option * Config_tree.t option -> 'a result
+
exception Incommensurable
exception Empty_comparison
exception Nonexistent_child
@@ -38,3 +45,4 @@ val diff_tree : string list -> Config_tree.t -> Config_tree.t -> Config_tree.t
val show_diff : ?cmds:bool -> string list -> Config_tree.t -> Config_tree.t -> string
val tree_union : Config_tree.t -> Config_tree.t -> Config_tree.t
val mask_tree : Config_tree.t -> Config_tree.t -> Config_tree.t
+val make_diff_cstore : Config_tree.t -> Config_tree.t -> int -> Diff_cstore.t result
diff --git a/src/config_tree.ml b/src/config_tree.ml
index 531cae8..89f85bf 100644
--- a/src/config_tree.ml
+++ b/src/config_tree.ml
@@ -10,6 +10,7 @@ type config_node_data = {
values: string list;
comment: string option;
tag: bool;
+ leaf: bool;
} [@@deriving yojson]
type t = config_node_data Vytree.t [@@deriving yojson]
@@ -18,8 +19,11 @@ let default_data = {
values = [];
comment = None;
tag = false;
+ leaf = false;
}
+let default = Vytree.make default_data ""
+
let make name = Vytree.make default_data name
let op_to_string op =
@@ -28,7 +32,7 @@ let op_to_string op =
| Delete -> "delete"
let replace_value node path value =
- let data = {default_data with values=[value]} in
+ let data = {default_data with values=[value]; leaf=true} in
Vytree.update node path data
let add_value node path value =
@@ -39,18 +43,25 @@ let add_value node path value =
| Some _ -> raise Duplicate_value
| None ->
let values = values @ [value] in
- Vytree.update node path ({data with values=values})
+ Vytree.update node path ({data with values=values; leaf=true})
let delete_value node path value =
let data = Vytree.data_of_node @@ Vytree.get node path in
let values = Vylist.remove (fun x -> x = value) data.values in
- Vytree.update node path {data with values=values}
+ Vytree.update node path {data with values=values; leaf=true}
let set_value node path value behaviour =
match behaviour with
| AddValue -> add_value node path value
| ReplaceValue -> replace_value node path value
+let create_node node path =
+ if (Vytree.exists node path) then raise Useless_set
+ else
+ let path_existing = Vytree.get_existent_path node path in
+ let path_remaining = Vylist.complement path path_existing in
+ Vytree.insert_multi_level default_data node path_existing path_remaining default_data
+
let set node path value behaviour =
if (Vytree.exists node path) then
(match value with
@@ -60,7 +71,8 @@ let set node path value behaviour =
let path_existing = Vytree.get_existent_path node path in
let path_remaining = Vylist.complement path path_existing in
let values = match value with None -> [] | Some v -> [v] in
- Vytree.insert_multi_level default_data node path_existing path_remaining {default_data with values=values}
+ let end_data = {default_data with values=values; leaf=true} in
+ Vytree.insert_multi_level default_data node path_existing path_remaining end_data
let get_values node path =
let node' = Vytree.get node path in
@@ -101,6 +113,14 @@ let is_tag node path =
let data = Vytree.get_data node path in
data.tag
+let set_leaf node path leaf =
+ let data = Vytree.get_data node path in
+ Vytree.update node path {data with leaf=leaf}
+
+let is_leaf node path =
+ let data = Vytree.get_data node path in
+ data.leaf
+
let get_subtree ?(with_node=false) node path =
try
let n = Vytree.get node path in
@@ -132,13 +152,12 @@ struct
(* Now handle the different cases for nodes with and without children *)
match child_names with
| [] ->
- (* This is a leaf node *)
let values = List.map Util.escape_string data.values in
let cmds =
begin
match values with
| [] ->
- (* Valueless leaf node *)
+ (* Valueless leaf node or a non-leaf node *)
String.concat " " new_path |> Printf.sprintf "%s %s" (op_to_string op)
| [v] ->
(* Single value, just one command *)
@@ -150,7 +169,6 @@ struct
in
if comment_cmd = "" then cmds else Printf.sprintf "%s\n%s" cmds comment_cmd
| _ :: _ ->
- (* A node with children *)
let children = List.map (fun n -> Vytree.get ct [n]) child_names in
let rendered_children = List.map (render_commands ~op:op new_path) children in
let cmds = String.concat "\n" rendered_children in
@@ -184,10 +202,14 @@ struct
let data = Vytree.data_of_node node in
let is_tag = data.tag in
let comment = render_comment indent_str data.comment in
- let values = render_values ~ord_val:ord_val indent_str name data.values in
let children = Vytree.children_of_node node in
match children with
- | [] -> Printf.sprintf "%s%s" comment values
+ | [] ->
+ if data.leaf then
+ let values = render_values ~ord_val:ord_val indent_str name data.values in
+ Printf.sprintf "%s%s" comment values
+ else
+ Printf.sprintf "%s%s%s {\n%s}\n" comment indent_str name indent_str
| _ :: _ ->
if is_tag then
begin
@@ -267,6 +289,14 @@ let render_commands ?(op=Set) node path =
let render_config ?(ord_val=false) = Renderer.render_config ~ord_val:ord_val
+let render_at_level node path =
+ let node =
+ match path with
+ | [] -> node
+ | _ -> Vytree.get node path
+ in
+ render_config node
+
let render_json = JSONRenderer.render_json
let render_json_ast c = to_yojson c |> Yojson.Safe.to_string
diff --git a/src/config_tree.mli b/src/config_tree.mli
index 990bb49..c05bab9 100644
--- a/src/config_tree.mli
+++ b/src/config_tree.mli
@@ -10,14 +10,19 @@ type config_node_data = {
values : string list;
comment : string option;
tag : bool;
+ leaf: bool;
} [@@deriving yojson]
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
+
val set : t -> string list -> string option -> value_behaviour -> t
val delete : t -> string list -> string option -> t
@@ -34,6 +39,10 @@ val set_tag : t -> string list -> bool -> t
val is_tag : t -> string list -> bool
+val set_leaf : t -> string list -> bool -> t
+
+val is_leaf : t -> string list -> bool
+
val get_subtree : ?with_node:bool -> t -> string list -> t
val render_commands : ?op:command -> t -> string list -> string
@@ -43,3 +52,5 @@ val render_config : ?ord_val:bool -> t -> string
val render_json : t -> string
val render_json_ast : t -> string
+
+val render_at_level : t -> string list -> string
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/generate.ml b/src/generate.ml
index e7801c5..632c678 100644
--- a/src/generate.ml
+++ b/src/generate.ml
@@ -2,6 +2,8 @@
exception Load_error of string
exception Write_error of string
+module I = Internal.Make(Reference_tree)
+
let load_interface_definitions dir =
let open Reference_tree in
let dir_paths = FileUtil.ls dir in
@@ -20,7 +22,7 @@ let load_interface_definitions dir =
| Error msg -> Error msg end
with Bad_interface_definition msg -> Error msg
-let reference_tree_to_json from_dir to_file =
+let reference_tree_to_json ?(internal_cache="") from_dir to_file =
let ref_tree_result =
load_interface_definitions from_dir
in
@@ -36,4 +38,7 @@ let reference_tree_to_json from_dir to_file =
with Sys_error msg -> raise (Write_error msg)
in
Printf.fprintf oc "%s" out;
- close_out oc
+ close_out oc;
+ match internal_cache with
+ | "" -> ()
+ | _ -> I.write_internal ref_tree internal_cache
diff --git a/src/generate.mli b/src/generate.mli
index e121d1f..6f8e775 100644
--- a/src/generate.mli
+++ b/src/generate.mli
@@ -2,4 +2,4 @@ exception Load_error of string
exception Write_error of string
val load_interface_definitions : string -> (Reference_tree.t, string) result
-val reference_tree_to_json : string -> string -> unit
+val reference_tree_to_json : ?internal_cache:string -> string -> string -> unit
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 7f6cc25..0efaf56 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -8,20 +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;
+ 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;
@@ -33,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
@@ -44,6 +46,7 @@ exception Validation_error of string
let default_data = {
node_type = Other;
constraints = [];
+ constraint_group = [];
constraint_error_message = "Invalid value";
completion_help = [];
help = "No help available";
@@ -77,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
@@ -116,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
@@ -126,15 +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 = (Value_checker.Regex s) :: d.constraint_group in
+ {d with constraint_group=cs}
+ | Xml.Element ("validator", [("name", n); ("argument", a)], _) ->
+ let cs = (Value_checker.External (n, Some a)) :: d.constraint_group in
+ {d with constraint_group=cs}
+ | 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: " ^ Xml.to_string c))
in Xml.fold aux d c
let data_from_xml d x =
@@ -149,11 +167,12 @@ let data_from_xml d x =
| Xml.Element ("constraintErrorMessage", _, [Xml.PCData s]) ->
{d with constraint_error_message=s}
| Xml.Element ("constraint", _, _) -> load_constraint_from_xml d x
+ | Xml.Element ("constraintGroup", _, _) -> load_constraint_group_from_xml d x
| Xml.Element ("priority", _, [Xml.PCData i]) ->
{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 =
@@ -211,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
@@ -257,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 =
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index 0e70ff5..a8d4efa 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -3,20 +3,16 @@ 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"]
| Script of string [@name "script"]
- [@@deriving to_yojson]
+ [@@deriving yojson]
type ref_node_data = {
node_type: node_type;
- constraints: 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;
@@ -28,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
@@ -42,6 +38,12 @@ 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 -> unit
+
+val split_path : t -> string list -> string list * string option
+
val is_multi : t -> string list -> bool
val is_hidden : t -> string list -> bool
@@ -62,4 +64,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
diff --git a/src/util.ml b/src/util.ml
index 168589d..cbee955 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -85,3 +85,28 @@ 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)
+
+(** Split string on whitespace, excluding single-quoted phrases,
+ as needed for parsing vyconf request path option **)
+let list_of_path p =
+ let seg = String.trim p |> String.split_on_char '\'' in
+ match seg with
+ | [h] -> Pcre.split ~pat:"\\s+" h
+ | h :: h' :: _ -> (Pcre.split ~pat:"\\s+" h) @ [h']
+ | _ -> []
diff --git a/src/util.mli b/src/util.mli
index f9bfba6..9a52268 100644
--- a/src/util.mli
+++ b/src/util.mli
@@ -9,3 +9,9 @@ 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
+
+val list_of_path : string -> string list
diff --git a/src/value_checker.ml b/src/value_checker.ml
new file mode 100644
index 0000000..9e6dae8
--- /dev/null
+++ b/src/value_checker.ml
@@ -0,0 +1,84 @@
+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 buf value_constraint value =
+ match value_constraint with
+ | Regex s ->
+ (try
+ let _ = Pcre.exec ~pat:(Printf.sprintf "^%s$" s) value in true
+ with Not_found -> false)
+ | External (v, c) ->
+ (* 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 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 () = Unix.putenv "vyos_libexec_dir" "/usr/libexec/vyos" in
+ let () = Unix.putenv "vyos_validators_dir" "/usr/libexec/vyos/validators" 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))
+ | _ ->
+ 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 *)
+let validate_any validators constraints value =
+ let buf = Buffer.create 4096 in
+ let validate_exists validators constraints value =
+ match constraints with
+ | [] -> true
+ | _ ->
+ try
+ List.exists (fun c -> validate_value validators buf c value) constraints
+ with Bad_validator e -> let () = Buffer.add_string buf e in false
+ in
+ match validate_exists validators constraints value with
+ | true ->
+ let () = Buffer.clear buf in
+ None
+ | false ->
+ let out = Buffer.contents buf in
+ let () = Buffer.clear buf in
+ Some 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
+ | _ ->
+ try
+ List.for_all (fun c -> validate_value validators buf c value) constraints
+ with Bad_validator e -> let () = Buffer.add_string buf e in false
+ in
+ match validate_forall validators constraints value with
+ | true ->
+ let () = Buffer.clear buf in
+ None
+ | false ->
+ let out = Buffer.contents buf in
+ let () = Buffer.clear buf in
+ Some out
diff --git a/src/value_checker.mli b/src/value_checker.mli
new file mode 100644
index 0000000..d4ae516
--- /dev/null
+++ b/src/value_checker.mli
@@ -0,0 +1,14 @@
+(*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 -> Buffer.t -> value_constraint -> string -> bool
+
+val validate_any : string -> value_constraint list -> string -> string option
+
+val validate_all : string -> value_constraint list -> string -> string option
diff --git a/src/vyos1x_parser.mly b/src/vyos1x_parser.mly
index 8b2d7d8..d3ae5dc 100644
--- a/src/vyos1x_parser.mly
+++ b/src/vyos1x_parser.mly
@@ -49,10 +49,10 @@ value:
leaf_node_body:
| comment = comments;
name = IDENTIFIER; value = value;
- { Vytree.make_full {default_data with values=[value]; comment=comment} name []}
+ { Vytree.make_full {default_data with values=[value]; comment=comment; leaf=true} name []}
| comment = comments;
name = IDENTIFIER; (* valueless node *)
- { Vytree.make_full {default_data with comment=comment} name [] }
+ { Vytree.make_full {default_data with comment=comment; leaf=true} name [] }
;
leaf_node:
diff --git a/vyos1x-config.opam b/vyos1x-config.opam
index 589f918..d2c214e 100644
--- a/vyos1x-config.opam
+++ b/vyos1x-config.opam
@@ -1,6 +1,6 @@
opam-version: "2.0"
name: "vyos1x-config"
-version: "0.2"
+version: "0.3"
synopsis: "VyOS 1.x and EdgeOS config file manipulation library"
description: """
A library for parsing, manipulating, and exporting VyOS 1.x and EdgeOS config files.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 06:40:09 +0000