summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/config_diff.ml110
-rw-r--r--src/config_diff.mli12
-rw-r--r--src/config_file.ml44
-rw-r--r--src/config_file.mli4
-rw-r--r--src/config_tree.ml75
-rw-r--r--src/config_tree.mli15
-rw-r--r--src/dune2
-rw-r--r--src/generate.ml50
-rw-r--r--src/generate.mli5
-rw-r--r--src/internal.ml66
-rw-r--r--src/internal.mli19
-rw-r--r--src/reference_tree.ml318
-rw-r--r--src/reference_tree.mli44
-rw-r--r--src/tree_alg.ml68
-rw-r--r--src/util.ml74
-rw-r--r--src/util.mli22
-rw-r--r--src/value_checker.ml84
-rw-r--r--src/value_checker.mli14
-rw-r--r--src/vyos1x_lexer.mll2
-rw-r--r--src/vyos1x_parser.mly4
-rw-r--r--src/vytree.ml21
-rw-r--r--src/vytree.mli4
22 files changed, 957 insertions, 100 deletions
diff --git a/src/config_diff.ml b/src/config_diff.ml
index 3529a5d..87b2663 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
@@ -173,8 +181,6 @@ let clone ?(recurse=true) ?(set_values=None) old_root new_root path =
let path_remaining = Vylist.complement path path_existing in
clone_path ~recurse:recurse ~set_values:set_values old_root new_root path_existing path_remaining
-let is_empty l = (l = [])
-
(* define the diff_func *)
let decorate_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : change) =
match m with
@@ -197,14 +203,14 @@ let decorate_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : cha
let add_vals = ValueS.elements (ValueS.diff v_set ov_set) in
let inter_vals = ValueS.elements (ValueS.inter ov_set v_set) in
let sub_tree =
- if not (is_empty sub_vals) then
+ if not (Util.is_empty sub_vals) then
clone ~set_values:(Some sub_vals) res.left res.sub path
else
res.sub
in
let del_tree =
- if not (is_empty sub_vals) then
- if (is_empty add_vals) && (is_empty inter_vals) then
+ if not (Util.is_empty sub_vals) then
+ if (Util.is_empty add_vals) && (Util.is_empty inter_vals) then
(* delete whole node, not just values *)
clone ~set_values:(Some []) res.left res.del path
else
@@ -213,13 +219,13 @@ let decorate_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : cha
res.del
in
let add_tree =
- if not (is_empty add_vals) then
+ if not (Util.is_empty add_vals) then
clone ~set_values:(Some add_vals) res.right res.add path
else
res.add
in
let inter_tree =
- if not (is_empty inter_vals) then
+ if not (Util.is_empty inter_vals) then
clone ~set_values:(Some inter_vals) res.left res.inter path
else
res.inter
@@ -256,6 +262,33 @@ let diff_tree path left right =
let ret = make Config_tree.default_data "" [add_node; sub_node; del_node; int_node] in
ret
+(* convenience function needed for commit algorithm:
+ we need a hybrid tree between the 'del' tree and the 'sub' tree, namely:
+ in case the del tree has a terminal tag node (== all tag values have
+ been removed) add tag node values for proper removal in commit execution
+ *)
+
+let get_tagged_delete_tree dt =
+ let del_tree = Config_tree.get_subtree dt ["del"] in
+ let sub_tree = Config_tree.get_subtree dt ["sub"] in
+ let f (p, a) _t =
+ let q = List.rev p in
+ match q with
+ | [] -> (p, a)
+ | _ ->
+ if Config_tree.is_tag a q && Vytree.is_terminal_path a q then
+ let children = Vytree.children_of_path sub_tree q in
+ let insert_child path node name =
+ Vytree.insert ~position:Lexical node (path @ [name]) Config_tree.default_data
+ in
+ let a' = List.fold_left (insert_child q) a children in
+ (p, a')
+ else
+ (p, a)
+ in
+ snd (Vytree.fold_tree_with_path f ([], del_tree) del_tree)
+
+
(* the following builds a diff_func to return a unified diff string of
configs or config commands
*)
@@ -332,14 +365,14 @@ let unified_diff ?(cmds=false) ?recurse:_ (path : string list) (Diff_string res)
let sub_vals = ValueS.elements (ValueS.diff ov_set v_set) in
let add_vals = ValueS.elements (ValueS.diff v_set ov_set) in
let str_diff =
- if not (is_empty sub_vals) then
+ if not (Util.is_empty sub_vals) then
let sub_tree =
clone ~set_values:(Some sub_vals) res.left res.skel path
in str_diff ^ (removed_lines ~cmds:cmds sub_tree path)
else str_diff
in
let str_diff =
- if not (is_empty add_vals) then
+ if not (Util.is_empty add_vals) then
let add_tree =
clone ~set_values:(Some add_vals) res.right res.skel path
in str_diff ^ (added_lines ~cmds:cmds add_tree path)
@@ -390,14 +423,6 @@ let show_diff ?(cmds=false) path left right =
in
strs
-let is_terminal_path node path =
- try
- let n = Vytree.get node path in
- match (Vytree.children_of_node n) with
- | [] -> true
- | _ -> false
- with Vytree.Nonexistent_path -> false
-
(* mask function; mask applied on right *)
let mask_func ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
match m with
@@ -405,7 +430,7 @@ let mask_func ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
| Subtracted ->
(match path with
| [_] -> Diff_tree {res with left = Vytree.delete res.left path}
- | _ -> if not (is_terminal_path res.right (list_but_last path)) then
+ | _ -> if not (Vytree.is_terminal_path res.right (list_but_last path)) then
Diff_tree {res with left = Vytree.delete res.left path}
else Diff_tree (res))
| Unchanged -> Diff_tree (res)
@@ -424,29 +449,10 @@ let union_of_values (n : Config_tree.t) (m : Config_tree.t) =
let set_m = ValueS.of_list (data_of m).values in
ValueS.elements (ValueS.union set_n set_m)
-let union_of_children n m =
- let set_n = ChildrenS.of_list (children_of n) in
- let set_m = ChildrenS.of_list (children_of m) in
- ChildrenS.elements (ChildrenS.union set_n set_m)
-
-(* tree_union is currently used only for unit tests, so only values of data
- are considered. Should there be a reason to expose it in the future,
- consistency check and union of remaining data will need to be added.
- *)
-let rec tree_union s t =
- let child_of_union s t c =
- let s_c = Vytree.find s (name_of c) in
- let t_c = Vytree.find t (name_of c) in
- match s_c, t_c with
- | Some child, None -> clone s t [(name_of child)]
- | None, Some _ -> t
- | Some u, Some v ->
- if u ^~ v then
- let values = union_of_values u v in
- let data = {(data_of v) with Config_tree.values = values} in
- Vytree.replace t (Vytree.make data (name_of v))
- else
- Vytree.replace t (tree_union u v)
- | None, None -> raise Nonexistent_child
+let tree_union s t =
+ let f u v =
+ let values = union_of_values u v in
+ let data = {(data_of v) with Config_tree.values = values} in
+ Vytree.make_full data (name_of v) (children_of v)
in
- List.fold_left (fun x c -> child_of_union s x c) t (union_of_children s t)
+ Tree_alg.ConfigAlg.tree_union s t f
diff --git a/src/config_diff.mli b/src/config_diff.mli
index 6adf5a7..4262a58 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,11 +32,19 @@ 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
+val clone : ?recurse:bool -> ?set_values:string list option -> Config_tree.t -> Config_tree.t ->string list -> Config_tree.t
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
+val get_tagged_delete_tree : Config_tree.t -> Config_tree.t
diff --git a/src/config_file.ml b/src/config_file.ml
new file mode 100644
index 0000000..17d3f1b
--- /dev/null
+++ b/src/config_file.ml
@@ -0,0 +1,44 @@
+(* strip commponent version string *)
+let strip_version s =
+ let rex = Pcre.regexp ~flags:[`MULTILINE;`DOTALL] "(^//.*)" in
+ let res = Pcre.split ~max:0 ~rex s in
+ match res with
+ | h :: _ -> Ok h
+ | [] -> Error "Failure stripping version string from config"
+
+let load_config file =
+ try
+ let chan = open_in file in
+ let s = really_input_string chan (in_channel_length chan) in
+ let () = close_in chan in
+ let prep = strip_version s in
+ let s = match prep with
+ | Ok s -> s
+ | Error msg -> raise (Sys_error msg)
+ in
+ let config = Parser.from_string s in
+ Ok config
+ with
+ | Sys_error msg -> Error msg
+ | Util.Syntax_error (opt, msg) ->
+ begin
+ match opt with
+ | None ->
+ let out = Printf.sprintf "Parse error: %s\n" msg
+ in Error out
+ | Some (line, pos) ->
+ let out = Printf.sprintf "Parse error: %s line %d pos %d\n" msg line pos
+ in Error out
+ end
+
+let save_config ct file =
+ try
+ let s = Config_tree.render_config ct in
+ let chan = open_out file in
+ let () = output_string chan s in
+ let () = close_out chan in
+ let () = Unix.chmod file 0o664 in
+ Ok ()
+ with
+ Sys_error msg -> Error msg
+
diff --git a/src/config_file.mli b/src/config_file.mli
new file mode 100644
index 0000000..3a87b4a
--- /dev/null
+++ b/src/config_file.mli
@@ -0,0 +1,4 @@
+
+val load_config : string -> (Config_tree.t, string) result
+
+val save_config : Config_tree.t -> string -> (unit, string) result
diff --git a/src/config_tree.ml b/src/config_tree.ml
index 531cae8..4d0f5df 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,19 @@ let is_tag node path =
let data = Vytree.get_data node path in
data.tag
+let is_tag_value node path =
+ match path with
+ | [] | [_] -> false
+ | _ -> is_tag node (Util.drop_last path)
+
+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
@@ -110,6 +135,28 @@ let get_subtree ?(with_node=false) node path =
Vytree.make_full default_data "" (Vytree.children_of_node n)
with Vytree.Nonexistent_path -> make ""
+let value_paths_of_tree node =
+ let func ct (p, a) _t =
+ match p with
+ | [] -> (p, a)
+ | _ ->
+ let q = List.rev p in
+ if not (Vytree.is_terminal_path ct q) then
+ (p, a)
+ else
+ let vals = get_values ct q in
+ match vals with
+ | [] -> (p, q::a)
+ | _ as vs ->
+ let a' =
+ let f acc v =
+ let q' = q @ [v] in
+ q'::acc
+ in List.fold_left f a vs
+ in (p, a')
+ in List.rev (snd (Vytree.fold_tree_with_path (func node) ([], []) node))
+
+
module Renderer =
struct
(* Rendering configs as set commands *)
@@ -132,13 +179,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 +196,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 +229,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 +316,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..be746a0 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,8 +39,16 @@ val set_tag : t -> string list -> bool -> t
val is_tag : t -> string list -> bool
+val is_tag_value : 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 value_paths_of_tree : t -> string list list
+
val render_commands : ?op:command -> t -> string list -> string
val render_config : ?ord_val:bool -> t -> string
@@ -43,3 +56,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..28f0be1 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 interface_definitions_to_cache from_dir cache_path =
let ref_tree_result =
load_interface_definitions from_dir
in
@@ -29,11 +31,55 @@ let reference_tree_to_json from_dir to_file =
| Ok ref -> ref
| Error msg -> raise (Load_error msg)
in
+ I.write_internal ref_tree cache_path
+
+let reference_tree_cache_to_json cache_path render_file =
+ let ref_tree =
+ I.read_internal cache_path
+ in
let out = Reference_tree.render_json ref_tree in
let oc =
try
- open_out to_file
+ open_out render_file
with Sys_error msg -> raise (Write_error msg)
in
Printf.fprintf oc "%s" out;
close_out oc
+
+let merge_reference_tree_cache cache_dir primary_name result_name =
+ let file_arr = Sys.readdir cache_dir in
+ let file_list' = Array.to_list file_arr in
+ let file_list =
+ List.filter (fun x -> x <> primary_name && x <> result_name) file_list' in
+ let file_path_list =
+ List.map (FilePath.concat cache_dir) file_list in
+ let primary_tree = I.read_internal (FilePath.concat cache_dir primary_name) in
+ let ref_trees = List.map I.read_internal file_path_list in
+ match ref_trees with
+ | [] ->
+ I.write_internal primary_tree (FilePath.concat cache_dir result_name)
+ | _ ->
+ let f _ v = v in
+ let res = List.fold_left (fun p r -> Tree_alg.RefAlg.tree_union r p f) primary_tree ref_trees in
+ I.write_internal res (FilePath.concat cache_dir result_name)
+
+let reference_tree_to_json ?(internal_cache="") from_dir to_file =
+ let ref_tree_result =
+ load_interface_definitions from_dir
+ in
+ let ref_tree =
+ match ref_tree_result with
+ | Ok ref -> ref
+ | Error msg -> raise (Load_error msg)
+ in
+ let out = Reference_tree.render_json ref_tree in
+ let oc =
+ try
+ open_out to_file
+ with Sys_error msg -> raise (Write_error msg)
+ in
+ Printf.fprintf oc "%s" out;
+ 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..4243ef0 100644
--- a/src/generate.mli
+++ b/src/generate.mli
@@ -2,4 +2,7 @@ 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
+val interface_definitions_to_cache : string -> string -> unit
+val reference_tree_cache_to_json : string -> string -> unit
+val merge_reference_tree_cache : string -> string -> string -> unit
diff --git a/src/internal.ml b/src/internal.ml
new file mode 100644
index 0000000..a57f3db
--- /dev/null
+++ b/src/internal.ml
@@ -0,0 +1,66 @@
+exception Read_error of string
+exception Write_error of string
+
+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
+ val replace_internal : string -> string -> unit
+ 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 fd = Unix.openfile file_name [Unix.O_CREAT;Unix.O_WRONLY] 0o664 in
+ let () =
+ try
+ Unix.lockf fd Unix.F_TLOCK 0
+ with _ ->
+ Unix.close fd; raise (Write_error "write lock unavailable")
+ in
+ let oc = Unix.out_channel_of_descr fd in
+ let () = Unix.ftruncate fd 0 in
+ let () = Printf.fprintf oc "%s" ys in
+ let () = Unix.fsync fd in
+ let () = Unix.lockf fd Unix.F_ULOCK 0 in
+ close_out_noerr oc
+
+ let read_internal file_name =
+ let fd =
+ try
+ Unix.openfile file_name [Unix.O_RDONLY] 0o664
+ with Unix.Unix_error (e,f,p) ->
+ let out =
+ Printf.sprintf "%s %s: %s" (Unix.error_message e) f p
+ in raise (Read_error out)
+ in
+ let () =
+ try
+ Unix.lockf fd Unix.F_TEST 0
+ with _ ->
+ Unix.close fd; raise (Read_error "read lock unavailable")
+ in
+ let ic = Unix.in_channel_of_descr fd 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_noerr ic; ct
+
+ let replace_internal dst src =
+ let tmp = src ^ ".tmp" in
+ try
+ let () = FileUtil.cp ~force:Force [src] tmp in
+ let () = FileUtil.rm ~force:Force [dst] in
+ FileUtil.mv ~force:Force tmp dst
+ with _ -> raise (Write_error "replace error")
+end
diff --git a/src/internal.mli b/src/internal.mli
new file mode 100644
index 0000000..a82232d
--- /dev/null
+++ b/src/internal.mli
@@ -0,0 +1,19 @@
+exception Read_error of string
+exception Write_error of string
+
+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
+ val replace_internal : string -> string -> unit
+ end
+
+module Make : FI
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 4889734..d39cc96 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -8,21 +8,34 @@ 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 doc_hints = {
+ text: string;
+ hint_type: string;
+} [@@deriving yojson]
+
+type docs = {
+ headline: string;
+ text: string;
+ usageExample: string;
+ hints: doc_hints list;
+} [@@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 +47,10 @@ type ref_node_data = {
default_value: string option;
hidden: bool;
secret: bool;
-} [@@deriving to_yojson]
+ docs: docs;
+} [@@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
@@ -57,6 +71,12 @@ let default_data = {
default_value = None;
hidden = false;
secret = false;
+ docs = {
+ headline = "";
+ text = "";
+ usageExample = "";
+ hints = [];
+ };
}
let default = Vytree.make default_data ""
@@ -79,7 +99,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 +138,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,32 +148,60 @@ 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 load_docs_hints d c =
+ let aux d c =
+ match c with
+ | Xml.Element ("hints", attrs, [Xml.PCData s]) ->
+ let hint_type = List.assoc "type" attrs in
+ let hint = { text = s; hint_type = hint_type } in
+ let new_docs = { d.docs with hints = hint :: d.docs.hints } in
+ { d with docs = new_docs }
+ | _ -> raise (Bad_interface_definition ("Malformed hint: " ^ Xml.to_string c))
+ in aux d c
+
+let load_docs_from_xml d x =
+ let aux d x =
+ match x with
+ | Xml.Element ("headline", _, [Xml.PCData s]) ->
+ let new_docs = {d.docs with headline = s} in
+ {d with docs = new_docs}
+ | Xml.Element ("text", _, [Xml.PCData s]) ->
+ let new_docs = {d.docs with text = s} in
+ {d with docs = new_docs}
+ | Xml.Element ("hints", _, _) ->
+ load_docs_hints d x
+ | Xml.Element ("usageExample", _, [Xml.PCData s]) ->
+ let new_docs = {d.docs with usageExample = s} in
+ {d with docs = new_docs}
+ | _ -> d (* Ignore unknown elements instead of raising an error *)
+ in Xml.fold aux d x
+
let data_from_xml d x =
let aux d x =
match x with
@@ -171,7 +219,8 @@ 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")
+ | Xml.Element ("docs", _, _) -> load_docs_from_xml d x
+ | _ -> 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 +278,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))
+ | [p] -> (List.rev (p :: 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
@@ -261,6 +480,10 @@ let get_owner reftree path =
let data = Vytree.get_data reftree path in
data.owner
+let get_priority reftree path =
+ let data = Vytree.get_data reftree path in
+ data.priority
+
let get_help_string reftree path =
let data = Vytree.get_data reftree path in
data.help
@@ -275,6 +498,61 @@ 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
+
+let flag path =
+ let len = List.length path in
+ let aux p i =
+ Util.drop_last_n p (len - i - 1)
+ in
+ List.mapi (fun k _ -> aux path k) path
+
+let set_tag_data rtree ctree path =
+ let ext = Vytree.exists ctree path in
+ match ext with
+ | false -> ctree
+ | true ->
+ let set_tag rt ct p =
+ let refp = refpath rt p in
+ if is_tag rt refp && not (Config_tree.is_tag_value ct p)
+ then Config_tree.set_tag ct p true
+ else ct
+ in
+ List.fold_left (set_tag rtree) ctree (flag path)
+
+let set_leaf_data rtree ctree path =
+ let ext = Vytree.exists ctree path in
+ match ext with
+ | false -> ctree
+ | true ->
+ let refp = refpath rtree path in
+ if is_leaf rtree refp then Config_tree.set_leaf ctree path true
+ else ctree
+
+let get_ceil_data f reftree path =
+ let data_of_path d p =
+ let data = Vytree.get_data reftree p in
+ match (f data) with
+ | Some d' -> Some d'
+ | None -> d
+ in
+ let rec aux d acc p =
+ match acc, p with
+ | _, h :: tl ->
+ let acc' = acc @ [h] in
+ aux (data_of_path d (refpath reftree acc')) acc' tl
+ | _, [] -> d
+ in aux None [] path
+
module JSONRenderer =
struct
let render_data data =
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index a18d875..9c583df 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -3,21 +3,28 @@ 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 doc_hints = {
+ text: string;
+ hint_type: string;
+} [@@deriving yojson]
+
+type docs = {
+ headline: string;
+ text: string;
+ usageExample: string;
+ hints: doc_hints list;
+} [@@deriving to_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;
@@ -29,9 +36,10 @@ type ref_node_data = {
default_value: string option;
hidden: bool;
secret: bool;
-} [@@deriving to_yojson]
+ docs: docs;
+} [@@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
@@ -43,6 +51,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
@@ -57,10 +71,20 @@ val is_valueless : t -> string list -> bool
val get_owner : t -> string list -> string option
+val get_priority : t -> string list -> string option
+
val get_help_string : t -> string list -> string
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 get_ceil_data : (ref_node_data -> string option) -> t -> string list -> string option
+
+val set_tag_data : t -> Config_tree.t -> string list -> Config_tree.t
+
+val set_leaf_data : t -> Config_tree.t -> string list -> Config_tree.t
+
val render_json : t -> string
diff --git a/src/tree_alg.ml b/src/tree_alg.ml
new file mode 100644
index 0000000..23af99d
--- /dev/null
+++ b/src/tree_alg.ml
@@ -0,0 +1,68 @@
+exception Incompatible_union
+exception Nonexistent_child
+
+module type Data = sig
+ type t
+end
+
+module type Tree = sig
+ module D: Data
+ type t = D.t Vytree.t
+end
+
+module Tree_impl (D: Data): Tree with module D = D = struct
+ module D = D
+ type t = D.t Vytree.t
+end
+
+module Alg (D: Data) (T: Tree with module D = D) = struct
+ module TreeOrd = struct
+ type t = T.t
+ let compare a b =
+ Util.lexical_numeric_compare (Vytree.name_of_node a) (Vytree.name_of_node b)
+ end
+ module SetT = Set.Make(TreeOrd)
+
+ let union_of_children n m =
+ let set_n = SetT.of_list (Vytree.children_of_node n) in
+ let set_m = SetT.of_list (Vytree.children_of_node m) in
+ SetT.elements (SetT.union set_n set_m)
+
+ let find_child n c = Vytree.find n (Vytree.name_of_node c)
+
+ let insert_child n c = Vytree.insert ~position:Vytree.Lexical ~children:(Vytree.children_of_node c) n [(Vytree.name_of_node c)] (Vytree.data_of_node c)
+
+ let replace_child n c =
+ Vytree.replace n c
+
+ let rec tree_union s t f =
+ if (Vytree.name_of_node s) <> (Vytree.name_of_node t) then
+ raise Incompatible_union
+ else
+ let child_of_union s t c =
+ let s_c = find_child s c in
+ let t_c = find_child t c in
+ match s_c, t_c with
+ | Some child, None ->
+ insert_child t child
+ | None, Some _ -> t
+ | Some u, Some v ->
+ if (Vytree.data_of_node u <> Vytree.data_of_node v) then
+ replace_child t (tree_union u (f u v) f)
+ else
+ replace_child t (tree_union u v f)
+ | None, None -> raise Nonexistent_child
+ in
+ List.fold_left (fun x c -> child_of_union s x c) t (union_of_children s t)
+end
+
+module ConfigData: Data with type t = Config_tree.config_node_data = struct
+ type t = Config_tree.config_node_data
+end
+
+module RefData: Data with type t = Reference_tree.ref_node_data = struct
+ type t = Reference_tree.ref_node_data
+end
+
+module ConfigAlg = Alg(ConfigData)(Tree_impl(ConfigData))
+module RefAlg = Alg(RefData)(Tree_impl(RefData))
diff --git a/src/util.ml b/src/util.ml
index 168589d..8fc5899 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -85,3 +85,77 @@ 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']
+ | _ -> []
+
+
+let drop_last l =
+ let rec aux acc l =
+ match l with
+ | [] | [_] -> List.rev acc
+ | hd :: tl ->
+ let acc' = hd :: acc in
+ aux acc' tl
+ in
+ aux [] l
+
+let drop_last_n l n =
+ let rec aux k l =
+ match l with
+ | [] -> []
+ | _ -> if k <= 0 then l else aux (k - 1) (drop_last l)
+ in aux n l
+
+let drop_first l =
+ match l with
+ | [] -> []
+ | _ :: tl -> tl
+
+let rec get_last l =
+ match l with
+ | [] -> None
+ | h :: [] -> Some h
+ | _ :: tl -> get_last tl
+
+let get_last_n l n =
+ get_last (drop_last_n l n)
+
+let lex_order l k =
+ let c = compare (get_last l) (get_last k) in
+ match c with
+ | 0 -> compare (drop_last l) (drop_last k)
+ | _ as r -> r
+
+let colex_order l k =
+ let rec comp x y =
+ let c = compare (get_last x) (get_last y) in
+ match c with
+ | 0 -> comp (drop_last x) (drop_last y)
+ | _ as r -> r
+ in comp l k
+
+let is_empty l =
+ List.compare_length_with l 0 = 0
diff --git a/src/util.mli b/src/util.mli
index f9bfba6..fc25cff 100644
--- a/src/util.mli
+++ b/src/util.mli
@@ -9,3 +9,25 @@ 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
+
+val drop_last : 'a list -> 'a list
+
+val drop_last_n : 'a list -> int -> 'a list
+
+val drop_first : 'a list -> 'a list
+
+val get_last : 'a list -> 'a option
+
+val get_last_n : 'a list -> int -> 'a option
+
+val lex_order : string list -> string list -> int
+
+val colex_order : string list -> string list -> int
+
+val is_empty : 'a list -> bool
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_lexer.mll b/src/vyos1x_lexer.mll
index a363c65..34cf294 100644
--- a/src/vyos1x_lexer.mll
+++ b/src/vyos1x_lexer.mll
@@ -69,8 +69,6 @@ rule token vy_inside_node = parse
{ (false, LEFT_BRACE) }
| '}'
{ (false, RIGHT_BRACE) }
-| "//" [^ '\n']*
- { token vy_inside_node lexbuf }
| [^ ' ' '\t' '\n' '\r' '{' '}' '"' ''' ]+ as s
{ (true, IDENTIFIER s) }
| eof
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/src/vytree.ml b/src/vytree.ml
index 05b3088..dec1666 100644
--- a/src/vytree.ml
+++ b/src/vytree.ml
@@ -207,3 +207,24 @@ let move node path position =
let child = get node path in
let node = delete node path in
insert ~position:position ~children:child.children node path child.data
+
+let is_terminal_path node path =
+ try
+ let n = get node path in
+ match (children_of_node n) with
+ | [] -> true
+ | _ -> false
+ with Nonexistent_path -> false
+
+let rec fold_tree_with_path f (p', a) t =
+ let p =
+ match name_of_node t with
+ | "" -> p'
+ | name -> name :: p'
+ in
+ let children = children_of_node t in
+ match children with
+ | [] -> (Util.drop_first p), snd (f (p, a) t)
+ | c -> let res =
+ List.fold_left (fold_tree_with_path f) (f (p, a) t) c in
+ (Util.drop_first p), snd res
diff --git a/src/vytree.mli b/src/vytree.mli
index 412379a..9839728 100644
--- a/src/vytree.mli
+++ b/src/vytree.mli
@@ -56,3 +56,7 @@ val sort_children : (string -> string -> int) -> 'a t -> 'a t
val copy : 'a t -> string list -> string list -> 'a t
val move : 'a t -> string list -> position -> 'a t
+
+val is_terminal_path : 'a t -> string list -> bool
+
+val fold_tree_with_path: (string list * 'acc -> 'b t -> string list * 'acc) -> string list * 'acc -> 'b t -> string list * 'acc
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-03 23:55:08 +0000