Merge pull request #30 from jestabro/dynamic-session-config

T7728: T7734: dynamically generate proposed config from changeset data

1 files changed, 88 insertions, 52 deletions

diff --git a/src/session.ml b/src/session.ml
index 31bd411..5efc9f5 100644
--- a/src/session.ml
+++ b/src/session.ml
@@ -53,22 +53,43 @@ let string_of_op op =
          | None -> Printf.sprintf "delete %s" path_str
          | Some v -> Printf.sprintf "delete %s \"%s\"" path_str v)
 
-
 let set_modified s =
     if s.modified = true then s
     else {s with modified = true}
 
-let apply_cfg_op op config =
+let apply_cfg_op w op config =
+    let result =
     match op with
     | CfgSet (path, value, value_behaviour) ->
-        CT.set config path value value_behaviour
+        begin
+        let rt = w.reference_tree in
+        let refp = RT.refpath rt path in
+        try
+            let c =
+            match (RT.is_leaf rt refp) with
+            | true ->
+                CT.set config path value value_behaviour
+            | false ->
+                CT.create_node config path
+            in
+            RT.set_tag_data rt c path
+        with
+        | CT.Useless_set | CT.Duplicate_value -> config
+        end
     | CfgDelete (path, value) -> 
-        CT.delete config path value
+        begin
+        try
+            CT.delete config path value |>
+            (fun c -> CT.prune_delete c path)
+        with
+        | VT.Nonexistent_path | CT.No_such_value -> config
+        end
+    in result
 
-let rec apply_changes changeset config =
+let rec apply_changes w changeset config =
     match changeset with
     | [] -> config
-    | c :: cs -> apply_changes cs (apply_cfg_op c config)
+    | c :: cs -> apply_changes w cs (apply_cfg_op w c config)
 
 let validate w _s path =
     try
@@ -81,46 +102,55 @@ let validate_tree w t =
     | "" -> ()
     | _ -> raise (Session_error out)
 
-let split_path w _s path =
+let split_path w path =
     RT.split_path w.reference_tree path
 
-let set w s path =
-    let _ = validate w s path in
-    let path, value = split_path w s path in
+let get_proposed_config w s =
+    let c = w.running_config in
+    apply_changes w (List.rev s.changeset) c
+
+let update_set w changeset path =
+    let path, value = split_path w path in
     let refpath = RT.refpath w.reference_tree path in
     let value_behaviour = if RT.is_multi w.reference_tree refpath then CT.AddValue else CT.ReplaceValue in
     let op = CfgSet (path, value, value_behaviour) in
-    let config =
-        try
-            apply_cfg_op op s.proposed_config |>
-            (fun c -> RT.set_tag_data w.reference_tree c path) |>
-            (fun c -> RT.set_leaf_data w.reference_tree c path)
-        with
-        | CT.Useless_set | CT.Duplicate_value -> s.proposed_config
+    (op :: changeset)
+
+let update_delete w changeset path =
+    let path, value = split_path w path in
+    let op = CfgDelete (path, value) in
+    (op :: changeset)
 
+let get_changeset w lt rt =
+    let diff = CD.diff_tree [] lt rt in
+    let add_tree = CT.get_subtree diff ["add"] in
+    let del_tree = CT.get_subtree diff ["del"] in
+    let add_changeset =
+        List.fold_left (update_set w) [] (CT.value_paths_of_tree add_tree)
     in
-    {s with proposed_config=config; changeset=(op :: s.changeset)}
+    let del_changeset =
+        List.fold_left (update_delete w) [] (CT.value_paths_of_tree del_tree)
+    in
+    add_changeset @ del_changeset
+
+let set w s path =
+    let _ = validate w s path in
+    let changeset' = update_set w s.changeset path in
+    { s with changeset = changeset' }
 
 let delete w s path =
-    let path, value = split_path w s path in
-    let op = CfgDelete (path, value) in
-    let config =
-        try
-            apply_cfg_op op s.proposed_config |>
-            (fun c -> CT.prune_delete c path)
-        with
-        | VT.Nonexistent_path | CT.No_such_value -> s.proposed_config
-    in
-    {s with proposed_config=config; changeset=(op :: s.changeset)}
+    let changeset' = update_delete w s.changeset path in
+    { s with changeset = changeset' }
 
-let discard w s =
-    {s with proposed_config=w.running_config}
+let discard _w s =
+    { s with changeset = []; }
 
 let session_changed w s =
     (* structural equality test requires consistent ordering, which is
      * practised, but may be unreliable; test actual difference
      *)
-    let diff = CD.diff_tree [] w.running_config s.proposed_config in
+    let c = get_proposed_config w s in
+    let diff = CD.diff_tree [] w.running_config c in
     let add_tree = CT.get_subtree diff ["add"] in
     let del_tree = CT.get_subtree diff ["del"] in
     (del_tree <> CT.default) || (add_tree <> CT.default)
@@ -138,7 +168,8 @@ let load w s file cached =
     match ct with
     | Error e -> raise (Session_error (Printf.sprintf "Error loading config: %s" e))
     | Ok config ->
-        validate_tree w config; {s with proposed_config=config;}
+        validate_tree w config;
+        { s with changeset = get_changeset w w.running_config config; }
 
 let merge w s file destructive =
     let ct = Vyos1x.Config_file.load_config file in
@@ -146,9 +177,10 @@ let merge w s file destructive =
     | Error e -> raise (Session_error (Printf.sprintf "Error loading config: %s" e))
     | Ok config ->
         let () = validate_tree w config in
-        let merged = CD.tree_merge ~destructive:destructive s.proposed_config config
+        let proposed = get_proposed_config w s in
+        let merged = CD.tree_merge ~destructive:destructive proposed config
         in
-        {s with proposed_config=merged;}
+        { s with changeset = get_changeset w w.running_config merged; }
 
 let save w s file =
     let ct = w.running_config in
@@ -157,9 +189,8 @@ let save w s file =
     | Error e -> raise (Session_error (Printf.sprintf "Error saving config: %s" e))
     | Ok () -> s
 
-let prepare_commit ?(dry_run=false) w s id =
+let prepare_commit ?(dry_run=false) w config id =
     let at = w.running_config in
-    let wt = s.proposed_config in
     let rt = w.reference_tree in
     let vc = w.vyconf_config in
     let () =
@@ -170,15 +201,15 @@ let prepare_commit ?(dry_run=false) w s id =
     in
     let () =
         try
-            IC.write_internal wt (FP.concat vc.session_dir vc.session_cache)
+            IC.write_internal config (FP.concat vc.session_dir vc.session_cache)
         with
             Vyos1x.Internal.Write_error msg -> raise (Session_error msg)
     in
-    CC.make_commit_data ~dry_run:dry_run rt at wt id
+    CC.make_commit_data ~dry_run:dry_run rt at config id
 
 let get_config w s id =
     let at = w.running_config in
-    let wt = s.proposed_config in
+    let wt = get_proposed_config w s in
     let vc = w.vyconf_config in
     let running_cache = Printf.sprintf "%s_%s" vc.running_cache id in
     let session_cache = Printf.sprintf "%s_%s" vc.session_cache id in
@@ -207,7 +238,8 @@ let cleanup_config w id =
     remove_file (FP.concat vc.session_dir session_cache)
 
 let get_value w s path =
-    if not (VT.exists s.proposed_config path) then
+    let c = get_proposed_config w s in
+    if not (VT.exists c path) then
         raise (Session_error ("Config path does not exist"))
     else let refpath = RT.refpath w.reference_tree path in
     if not (RT.is_leaf w.reference_tree refpath) then
@@ -216,39 +248,43 @@ let get_value w s path =
         raise (Session_error "This node can have more than one value")
     else if (RT.is_valueless w.reference_tree refpath) then
         raise (Session_error "This node can have more than one value")
-    else CT.get_value s.proposed_config path
+    else CT.get_value c path
 
 let get_values w s path =
-    if not (VT.exists s.proposed_config path) then
+    let c = get_proposed_config w s in
+    if not (VT.exists c path) then
         raise (Session_error ("Config path does not exist"))
     else let refpath = RT.refpath w.reference_tree path in
     if not (RT.is_leaf w.reference_tree refpath) then
         raise (Session_error "Cannot get a value of a non-leaf node")
     else if not (RT.is_multi w.reference_tree refpath) then
         raise (Session_error "This node can have only one value")
-    else CT.get_values s.proposed_config path
+    else CT.get_values c path
 
 let list_children w s path =
-    if not (VT.exists s.proposed_config path) then
+    let c = get_proposed_config w s in
+    if not (VT.exists c path) then
         raise (Session_error ("Config path does not exist"))
     else let refpath = RT.refpath w.reference_tree path in
     if (RT.is_leaf w.reference_tree refpath) then
         raise (Session_error "Cannot list children of a leaf node")
-    else VT.children_of_path s.proposed_config path
+    else VT.children_of_path c path
 
-let exists _w s path =
-    VT.exists s.proposed_config path
+let exists w s path =
+    let c = get_proposed_config w s in
+    VT.exists c path
 
-let show_config _w s path fmt =
+let show_config w s path fmt =
     let open Vyconf_connect.Vyconf_pbt in
-    if (path <> []) && not (VT.exists s.proposed_config path) then
+    let c = get_proposed_config w s in
+    if (path <> []) && not (VT.exists c path) then
         raise (Session_error ("Path does not exist")) 
     else
-        let node = s.proposed_config in
+        let node = c in
         match fmt with
         | Curly -> CT.render_at_level node path
         | Json ->
             let node =
-                (match path with [] -> s.proposed_config |
-                                 _ as ps -> VT.get s.proposed_config ps) in
+                (match path with [] -> c |
+                                 _ as ps -> VT.get c ps) in
             CT.to_yojson node |> Yojson.Safe.pretty_to_string