type value_behaviour = AddValue | ReplaceValue exception Duplicate_value exception Node_has_no_value exception No_such_value exception Useless_set type config_node_data = { values: string list; comment: string option; tag: bool; } [@@deriving yojson] type t = config_node_data Vytree.t [@@deriving yojson] let default_data = { values = []; comment = None; tag = false; } let make name = Vytree.make default_data name let replace_value node path value = let data = {default_data with values=[value]} in Vytree.update node path data let add_value node path value = let node' = Vytree.get node path in let data = Vytree.data_of_node node' in let values = data.values in match (Vylist.find (fun x -> x = value) values) with | Some _ -> raise Duplicate_value | None -> let values = values @ [value] in Vytree.update node path ({data with values=values}) 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} let set_value node path value behaviour = match behaviour with | AddValue -> add_value node path value | ReplaceValue -> replace_value node path value let set node path value behaviour = if (Vytree.exists node path) then (match value with | None -> raise Useless_set | Some v -> set_value node path v behaviour) else 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 get_values node path = let node' = Vytree.get node path in let data = Vytree.data_of_node node' in data.values let get_value node path = let values = get_values node path in match values with | [] -> raise Node_has_no_value | x :: _ -> x let delete node path value = match value with | Some v -> (let values = get_values node path in if Vylist.in_list values v then (match values with | [_] -> Vytree.delete node path | _ -> delete_value node path v) else raise No_such_value) | None -> Vytree.delete node path let set_comment node path comment = let data = Vytree.get_data node path in Vytree.update node path {data with comment=comment} let get_comment node path = let data = Vytree.get_data node path in data.comment let set_tag node path tag = let data = Vytree.get_data node path in Vytree.update node path {data with tag=tag} let is_tag node path = let data = Vytree.get_data node path in data.tag module Renderer = struct (* Rendering configs as set commands *) let render_set_path path value = let v = Printf.sprintf "\'%s\'" value in List.append path [v] |> String.concat " " |> Printf.sprintf "set %s" let rec render_commands path ct = let new_path = List.append path [Vytree.name_of_node ct] in let new_path_str = String.concat " " new_path in let data = Vytree.data_of_node ct in (* Get the node comment, if any *) let comment = Util.default "" data.comment in let comment_cmd = (if comment = "" then "" else Printf.sprintf "comment %s \'%s\'" new_path_str comment) in let child_names = Vytree.list_children ct in (* Now handle the different cases for nodes with and without children *) match child_names with | [] -> (* This is a leaf node *) let values = List.map String.escaped data.values in let cmds = begin match values with | [] -> (* Valueless leaf node *) String.concat " " new_path |> Printf.sprintf "set %s" | [v] -> (* Single value, just one command *) render_set_path new_path v | vs -> (* A leaf node with multiple values *) List.map (render_set_path new_path) vs |> String.concat "\n" end 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 new_path) children in let cmds = String.concat "\n" rendered_children in if comment_cmd = "" then cmds else Printf.sprintf "%s\n%s" cmds comment_cmd (* Rendering config as a VyOS/EdgeOS config file *) let make_indent indent level = String.make (level * indent) ' ' let render_values indent_str name values = match values with | [] -> Printf.sprintf "%s%s { }\n" indent_str name | [v] -> Printf.sprintf "%s%s \"%s\"\n" indent_str name (String.escaped v) | _ -> let rendered = List.map (fun s -> Printf.sprintf "%s%s \"%s\"" indent_str name (String.escaped s)) values in let rendered = String.concat "\n" rendered in Printf.sprintf "%s\n" rendered let render_comment indent c = match c with | None -> "" | Some c -> Printf.sprintf "%s/* %s */\n" indent c let rec render_node indent level node = let indent_str = make_indent indent level in let name = Vytree.name_of_node node in 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 indent_str name data.values in let children = Vytree.children_of_node node in match children with | [] -> Printf.sprintf "%s%s" comment values | _ :: _ -> if is_tag then begin let inner = List.map (render_tag_node_child indent level name) children in String.concat "" inner end else begin let inner = List.map (render_node indent (level + 1)) children in let inner = String.concat "" inner in Printf.sprintf "%s%s%s {\n%s%s}\n" comment indent_str name inner indent_str end and render_tag_node_child indent level parent node = let indent_str = make_indent indent level in let name = Vytree.name_of_node node in let data = Vytree.data_of_node node in let comment = render_comment indent_str data.comment in let values = render_values indent_str name data.values in let children = Vytree.children_of_node node in match children with (* This produces too much whitespace due to indent_str from values, but the issue is cosmetic *) | [] -> Printf.sprintf "%s%s%s %s" comment indent_str parent values | _ -> (* Exploiting the fact that immediate children of tag nodes are never themselves tag nodes *) let inner = List.map (render_node indent (level + 1)) children in let inner = String.concat "" inner in Printf.sprintf "%s%s%s %s {\n%s%s}\n" comment indent_str parent name inner indent_str let render_config node = let children = Vytree.children_of_node node in let child_configs = List.map (render_node 4 0) children in String.concat "" child_configs end (* Renderer *) module JSONRenderer = struct let render_values values = match values with | [] -> Printf.sprintf "{}" | [v] -> Printf.sprintf "\"%s\"" (String.escaped v) | _ -> let rendered = List.map (fun s -> Printf.sprintf "\"%s\"" (String.escaped s)) values in let rendered = String.concat "," rendered in Printf.sprintf "[%s]" rendered let rec render_node node = let name = Vytree.name_of_node node in let children = Vytree.children_of_node node in let data = Vytree.data_of_node node in match children, data.values with | [], [] -> (* Empty node. In JSON, we don't differentiate between leaf and non-leaf nodes in this case. *) Printf.sprintf "\"%s\": {}" name | _, [] -> (* Non-empty, non-leaf node. *) let children_strs = List.map render_node children in let children_str = String.concat "," children_strs in Printf.sprintf "\"%s\": {%s}" name children_str | [], _ -> (* Leaf node with children. *) Printf.sprintf "\"%s\": %s" name (render_values data.values) | _, _ -> (* Shouldn't happen *) failwith "Internal error: non-leaf node with values" let render_json node = let children = Vytree.children_of_node node in let child_configs = List.map render_node children in let child_configs = String.concat "," child_configs in Printf.sprintf "{%s}" child_configs end (* JSONRenderer *) let render_commands node path = let node = match path with | [] -> node | _ -> Vytree.get node path in let children = Vytree.children_of_node node in let commands = List.map (Renderer.render_commands path) children in String.concat "\n" commands let render_config = Renderer.render_config let render_json = JSONRenderer.render_json let render_json_ast c = to_yojson c |> Yojson.Safe.to_string