diff options
| -rw-r--r-- | src/commit.ml | 148 | ||||
| -rw-r--r-- | src/commit.mli | 2 | ||||
| -rw-r--r-- | src/dune | 14 | ||||
| -rw-r--r-- | src/startup.ml | 7 | ||||
| -rw-r--r-- | src/startup.mli | 6 | ||||
| -rw-r--r-- | src/test_commit_data.ml | 30 | ||||
| -rw-r--r-- | src/vyconfd.ml | 1 | ||||
| -rw-r--r-- | vyconf.opam | 3 |
8 files changed, 201 insertions, 10 deletions
diff --git a/src/commit.ml b/src/commit.ml new file mode 100644 index 0000000..3c593fd --- /dev/null +++ b/src/commit.ml @@ -0,0 +1,148 @@ +module VT = Vyos1x.Vytree +module CT = Vyos1x.Config_tree +module CD = Vyos1x.Config_diff +module RT = Vyos1x.Reference_tree +module FP = FilePath + +type commit_data = { + script: string option; + priority: int; + tag_value: string option; + arg_value: string option; + path: string list; +} [@@deriving yojson] + + +let default_commit_data = { + script = None; + priority = 0; + tag_value = None; + arg_value = None; + path = []; +} + +let lex_order c1 c2 = + let c = Vyos1x.Util.lex_order c1.path c2.path in + match c with + | 0 -> + begin + match c1.tag_value, c2.tag_value with + | Some t1, Some t2 -> Vyos1x.Util.lexical_numeric_compare t1 t2 + | _ -> 0 + end + | _ as a -> a + +module CI = struct + type t = commit_data + let compare a b = + match compare a.priority b.priority with + | 0 -> lex_order a b + | _ as c -> c +end +module CS = Set.Make(CI) + +let owner_args_from_data p s = + match s with + | None -> None, None + | Some o -> + let oa = Pcre.split o in + let owner = FilePath.basename (List.nth oa 0) in + if List.length oa < 2 then Some owner, None + else + let var = List.nth oa 1 in + let res = Pcre.extract_all ~pat:"\\.\\./" var in + let var_pos = Array.length res in + let arg_value = Vyos1x.Util.get_last_n p var_pos + in Some owner, arg_value + +let add_tag_instance cd cs tv = + CS.add { cd with tag_value = Some tv; } cs + +let get_commit_data rt ct (path, cs') t = + if Vyos1x.Util.is_empty path then + (path, cs') + else + if (VT.name_of_node t) = "" then + (path, cs') + else + let rpath = List.rev path in + (* the following is critical to avoid redundant calculations for owner + of a tag node, quadratic in the number of tag node values *) + if CT.is_tag_value ct rpath then + (path, cs') + else + let rt_path = RT.refpath rt rpath in + let priority = + match RT.get_priority rt rt_path with + | None -> 0 + | Some s -> int_of_string s + in + let owner = RT.get_owner rt rt_path in + if owner = None then (path, cs') + else + let (own, arg) = owner_args_from_data rpath owner in + let c_data = { default_commit_data with + script = own; + priority = priority; + arg_value = arg; + path = rpath; } + in + let tag_values = + match RT.is_tag rt rt_path with + | false -> [] + | true -> VT.list_children t + in + let cs = + match tag_values with + | [] -> CS.add c_data cs' + | _ -> List.fold_left (add_tag_instance c_data) cs' tag_values + in (path, cs) + +let get_commit_set rt ct = + snd (VT.fold_tree_with_path (get_commit_data rt ct) ([], CS.empty) ct) + +(* for initial consistency with the legacy ordering of delete and add + queues, enforce the following subtlety: if a path in the delete tree is + an owner node, or the tag value thereof, insert in the delete queue; if + the path is in a subtree, however, insert in the add queue - cf. T5492 +*) +let legacy_order del_t a b = + let shift c_data (c_del, c_add) = + let path = + match c_data.tag_value with + | None -> c_data.path + | Some v -> c_data.path @ [v] + in + match VT.is_terminal_path del_t path with + | false -> CS.remove c_data c_del, CS.add c_data c_add + | true -> c_del, c_add + in + CS.fold shift a (a, b) + +let calculate_priority_lists rt at wt = + let diff = CD.diff_tree [] at wt in + let del_tree = CD.get_tagged_delete_tree diff in + let add_tree = CT.get_subtree diff ["add"] in + let cs_del' = get_commit_set rt del_tree in + let cs_add' = get_commit_set rt add_tree in + let cs_del, cs_add = legacy_order del_tree cs_del' cs_add' in + List.rev (CS.elements cs_del), CS.elements cs_add + +let show_commit_data at wt = + let vc = + Startup.load_daemon_config Defaults.defaults.config_file in + let rt_opt = + Startup.read_reference_tree (FP.concat vc.reftree_dir vc.reference_tree) + in + match rt_opt with + | Error msg -> msg + | Ok rt -> + let del_list, add_list = + calculate_priority_lists rt at wt + in + let sprint_commit_data acc s = + acc ^ "\n" ^ (commit_data_to_yojson s |> Yojson.Safe.to_string) + in + let del_out = List.fold_left sprint_commit_data "" del_list in + let add_out = List.fold_left sprint_commit_data "" add_list in + del_out ^ "\n" ^ add_out diff --git a/src/commit.mli b/src/commit.mli new file mode 100644 index 0000000..db91195 --- /dev/null +++ b/src/commit.mli @@ -0,0 +1,2 @@ + +val show_commit_data : Vyos1x.Config_tree.t -> Vyos1x.Config_tree.t -> string @@ -9,9 +9,10 @@ (library (name vyconfd_config) - (modules vyconf_config session directories defaults) + (public_name vyconf.vyconfd-config) + (modules vyconf_config startup session directories defaults commit) (libraries vyos1x-config vyconf_connect toml sha ppx_deriving.show) - (preprocess (pps ppx_deriving.show ppx_deriving_yojson))) + (preprocess (pps lwt_ppx ppx_deriving.show ppx_deriving_yojson))) (library (name client) @@ -24,7 +25,7 @@ (executable (name vyconfd) (public_name vyconfd) - (modules vyconfd startup version) + (modules vyconfd version) (libraries vyos1x-config vyconfd_config vyconf_connect) (preprocess (pps lwt_ppx))) @@ -41,6 +42,13 @@ (modules validate) (libraries client)) +(executable + (name test_commit_data) + (public_name test-commit-data) + (modules test_commit_data) + (libraries vyos1x-config vyconfd_config) + (preprocess (pps lwt_ppx))) + (rule (alias protoc) (mode promote) diff --git a/src/startup.ml b/src/startup.ml index db0d719..db2784d 100644 --- a/src/startup.ml +++ b/src/startup.ml @@ -33,7 +33,7 @@ let setup_logger daemonize log_file template = (** Load the config file or panic if it fails *) let load_daemon_config path = - let result = Vyconfd_config.Vyconf_config.load path in + let result = Vyconf_config.load path in match result with | Ok cfg -> cfg | Error err -> @@ -41,13 +41,13 @@ let load_daemon_config path = (** Check if appliance directories exist and panic if they don't *) let check_dirs dirs = - let res = Vyconfd_config.Directories.test dirs in + let res = Directories.test dirs in match res with | Ok _ -> () | Error err -> panic err let check_validators_dir dirs = - let res = Vyconfd_config.Directories.test_validators_dir dirs in + let res = Directories.test_validators_dir dirs in match res with | Ok _ -> () | Error err -> panic err @@ -136,5 +136,6 @@ module I = Vyos1x.Internal.Make(Vyos1x.Reference_tree) let read_reference_tree file = try let reftree = I.read_internal file in + log_info @@ Printf.sprintf "Reading interface definitions from %s" file; Ok reftree with Sys_error msg -> Error msg diff --git a/src/startup.mli b/src/startup.mli index 84fb99e..dc84736 100644 --- a/src/startup.mli +++ b/src/startup.mli @@ -2,11 +2,11 @@ val panic : string -> 'a val setup_logger : bool -> string option -> Lwt_log.template -> unit Lwt.t -val load_daemon_config : string -> Vyconfd_config.Vyconf_config.t +val load_daemon_config : string -> Vyconf_config.t -val check_dirs : Vyconfd_config.Directories.t -> unit +val check_dirs : Directories.t -> unit -val check_validators_dir : Vyconfd_config.Directories.t -> unit +val check_validators_dir : Directories.t -> unit val create_socket : string -> Lwt_unix.file_descr Lwt.t diff --git a/src/test_commit_data.ml b/src/test_commit_data.ml new file mode 100644 index 0000000..81b6c19 --- /dev/null +++ b/src/test_commit_data.ml @@ -0,0 +1,30 @@ +module CT = Vyos1x.Config_tree +module FP = FilePath + +let active_config_file = ref "" +let working_config_file = ref "" + +let usage = "Usage: " ^ Sys.argv.(0) ^ " [options]" + +let args = [ + ("--running-config", Arg.String (fun s -> active_config_file:= s), "running config file"); + ("--proposed-config", Arg.String (fun s -> working_config_file := s), "proposed config file"); + ] + +let parse_ct file_name = + match file_name with + | "" -> CT.make "" + | _ -> + let ic = open_in file_name in + let s = really_input_string ic (in_channel_length ic) in + let ct = Vyos1x.Parser.from_string s in + close_in ic; ct + +let () = + let () = Arg.parse args (fun _ -> ()) usage in + let af = !active_config_file in + let wf = !working_config_file in + let at = parse_ct af in + let wt = parse_ct wf in + let out = Vyconfd_config.Commit.show_commit_data at wt + in print_endline out diff --git a/src/vyconfd.ml b/src/vyconfd.ml index 004ed6f..95915b3 100644 --- a/src/vyconfd.ml +++ b/src/vyconfd.ml @@ -9,6 +9,7 @@ module CT = Vyos1x.Config_tree module Gen = Vyos1x.Generate module Session = Vyconfd_config.Session module Directories = Vyconfd_config.Directories +module Startup = Vyconfd_config.Startup (* On UNIX, self_init uses /dev/random for seed *) let () = Random.self_init () diff --git a/vyconf.opam b/vyconf.opam index b947e39..2ae8127 100644 --- a/vyconf.opam +++ b/vyconf.opam @@ -17,7 +17,7 @@ depends: [ "menhir" {build} "dune" {build & >= "1.4.0"} "ocaml-protoc" {build} - "ounit" {build} + "ounit2" {build} "lwt" {build & >= "4.1.0"} "lwt_ppx" {build} "lwt_log" {build} @@ -29,4 +29,5 @@ depends: [ "toml" {build} "sha" {build} "pcre" {build} + "toml" {build} ] |