path: root/src/commit.ml

module VT = Vyos1x.Vytree
module CT = Vyos1x.Config_tree
module CD = Vyos1x.Config_diff
module RT = Vyos1x.Reference_tree

exception Commit_error of string

type tree_source = DELETE | ADD

let tree_source_to_yojson = function
    | DELETE -> `String "DELETE"
    | ADD -> `String "ADD"

type status = {
    success : bool;
    out : string;
} [@@deriving to_yojson]

let default_status = {
    success = true;
    out = "";
}

let fail_status msg =
    { success = false;
      out = msg;
    }

type node_data = {
    script_name: string;
    priority: int;
    tag_value: string option;
    arg_value: string option;
    path: string list;
    source: tree_source;
    reply: status option;
} [@@deriving to_yojson]


let default_node_data = {
    script_name = "";
    priority = 0;
    tag_value = None;
    arg_value = None;
    path = [];
    source = ADD;
    reply = None;
}

type commit_data = {
    session_id: string;
    session_pid: int32;
    sudo_user: string;
    user: string;
    dry_run: bool;
    atomic: bool;
    background: bool;
    init: status option;
    node_list: node_data list;
    config_diff: CT.t;
    config_result: CT.t;
    result : status;
} [@@deriving to_yojson]

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 = node_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 o =
    let oa = Pcre2.split o in
    let owner = FilePath.basename (List.nth oa 0) in
    if List.length oa < 2 then owner, None
    else
    let var = List.nth oa 1 in
    let res = Pcre2.extract_all ~pat:"\\.\\./" var in
    let var_pos = Array.length res in
    let arg_value = Vyos1x.Util.get_last_n p var_pos
    in owner, arg_value

let add_tag_instance cd cs tv =
    CS.add { cd with tag_value = Some tv; } cs

let get_node_data rt ct src (path, cs') t =
    (* alert exn CT.is_tag_value;
                 RT.refpath;
                 RT.get_priority;
                 RT.get_owner;
                 RT.is_tag:
        [Vytree.Empty_path] not possible in branch of non-empty path
        [Vytree.Nonexistent_path] not possible in fold_tree_with_path
     *)
    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[@alert "-exn"]) ct rpath then
        (path, cs')
    else
    let rt_path = (RT.refpath[@alert "-exn"]) rt rpath in
    let priority =
        match (RT.get_priority[@alert "-exn"]) rt rt_path with
        | None -> 0
        | Some s -> int_of_string s
    in
    let owner = (RT.get_owner[@alert "-exn"]) rt rt_path in
    match owner with
    | None -> (path, cs')
    | Some owner_str ->
    let (own, arg) = owner_args_from_data rpath owner_str in
    let c_data = { default_node_data with
                   script_name = own;
                   priority = priority;
                   arg_value = arg;
                   path = rpath;
                   source = src; }
    in
    let tag_values =
        match (RT.is_tag[@alert "-exn"]) 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 src =
    VT.fold_tree_with_path (get_node_data rt ct src) ([], 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 =
    (* alert exn Vytree.is_terminal_path:
        [Vytree.Empty_path] not possible as cdata.path non-empty
     *)
    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[@alert "-exn"]) 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 diff =
    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 DELETE in
    let cs_add' = get_commit_set rt add_tree ADD 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

(* The base config_result is the intersection of running and proposed
   configs:
       on success, added paths are added; deleted paths are ignored
       on failure, deleted paths are added back in, added paths ignored
 *)
let config_result_update c_data n_data =
    (* alert exn CD.clone:
        [Vytree.Nonexistent_path] not possible for node_data.path
       alert exn CD.tree_union:
        [Tree_alg.Incompatible_union] not possible for base root
        [Tree_alg.Nonexistent_child] non reachable
     *)
    match n_data.reply with
    | None -> c_data (* already excluded in calling function *)
    | Some r ->
    match r.success, n_data.source with
    | true, ADD ->
        let add =
            CT.get_subtree c_data.config_diff ["add"]
        in
        let path =
            match n_data.tag_value with
            | None -> n_data.path
            | Some v -> n_data.path @ [v]
        in
        let add_tree = (CD.clone[@alert "-exn"]) add (CT.default) path in
        let config =
            (CD.tree_union[@alert "-exn"]) add_tree c_data.config_result
        in
        let result =
            { success = c_data.result.success && true;
              out = c_data.result.out ^ r.out; }
        in
        { c_data with config_result = config; result = result; }
    | false, DELETE ->
        let sub =
            CT.get_subtree c_data.config_diff ["sub"]
        in
        let path =
            match n_data.tag_value with
            | None -> n_data.path
            | Some v -> n_data.path @ [v]
        in
        let add_tree = (CD.clone[@alert "-exn"]) sub (CT.default) path in
        let config =
            (CD.tree_union[@alert "-exn"]) add_tree c_data.config_result
        in
        let result =
            { success = c_data.result.success && false;
              out = c_data.result.out ^ r.out; }
        in
        { c_data with config_result = config; result = result; }
    | true, DELETE ->
        let result =
            { success = c_data.result.success && true;
              out = c_data.result.out ^ r.out; }
        in
        { c_data with result = result; }
    | false, ADD ->
        let result =
            { success = c_data.result.success && false;
              out = c_data.result.out ^ r.out; }
        in
        { c_data with result = result; }


let commit_update c_data =
    match c_data.init with
    | None ->
        { c_data with
          init = Some (fail_status "commitd failure: no init status provided")
        }
    | Some _ ->
        let func acc_data nd =
            match nd.reply with
            | None ->
                { c_data with
                  init = Some (fail_status "commitd failure: no reply status provided")
                }
            | Some _ -> config_result_update acc_data nd
    in List.fold_left func c_data c_data.node_list

let make_commit_data ?(dry_run=false) rt at wt id pid sudo_user user =
    (* alert exn CD.diff_tree:
        [Config_diff.Incommensurable] not possible as base root
        [Config_diff.Empty_comparison] not reachable for path []
     *)
    let diff = (CD.diff_tree[@alert "-exn"]) [] at wt in
    let del_list, add_list = calculate_priority_lists rt diff in
    { session_id = id;
      session_pid = pid;
      sudo_user = sudo_user;
      user = user;
      dry_run = dry_run;
      atomic = false;
      background = false;
      init = None;
      config_diff = diff;
      config_result = CT.get_subtree diff ["inter"];
      node_list = del_list @ add_list;
      result = default_status; }