diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/config_tree.ml | 345 | ||||
| -rw-r--r-- | src/config_tree.mli | 78 | ||||
| -rw-r--r-- | src/curly_lexer.mll | 90 | ||||
| -rw-r--r-- | src/curly_parser.mly | 114 | ||||
| -rw-r--r-- | src/dune | 5 | ||||
| -rw-r--r-- | src/reference_tree.ml | 237 | ||||
| -rw-r--r-- | src/reference_tree.mli | 51 | ||||
| -rw-r--r-- | src/session.ml | 31 | ||||
| -rw-r--r-- | src/session.mli | 12 | ||||
| -rw-r--r-- | src/startup.ml | 16 | ||||
| -rw-r--r-- | src/startup.mli | 6 | ||||
| -rw-r--r-- | src/util.ml | 2 | ||||
| -rw-r--r-- | src/value_checker.ml | 39 | ||||
| -rw-r--r-- | src/value_checker.mli | 7 | ||||
| -rw-r--r-- | src/vycli.ml | 4 | ||||
| -rw-r--r-- | src/vyconf_client.ml | 18 | ||||
| -rw-r--r-- | src/vyconf_config.ml | 4 | ||||
| -rw-r--r-- | src/vyconf_pb.ml | 162 | ||||
| -rw-r--r-- | src/vyconfd.ml | 25 | ||||
| -rw-r--r-- | src/vylist.ml | 46 | ||||
| -rw-r--r-- | src/vylist.mli | 7 | ||||
| -rw-r--r-- | src/vytree.ml | 192 | ||||
| -rw-r--r-- | src/vytree.mli | 50 |
23 files changed, 154 insertions, 1387 deletions
diff --git a/src/config_tree.ml b/src/config_tree.ml deleted file mode 100644 index 28cfcdd..0000000 --- a/src/config_tree.ml +++ /dev/null @@ -1,345 +0,0 @@ -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; - inactive: bool; - ephemeral: bool; -} [@@deriving yojson] - -type t = config_node_data Vytree.t [@@deriving yojson] - -let default_data = { - values = []; - comment = None; - inactive = false; - ephemeral = 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_inactive node path inactive = - let data = Vytree.get_data node path in - Vytree.update node path {data with inactive=inactive} - -let is_inactive node path = - let data = Vytree.get_data node path in - data.inactive - -let set_ephemeral node path ephemeral = - let data = Vytree.get_data node path in - Vytree.update node path {data with ephemeral=ephemeral} - -let is_ephemeral node path = - let data = Vytree.get_data node path in - data.ephemeral - -module Renderer = -struct - (* TODO Replace use of Printf with Format *) - - module L = List - module S = String - module PF = Printf - module VT = Vytree - module RT = Reference_tree - - (* Nodes are ordered based on a comarison of their names *) - let compare cmp node1 node2 = - let name1 = VT.name_of_node node1 in - let name2 = VT.name_of_node node2 in - cmp name1 name2 - - let indentation indent level = S.make (level * indent) ' ' - - let render_inactive data = if data.inactive then "#INACTIVE " else "" - let render_ephemeral data = if data.ephemeral then "#EPHEMERAL " else "" - - let render_comment data indents = - match data.comment with - | None -> "" - (* Trailing indentation for the rest of the material on the next line *) - | Some c -> PF.sprintf "/*%s*/\n%s" c indents - - let render_tag = function - | None -> "" - | Some tag -> PF.sprintf "%s " tag - - let render_outer indents data name tag = - [render_comment data indents ; - render_inactive data; - render_ephemeral data; - render_tag tag; - name] - |> S.concat "" - - let render_values ?(valueless=false) values = - let quote_if_needed s = - try - let _ = Pcre.exec ~pat:"[\\s;{}#\\[\\]\"\']" s in - Printf.sprintf "\"%s\"" s - with Not_found -> s - in - match values with - | [] -> if valueless then ";" else "{ }" - | [v] -> PF.sprintf "%s;" (quote_if_needed v) - | _ as vs -> S.concat "; " (List.map quote_if_needed vs) |> PF.sprintf "[%s];" - - let render_inner_and_outer indents inner outer = - if inner = "" - (* Hidden or empty descendents yield empty nodes *) - then PF.sprintf "%s%s { }" indents outer - else PF.sprintf "%s%s %s" indents outer inner - - let render - ?(indent=4) - ?(reftree=None) - ?(cmp=BatString.numeric_compare) - ?(showephemeral=false) - ?(showinactive=false) - (config_tree:t) - = - let is_hidden data = - (not showephemeral && data.ephemeral) || - (not showinactive && data.inactive) - in - let rec render_node level ?tag node = - let data = VT.data_of_node node in - let name = VT.name_of_node node in - (* Hide inactive and ephemeral when necessary *) - if is_hidden data then "" - else - let indents = indentation indent level in - let outer = render_outer indents data name tag in - let inner = (* Children are ignored if the node has values *) - match data.values with - | [] -> VT.children_of_node node |> render_children level - | values -> render_values values - in - PF.sprintf "%s%s %s" indents outer inner - and render_children level = function - | [] -> "{ }" - | children -> - let indents = indentation indent level in - let render_child node = render_node (level + 1) node in - let rendered_children = L.map render_child children |> S.concat "\n" - in - if rendered_children = "" then "{ }" - else PF.sprintf "{\n%s\n%s}" rendered_children indents - in - (* Walks the reftree and config_tree side-by-side *) - let rec render_node_rt level tag rt node = - let data = VT.data_of_node node in - let name = VT.name_of_node node in - let rt_data = VT.data_of_node rt in - let rt_name = VT.name_of_node rt in - (* Hide inactive and ephemeral when necessary *) - if is_hidden data then "" - else - (* TODO refactor this ugly approach*) - let (outer_name, level', inner) = - let open RT in - let children = VT.children_of_node node in - let ordered = rt_data.keep_order in - match rt_data.node_type with - | Tag -> - ("", 0, render_children_rt level (Some name) ordered rt children) - | Other -> - (name, level, render_children_rt level None ordered rt children) - | Leaf -> - (name, level, render_values ~valueless:rt_data.valueless data.values) - in - let indents = indentation indent level' in - let outer = render_outer indents data outer_name tag in - (* Do not insert a space before ; for valueless nodes *) - if rt_data.valueless then PF.sprintf "%s%s%s" indents outer inner - else PF.sprintf "%s%s %s" indents outer inner - and render_children_rt level tag ordered rt = function - | [] -> "{ }" - | children -> - let is_tagged = BatOption.is_some tag in - let indents = indentation indent level in - let reorder nodes = - if ordered then nodes - else L.sort (compare cmp) nodes - in - let render_child node = - let level' = if is_tagged then level else level + 1 in - let node_reftree = VT.find rt (VT.name_of_node node) in - (* If there is no reftree for a node, default to stand-alone *) - match node_reftree with - | Some rt' -> render_node_rt level' tag rt' node - | None -> render_node level' ?tag node - in - let rendered_children = children - |> reorder - |> L.map render_child - |> S.concat "\n" - in - if rendered_children = "" then "{ }" - else if is_tagged - then rendered_children - else PF.sprintf "{\n%s\n%s}" rendered_children indents - in - match reftree with - | None -> render_node 0 config_tree - | Some rt -> render_node_rt 0 None rt config_tree - - - (* 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 ?(reftree=None) ?(alwayssort=false) 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 = BatOption.default "" data.comment in - let comment_cmd = (if comment = "" then "" else Printf.sprintf "comment %s \'%s\'" new_path_str comment) in - (* Sort child names, if required *) - let child_names = Vytree.list_children ct in - let child_names = - begin - match reftree with - | Some rt -> - if ((RT.get_keep_order rt path) && (not alwayssort)) then child_names - else (List.sort BatString.numeric_compare child_names) - | None -> - if alwayssort then (List.sort BatString.numeric_compare child_names) - else child_names - end - 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 - | children -> - (* A node with children *) - let children = List.map (fun n -> Vytree.get ct [n]) child_names in - let rendered_children = List.map (render_commands ~reftree:reftree ~alwayssort:alwayssort 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 - - -end (* Renderer *) - -let render = Renderer.render - -let render_at_level - ?(indent=4) - ?(reftree=None) - ?(cmp=BatString.numeric_compare) - ?(showephemeral=false) - ?(showinactive=false) - node - path = - let node = - match path with - | [] -> node - | _ -> Vytree.get node path - in - let children = Vytree.children_of_node node in - let child_configs = List.map (render ~indent:indent ~reftree:reftree ~cmp:cmp ~showephemeral:showephemeral ~showinactive:showinactive) children in - String.concat "\n" child_configs - -let render_commands ?(reftree=None) ?(alwayssort=false) ?(sortchildren=false) node path = - let node = - match path with - | [] -> node - | _ -> Vytree.get node path - in - let children = - if sortchildren then Vytree.sorted_children_of_node (BatString.numeric_compare) node - else Vytree.children_of_node node - in - let commands = List.map (Renderer.render_commands ~reftree:reftree ~alwayssort:alwayssort path) children in - String.concat "\n" commands diff --git a/src/config_tree.mli b/src/config_tree.mli deleted file mode 100644 index 79426e3..0000000 --- a/src/config_tree.mli +++ /dev/null @@ -1,78 +0,0 @@ -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; - inactive : bool; - ephemeral : bool; -} [@@deriving yojson] - -type t = config_node_data Vytree.t [@@deriving yojson] - -val default_data : config_node_data - -val make : string -> t - -val set : t -> string list -> string option -> value_behaviour -> t - -val delete : t -> string list -> string option -> t - -val get_values : t -> string list -> string list - -val get_value : t -> string list -> string - -val set_comment : t -> string list -> string option -> t - -val get_comment : t -> string list -> string option - -val set_inactive : t -> string list -> bool -> t - -val is_inactive : t -> string list -> bool - -val set_ephemeral : t -> string list -> bool -> t - -val is_ephemeral : t -> string list -> bool - -(** Interface to two rendering routines: - 1. The stand-alone routine, when [reftree] is not provided - 2. The reference-tree guided routine, when [reftree] is provided. - - If an {i incomplete} reftree is supplied, then the remaining portion of the - config tree will be rendered according to the stand-alone routine. - - If an {i incompatible} reftree is supplied (i.e., the name of the nodes of - the reftree do not match the name of the nodes in the config tree), then the - exception {! Config_tree.Renderer.Inapt_reftree} is raised. - - @param indent spaces by which each level of nesting should be indented - @param reftree optional reference tree used to instruct rendering - @param cmp function used to sort the order of children, overruled - if [reftree] specifies [keep_order] for a node - @param showephemeral boolean determining whether ephemeral nodes are shown - @param showinactive boolean determining whether inactive nodes are shown -*) -val render : - ?indent:int -> - ?reftree:(Reference_tree.t option)-> - ?cmp:(string -> string -> int) -> - ?showephemeral:bool -> - ?showinactive:bool -> - t -> - string - -val render_at_level : - ?indent:int -> - ?reftree:(Reference_tree.t option)-> - ?cmp:(string -> string -> int) -> - ?showephemeral:bool -> - ?showinactive:bool -> - t -> - string list -> - string - -val render_commands: ?reftree:(Reference_tree.t option) -> ?alwayssort:bool -> ?sortchildren:bool -> t -> string list -> string diff --git a/src/curly_lexer.mll b/src/curly_lexer.mll deleted file mode 100644 index 32e566a..0000000 --- a/src/curly_lexer.mll +++ /dev/null @@ -1,90 +0,0 @@ -{ - -open Curly_parser - -exception Error of string - -} - -rule token = parse -| [' ' '\t' '\r'] - { token lexbuf } -| '\n' - { Lexing.new_line lexbuf; token lexbuf } -| '"' - { read_string (Buffer.create 16) lexbuf } -| ''' - { read_single_quoted_string (Buffer.create 16) lexbuf } -| "//" [^ '\n']+ '\n' - { Lexing.new_line lexbuf ; token lexbuf } -| "/*" - { read_comment (Buffer.create 16) lexbuf } -| "#INACTIVE" - { INACTIVE } -| "#EPHEMERAL" - { EPHEMERAL } -| '{' - { LEFT_BRACE } -| '}' - { RIGHT_BRACE } -| '[' - { LEFT_BRACKET } -| ']' - { RIGHT_BRACKET } -| ';' - { SEMI } -| [^ ' ' '\t' '\n' '\r' '{' '}' '[' ']' ';' '#' '"' ''' ]+ as s - { IDENTIFIER s} -| eof - { EOF } -| _ -{ raise (Error (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) } - -and read_string buf = - parse - | '"' { STRING (Buffer.contents buf) } - | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } - | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } - | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } - | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } - | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } - | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } - | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } - | '\\' '\'' { Buffer.add_char buf '\''; read_string buf lexbuf } - | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } - | '\n' { Lexing.new_line lexbuf; Buffer.add_char buf '\n'; read_string buf lexbuf } - | [^ '"' '\\']+ - { Buffer.add_string buf (Lexing.lexeme lexbuf); - read_string buf lexbuf - } - | _ { raise (Error (Printf.sprintf "Illegal string character: %s" (Lexing.lexeme lexbuf))) } - | eof { raise (Error ("String is not terminated")) } - -and read_single_quoted_string buf = - parse - | ''' { STRING (Buffer.contents buf) } - | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } - | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } - | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } - | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } - | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } - | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } - | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } - | '\\' '\'' { Buffer.add_char buf '\''; read_string buf lexbuf } - | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } - | '\n' { Lexing.new_line lexbuf; Buffer.add_char buf '\n'; read_string buf lexbuf } - | [^ ''' '\\']+ - { Buffer.add_string buf (Lexing.lexeme lexbuf); - read_single_quoted_string buf lexbuf - } - | _ { raise (Error (Printf.sprintf "Illegal string character: %s" (Lexing.lexeme lexbuf))) } - | eof { raise (Error ("String is not terminated")) } - -and read_comment buf = - parse - | "*/" - { COMMENT (Buffer.contents buf) } - | _ - { Buffer.add_string buf (Lexing.lexeme lexbuf); - read_comment buf lexbuf - } diff --git a/src/curly_parser.mly b/src/curly_parser.mly deleted file mode 100644 index be5aadc..0000000 --- a/src/curly_parser.mly +++ /dev/null @@ -1,114 +0,0 @@ -%{ - open Config_tree - - exception Duplicate_child of (string * string) - - (* Used for checking if after merging immediate children, - any of them have duplicate children inside, - e.g. "interfaces { ethernet eth0 {...} ethernet eth0 {...} }" *) - let find_duplicate_children n = - let rec aux xs = - let xs = List.sort compare xs in - match xs with - | [] | [_] -> () - | x :: x' :: xs -> - if x = x' then raise (Duplicate_child (Vytree.name_of_node n, x)) - else aux (x' :: xs) - in - aux @@ Vytree.list_children n - - (* When merging nodes with values, append values of subsequent nodes to the - first one *) - let merge_data l r = {l with values=(List.append l.values r.values)} -%} - -%token <string> IDENTIFIER -%token <string> STRING -%token <string> COMMENT -%token INACTIVE -%token EPHEMERAL -%token LEFT_BRACE -%token RIGHT_BRACE -%token LEFT_BRACKET -%token RIGHT_BRACKET -%token SEMI -%token EOF - -%start <Config_tree.t> config -%% - -opt_comment: - | (* empty *) { None } - | c = COMMENT { Some (String.trim c) } -; - -value: - | v = STRING - { v } - | v = IDENTIFIER - { v } -; - -values: - | v = value { [v] } - | LEFT_BRACKET; vs = separated_nonempty_list(SEMI, value); RIGHT_BRACKET - { (List.rev vs) } -; - -leaf_node: - | comment = opt_comment; inactive = boption(INACTIVE); ephemeral = boption(EPHEMERAL); - name = IDENTIFIER; values = values; SEMI - { Vytree.make_full {values=(List.rev values); comment=comment; inactive=inactive; ephemeral=ephemeral} name []} - | comment = opt_comment; inactive = boption(INACTIVE); ephemeral = boption(EPHEMERAL); - name = IDENTIFIER; SEMI (* valueless node *) - { Vytree.make_full {default_data with comment=comment; inactive=inactive; ephemeral=ephemeral} name [] } -; - -node: - | comment = opt_comment; inactive = boption(INACTIVE); ephemeral = boption(EPHEMERAL); - name = IDENTIFIER; LEFT_BRACE; children = list(node_content); RIGHT_BRACE - { - let node = - Vytree.make_full {default_data with comment=comment; inactive=inactive; ephemeral=ephemeral} name [] in - let node = List.fold_left Vytree.adopt node (List.rev children) |> Vytree.merge_children merge_data in - try - List.iter find_duplicate_children (Vytree.children_of_node node); - node - with - | Duplicate_child (child, dup) -> - failwith (Printf.sprintf "Node \"%s %s\" has two children named \"%s\"" name child dup) - } -; - -tag_node: - | comment = opt_comment; inactive = boption(INACTIVE); ephemeral = boption(EPHEMERAL); - name = IDENTIFIER; tag = IDENTIFIER; LEFT_BRACE; children = list(node_content); RIGHT_BRACE - { - let outer_node = Vytree.make_full default_data name [] in - let inner_node = - Vytree.make_full {default_data with comment=comment; inactive=inactive; ephemeral=ephemeral} tag [] in - let inner_node = List.fold_left Vytree.adopt inner_node (List.rev children) |> Vytree.merge_children merge_data in - let node = Vytree.adopt outer_node inner_node in - try - List.iter find_duplicate_children (Vytree.children_of_node inner_node); - node - with - | Duplicate_child (child, dup) -> - failwith (Printf.sprintf "Node \"%s %s %s\" has two children named \"%s\"" name tag child dup) - } - -node_content: n = node { n } | n = leaf_node { n } | n = tag_node { n }; - -%public config: - | ns = list(node); EOF - { - let root = make "root" in - let root = List.fold_left Vytree.adopt root (List.rev ns) |> Vytree.merge_children merge_data in - try - List.iter find_duplicate_children (Vytree.children_of_node root); - root - with - | Duplicate_child (child, dup) -> - failwith (Printf.sprintf "Node \"%s\" has two children named \"%s\"" child dup) - } -; diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..ff86052 --- /dev/null +++ b/src/dune @@ -0,0 +1,5 @@ +(library + (name vyconf) + (public_name vyconf) + (libraries vyos1x-config lwt lwt.unix lwt_log lwt_ppx ocaml-protoc toml sha yojson ppx_deriving.show ppx_deriving_yojson) + (preprocess (pps lwt_ppx ppx_deriving.show ppx_deriving_yojson))) diff --git a/src/reference_tree.ml b/src/reference_tree.ml deleted file mode 100644 index 45789eb..0000000 --- a/src/reference_tree.ml +++ /dev/null @@ -1,237 +0,0 @@ -type node_type = Leaf | Tag | Other - -type ref_node_data = { - node_type: node_type; - constraints: (Value_checker.value_constraint list); - help: string; - value_help: (string * string) list; - constraint_error_message: string; - multi: bool; - valueless: bool; - owner: string option; - keep_order: bool; - hidden: bool; - secret: bool; -} - -type t = ref_node_data Vytree.t - -exception Bad_interface_definition of string - -exception Validation_error of string - -let default_data = { - node_type = Other; - constraints = []; - help = "No help available"; - value_help = []; - constraint_error_message = "Invalid value"; - multi = false; - valueless = false; - owner = None; - keep_order = false; - hidden = false; - secret = false; -} - -let default = Vytree.make default_data "root" - -(* Loading from XML *) - -let node_type_of_string s = - match s with - | "node" -> Other - | "tagNode" -> Tag - | "leafNode" -> Leaf - | _ -> raise (Bad_interface_definition - (Printf.sprintf "node, tagNode, or leafNode expected, %s found" s)) - -let load_constraint_from_xml d c = - let aux d c = - match c with - | Xml.Element ("regex", _, [Xml.PCData s]) -> - let cs = (Value_checker.Regex s) :: d.constraints in - {d with constraints=cs} - | Xml.Element ("validator", [("name", n); ("argument", a)], _) -> - let cs = (Value_checker.External (n, Some a)) :: d.constraints in - {d with constraints=cs} - | Xml.Element ("validator", [("name", n)], _) -> - let cs = (Value_checker.External (n, None)) :: d.constraints in - {d with constraints=cs} - | _ -> raise (Bad_interface_definition "Malformed constraint") - in Xml.fold aux d c - -let data_from_xml d x = - let aux d x = - match x with - | Xml.Element ("help", _, [Xml.PCData s]) -> {d with help=s} - | Xml.Element ("valueHelp", _, - [Xml.Element ("format", _, [Xml.PCData fmt]); - Xml.Element ("description", _, [Xml.PCData descr])]) -> - let vhs = d.value_help in - let vhs' = (fmt, descr) :: vhs in - {d with value_help=vhs'} - | Xml.Element ("multi", _, _) -> {d with multi=true} - | Xml.Element ("valueless", _, _) -> {d with valueless=true} - | Xml.Element ("constraintErrorMessage", _, [Xml.PCData s]) -> - {d with constraint_error_message=s} - | Xml.Element ("constraint", _, _) -> load_constraint_from_xml d x - | Xml.Element ("hidden", _, _) -> {d with hidden=true} - | Xml.Element ("secret", _, _) -> {d with secret=true} - | Xml.Element ("keepChildOrder", _, _) -> {d with keep_order=true} - | _ -> raise (Bad_interface_definition "Malformed property tag") - in Xml.fold aux d x - -let rec insert_from_xml basepath reftree xml = - match xml with - | Xml.Element (tag, _, _) -> - let props = Util.find_xml_child "properties" xml in - let data = - (match props with - | None -> default_data - | Some p -> data_from_xml default_data p) - in - let node_type = node_type_of_string (Xml.tag xml) in - let node_owner = try let o = Xml.attrib xml "owner" in Some o - with _ -> None - in - let data = {data with node_type=node_type; owner=node_owner} in - let name = Xml.attrib xml "name" in - let path = basepath @ [name] in - let new_tree = Vytree.insert reftree path data in - (match node_type with - | Leaf -> new_tree - | _ -> - let children = Util.find_xml_child "children" xml in - (match children with - | None -> raise (Bad_interface_definition (Printf.sprintf "Node %s has no children" name)) - | Some c -> List.fold_left (insert_from_xml path) new_tree (Xml.children c))) - | _ -> raise (Bad_interface_definition "PCData not allowed here") - -let load_from_xml reftree file = - let xml_to_reftree xml reftree = - match xml with - | Xml.Element ("interfaceDefinition", attrs, children) -> - List.fold_left (insert_from_xml []) reftree children - | _ -> raise (Bad_interface_definition "Should start with <interfaceDefinition>") - in - try - let xml = Xml.parse_file file in - xml_to_reftree xml reftree - with - | Xml.File_not_found msg -> raise (Bad_interface_definition msg) - | Xml.Error e -> raise (Bad_interface_definition (Xml.error e)) - -(* 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 - -(** 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 non-valueless leaf node without a value - 3. It's a valueless node with a value - 4. It's a non-valueless leaf node with garbage after the value - 5. It's a non-leaf, non-tag node with a name that doesn't exist - in the reference tree - *) -let rec 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 -> - (match path with - | [] -> - if data.valueless then (List.rev acc, None) - else raise (Validation_error - (Printf.sprintf "Node %s requires a value" (show_path acc) )) - | [p] -> - if not data.valueless then - (if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, Some p) - else raise (Validation_error data.constraint_error_message)) - else raise (Validation_error - (Printf.sprintf "Node %s cannot have a value" (show_path acc))) - | p :: ps -> raise (Validation_error (Printf.sprintf "Path %s is too long" (show_path acc)))) - | Tag -> - (match path with - | p :: p' :: ps -> - (match (has_illegal_characters p) with - | Some c -> raise (Validation_error (Printf.sprintf "Illegal character \"%s\" in node name \"%s\"" c p)) - | None -> - if (Value_checker.validate_any validators_dir data.constraints p) then - let child = Vytree.find node p' in - (match child with - | Some c -> aux c ps (p' :: p :: acc) - | None -> raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p'))) - else raise (Validation_error (Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc)))) - | [p] -> if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, None) - else raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p)) - | _ -> raise (Validation_error (Printf.sprintf "Path %s is incomplete" (show_path acc)))) - | Other -> - (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 -> raise (Validation_error ((Printf.sprintf "Path %s is incomplete" (show_path acc)))))) - in aux node path [] - -let is_multi reftree path = - let data = Vytree.get_data reftree path in - data.multi - -let is_hidden reftree path = - let data = Vytree.get_data reftree path in - data.hidden - -let is_secret reftree path = - let data = Vytree.get_data reftree path in - data.secret - -let is_tag reftree path = - let data = Vytree.get_data reftree path in - match data.node_type with - | Tag -> true - | _ -> false - -let is_leaf reftree path = - let data = Vytree.get_data reftree path in - match data.node_type with - | Leaf -> true - | _ -> false - -let is_valueless reftree path = - let data = Vytree.get_data reftree path in - data.valueless - -let get_keep_order reftree path = - let data = Vytree.get_data reftree path in - data.keep_order - -let get_owner reftree path = - let data = Vytree.get_data reftree path in - data.owner - -let get_help_string reftree path = - let data = Vytree.get_data reftree path in - data.help - -let get_value_help reftree path = - let data = Vytree.get_data reftree path in - data.value_help - -let get_completion_data reftree path = - let aux node = - let data = Vytree.data_of_node node in - (data.node_type, data.multi, data.help) - in List.map aux (Vytree.children_of_node @@ Vytree.get reftree path) diff --git a/src/reference_tree.mli b/src/reference_tree.mli deleted file mode 100644 index 33813d5..0000000 --- a/src/reference_tree.mli +++ /dev/null @@ -1,51 +0,0 @@ -type node_type = Leaf | Tag | Other - -type ref_node_data = { - node_type: node_type; - constraints: (Value_checker.value_constraint list); - help: string; - value_help: (string * string) list; - constraint_error_message: string; - multi: bool; - valueless: bool; - owner: string option; - keep_order: bool; - hidden: bool; - secret: bool; -} - -exception Bad_interface_definition of string - -exception Validation_error of string - -type t = ref_node_data Vytree.t - -val default_data : ref_node_data - -val default : t - -val load_from_xml : t -> string -> t - -val validate_path : string -> t -> string list -> string list * string option - -val is_multi : t -> string list -> bool - -val is_hidden : t -> string list -> bool - -val is_secret : t -> string list -> bool - -val is_tag : t -> string list -> bool - -val is_leaf : t -> string list -> bool - -val is_valueless : t -> string list -> bool - -val get_keep_order : t -> string list -> bool - -val get_owner : 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 diff --git a/src/session.ml b/src/session.ml index 832bfe6..7624bb0 100644 --- a/src/session.ml +++ b/src/session.ml @@ -1,5 +1,6 @@ -module CT = Config_tree -module RT = Reference_tree +module CT = Vyos1x.Config_tree +module VT = Vyos1x.Vytree +module RT = Vyos1x.Reference_tree module D = Directories exception Session_error of string @@ -16,7 +17,7 @@ type world = { } type session_data = { - proposed_config : Config_tree.t; + proposed_config : CT.t; modified: bool; conf_mode: bool; changeset: cfg_op list; @@ -64,20 +65,22 @@ let rec apply_changes changeset config = | c :: cs -> apply_changes cs (apply_cfg_op c config) let set w s path = - let path, value = RT.validate_path D.(w.dirs.validators) w.reference_tree path in + let path, value = RT.validate_path D.(w.dirs.validators) + w.reference_tree path in let value_behaviour = if RT.is_multi w.reference_tree path then CT.AddValue else CT.ReplaceValue in let op = CfgSet (path, value, value_behaviour) in let config = apply_cfg_op op s.proposed_config in {s with proposed_config=config; changeset=(op :: s.changeset)} let delete w s path = - let path, value = RT.validate_path D.(w.dirs.validators) w.reference_tree path in + let path, value = RT.validate_path D.(w.dirs.validators) + w.reference_tree path in let op = CfgDelete (path, value) in let config = apply_cfg_op op s.proposed_config in {s with proposed_config=config; changeset=(op :: s.changeset)} let get_value w s path = - if not (Vytree.exists s.proposed_config path) then + if not (VT.exists s.proposed_config path) then raise (Session_error ("Path does not exist")) else if not (RT.is_leaf w.reference_tree path) then raise (Session_error "Cannot get a value of a non-leaf node") @@ -88,7 +91,7 @@ let get_value w s path = else CT.get_value s.proposed_config path let get_values w s path = - if not (Vytree.exists s.proposed_config path) then + if not (VT.exists s.proposed_config path) then raise (Session_error ("Path does not exist")) else if not (RT.is_leaf w.reference_tree path) then raise (Session_error "Cannot get a value of a non-leaf node") @@ -97,18 +100,18 @@ let get_values w s path = else CT.get_values s.proposed_config path let list_children w s path = - if not (Vytree.exists s.proposed_config path) then + if not (VT.exists s.proposed_config path) then raise (Session_error ("Path does not exist")) else if (RT.is_leaf w.reference_tree path) then raise (Session_error "Cannot list children of a leaf node") - else Vytree.children_of_path s.proposed_config path + else VT.children_of_path s.proposed_config path -let exists w s path = - Vytree.exists s.proposed_config path +let exists _w s path = + VT.exists s.proposed_config path -let show_config w s path fmt = +let show_config _w s path fmt = let open Vyconf_types in - if (path <> []) && not (Vytree.exists s.proposed_config path) then + if (path <> []) && not (VT.exists s.proposed_config path) then raise (Session_error ("Path does not exist")) else let node = s.proposed_config in @@ -117,5 +120,5 @@ let show_config w s path fmt = | Json -> let node = (match path with [] -> s.proposed_config | - _ as ps -> Vytree.get s.proposed_config ps) in + _ as ps -> VT.get s.proposed_config ps) in CT.to_yojson node |> Yojson.Safe.pretty_to_string diff --git a/src/session.mli b/src/session.mli index 299f2ca..f59ea7b 100644 --- a/src/session.mli +++ b/src/session.mli @@ -1,16 +1,16 @@ type cfg_op = - | CfgSet of string list * string option * Config_tree.value_behaviour + | CfgSet of string list * string option * Vyos1x.Config_tree.value_behaviour | CfgDelete of string list * string option type world = { - running_config: Config_tree.t; - reference_tree: Reference_tree.t; + running_config: Vyos1x.Config_tree.t; + reference_tree: Vyos1x.Reference_tree.t; vyconf_config: Vyconf_config.t; dirs: Directories.t } type session_data = { - proposed_config : Config_tree.t; + proposed_config : Vyos1x.Config_tree.t; modified: bool; conf_mode: bool; changeset: cfg_op list; @@ -22,6 +22,10 @@ exception Session_error of string val make : world -> string -> string -> session_data +val set_modified : session_data -> session_data + +val apply_changes : cfg_op list -> Vyos1x.Config_tree.t -> Vyos1x.Config_tree.t + val set : world -> session_data -> string list -> session_data val delete : world -> session_data -> string list -> session_data diff --git a/src/startup.ml b/src/startup.ml index cea5f02..4cf109c 100644 --- a/src/startup.ml +++ b/src/startup.ml @@ -75,11 +75,21 @@ let create_server accept_connection sock = let load_config file = try let chan = open_in file in - let config = Curly_parser.config Curly_lexer.token (Lexing.from_channel chan) in + let s = really_input_string chan (in_channel_length chan) in + let config = Vyos1x.Parser.from_string s in Ok config with | Sys_error msg -> Error msg - | Curly_parser.Error -> Error "Parse error" + | Vyos1x.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 (** Load the appliance configuration file or the fallback config *) let load_config_failsafe main fallback = @@ -99,7 +109,7 @@ let load_config_failsafe main fallback = (* Load interface definitions from a directory into a reference tree *) let load_interface_definitions dir = - let open Reference_tree in + let open Vyos1x.Reference_tree in let relative_paths = FileUtil.ls dir in let absolute_paths = try Ok (List.map Util.absolute_path relative_paths) diff --git a/src/startup.mli b/src/startup.mli index c32ddea..abe731f 100644 --- a/src/startup.mli +++ b/src/startup.mli @@ -12,8 +12,8 @@ val create_server : (Lwt_unix.file_descr * Lwt_unix.sockaddr -> unit Lwt.t) -> Lwt_unix.file_descr -> unit -> 'a Lwt.t -val load_config : string -> (Config_tree.t, string) result +val load_config : string -> (Vyos1x.Config_tree.t, string) result -val load_config_failsafe : string -> string -> Config_tree.t +val load_config_failsafe : string -> string -> Vyos1x.Config_tree.t -val load_interface_definitions : string -> (Reference_tree.t, string) result +val load_interface_definitions : string -> (Vyos1x.Reference_tree.t, string) result diff --git a/src/util.ml b/src/util.ml index c4bbd96..ec988e9 100644 --- a/src/util.ml +++ b/src/util.ml @@ -8,7 +8,7 @@ let find_xml_child name xml = | _ -> false in match xml with - | Xml.Element (_, _, children) -> Vylist.find find_aux children + | Xml.Element (_, _, children) -> Vyos1x.Vylist.find find_aux children | Xml.PCData _ -> None (** Convert a list of strings to a string of unquoted, space separated words *) diff --git a/src/value_checker.ml b/src/value_checker.ml deleted file mode 100644 index aa88f7b..0000000 --- a/src/value_checker.ml +++ /dev/null @@ -1,39 +0,0 @@ -module F = Filename - -type value_constraint = Regex of string | External of string * string option - -exception Bad_validator of string - -let validate_value dir value_constraint value = - match value_constraint with - | Regex s -> - (try - let _ = Pcre.exec ~pat:s value in true - with Not_found -> false) - | External (v, c) -> - (* XXX: Using Unix.system 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 arg = BatOption.default "" c in - let safe_arg = Printf.sprintf "'%s'" (Pcre.qreplace ~pat:"\"" ~templ:"\\\"" arg) in - let result = Unix.system (Printf.sprintf "%s %s %s" validator safe_arg value) in - match result with - | Unix.WEXITED 0 -> true - | Unix.WEXITED 127 -> raise (Bad_validator (Printf.sprintf "Could not execute validator %s" validator)) - | _ -> 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 rec aux validators constraints value = - match constraints with - | [] -> false - | c :: cs -> if validate_value validators c value then true - else aux validators cs value - in - match constraints with - | [] -> true - | _ -> aux validators constraints value diff --git a/src/value_checker.mli b/src/value_checker.mli deleted file mode 100644 index d786f5e..0000000 --- a/src/value_checker.mli +++ /dev/null @@ -1,7 +0,0 @@ -type value_constraint = Regex of string | External of string * string option - -exception Bad_validator of string - -val validate_value : string -> value_constraint -> string -> bool - -val validate_any : string -> value_constraint list -> string -> bool diff --git a/src/vycli.ml b/src/vycli.ml index e00a4e3..6c1ed0c 100644 --- a/src/vycli.ml +++ b/src/vycli.ml @@ -60,7 +60,7 @@ let main socket op path out_format config_format = begin match resp.status with | Success -> Ok "" |> Lwt.return - | _ -> Error (BatOption.default "" resp.error) |> Lwt.return + | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return end | OpSetupSession -> let%lwt resp = setup_session client "vycli" in @@ -81,7 +81,7 @@ let main socket op path out_format config_format = | Error e -> let%lwt () = Lwt_io.write Lwt_io.stderr (Printf.sprintf "%s\n" e) in Lwt.return 1 let _ = - let () = Arg.parse args (fun f -> ()) usage in + let () = Arg.parse args (fun _ -> ()) usage in let path = String.trim !path_opt |> Pcre.split ~pat:"\\s+" in let out_format = output_format_of_string !out_format_opt in let config_format = config_format_of_string !conf_format_opt in diff --git a/src/vyconf_client.ml b/src/vyconf_client.ml index db7d9c1..63ff121 100644 --- a/src/vyconf_client.ml +++ b/src/vyconf_client.ml @@ -22,8 +22,8 @@ let create ?(token=None) sockfile out_format conf_format = let open Lwt_unix in let sock = socket PF_UNIX SOCK_STREAM 0 in let%lwt () = connect sock (ADDR_UNIX sockfile) in - let ic = Lwt_io.of_fd Lwt_io.Input sock in - let oc = Lwt_io.of_fd Lwt_io.Output sock in + let ic = Lwt_io.of_fd ~mode:Lwt_io.Input sock in + let oc = Lwt_io.of_fd ~mode:Lwt_io.Output sock in Lwt.return { sock=sock; ic=ic; oc=oc; enc=(Pbrt.Encoder.create ()); closed=false; @@ -55,7 +55,7 @@ let get_status client = Lwt.return resp let setup_session ?(on_behalf_of=None) client client_app = - if BatOption.is_some client.session then Lwt.return (Error "Client is already associated with a session") else + if Option.is_some client.session then Lwt.return (Error "Client is already associated with a session") else let id = on_behalf_of |> (function None -> None | Some x -> (Some (Int32.of_int x))) in let req = Setup_session {client_application=(Some client_app); on_behalf_of=id} in let%lwt resp = do_request client req in @@ -64,7 +64,7 @@ let setup_session ?(on_behalf_of=None) client client_app = (match resp.output with | Some token -> Ok {client with session=(Some token)} | None -> Error "setup_session did not return a session token!") |> Lwt.return - | _ -> Error (BatOption.default "Unknown error" resp.error) |> Lwt.return + | _ -> Error (Option.value resp.error ~default:"Unknown error") |> Lwt.return let exists client path = let req = Exists {path=path} in @@ -72,33 +72,33 @@ let exists client path = match resp.status with | Success -> Lwt.return (Ok "") | Fail -> Lwt.return (Error "") - | _ -> Error (BatOption.default "" resp.error) |> Lwt.return + | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return let get_value client path = let req = Get_value {path=path; output_format=(Some client.out_format)} in let%lwt resp = do_request client req in match resp.status with | Success -> unwrap resp.output |> Lwt.return - | _ -> Error (BatOption.default ""resp.error) |> Lwt.return + | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return let get_values client path = let req = Get_values {path=path; output_format=(Some client.out_format)} in let%lwt resp = do_request client req in match resp.status with | Success -> unwrap resp.output |> Lwt.return - | _ -> Error (BatOption.default "" resp.error) |> Lwt.return + | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return let list_children client path = let req = List_children {path=path; output_format=(Some client.out_format)} in let%lwt resp = do_request client req in match resp.status with | Success -> unwrap resp.output |> Lwt.return - | _ -> Error (BatOption.default "" resp.error) |> Lwt.return + | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return let show_config client path = let req = Show_config {path=path; format=(Some client.conf_format)} in let%lwt resp = do_request client req in match resp.status with | Success -> unwrap resp.output |> Lwt.return - | _ -> Error (BatOption.default "" resp.error) |> Lwt.return + | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return diff --git a/src/vyconf_config.ml b/src/vyconf_config.ml index 7a87c1a..07ab3ef 100644 --- a/src/vyconf_config.ml +++ b/src/vyconf_config.ml @@ -37,7 +37,7 @@ let get_field conf tbl_name field_name = (* NB: TomlLenses module uses "table" and "field" names for function names, hence tbl_name and field_name *) - TomlLenses.(get conf (key tbl_name |-- table |-- key field_name |-- string)) + Toml.Lenses.(get conf (key tbl_name |-- table |-- key field_name |-- string)) let mandatory_field conf table field = let value = get_field conf table field in @@ -47,7 +47,7 @@ let mandatory_field conf table field = let optional_field default conf table field = let value = get_field conf table field in - BatOption.default default value + Option.value value ~default:default let load filename = try diff --git a/src/vyconf_pb.ml b/src/vyconf_pb.ml index 4dced0f..c6155da 100644 --- a/src/vyconf_pb.ml +++ b/src/vyconf_pb.ml @@ -806,13 +806,13 @@ let rec encode_request_output_format (v:Vyconf_types.request_output_format) enco let rec encode_request_setup_session (v:Vyconf_types.request_setup_session) encoder = begin match v.Vyconf_types.client_application with | Some x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; | None -> (); end; begin match v.Vyconf_types.on_behalf_of with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; Pbrt.Encoder.int32_as_varint x encoder; | None -> (); end; @@ -820,12 +820,12 @@ let rec encode_request_setup_session (v:Vyconf_types.request_setup_session) enco let rec encode_request_set (v:Vyconf_types.request_set) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; begin match v.Vyconf_types.ephemeral with | Some x -> - Pbrt.Encoder.key (3, Pbrt.Varint) encoder; + Pbrt.Encoder.key 3 Pbrt.Varint encoder; Pbrt.Encoder.bool x encoder; | None -> (); end; @@ -833,96 +833,96 @@ let rec encode_request_set (v:Vyconf_types.request_set) encoder = let rec encode_request_delete (v:Vyconf_types.request_delete) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; () let rec encode_request_rename (v:Vyconf_types.request_rename) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.edit_level; - Pbrt.Encoder.key (2, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 2 Pbrt.Bytes encoder; Pbrt.Encoder.string v.Vyconf_types.from encoder; - Pbrt.Encoder.key (3, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 3 Pbrt.Bytes encoder; Pbrt.Encoder.string v.Vyconf_types.to_ encoder; () let rec encode_request_copy (v:Vyconf_types.request_copy) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.edit_level; - Pbrt.Encoder.key (2, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 2 Pbrt.Bytes encoder; Pbrt.Encoder.string v.Vyconf_types.from encoder; - Pbrt.Encoder.key (3, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 3 Pbrt.Bytes encoder; Pbrt.Encoder.string v.Vyconf_types.to_ encoder; () let rec encode_request_comment (v:Vyconf_types.request_comment) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; - Pbrt.Encoder.key (2, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 2 Pbrt.Bytes encoder; Pbrt.Encoder.string v.Vyconf_types.comment encoder; () let rec encode_request_commit (v:Vyconf_types.request_commit) encoder = begin match v.Vyconf_types.confirm with | Some x -> - Pbrt.Encoder.key (1, Pbrt.Varint) encoder; + Pbrt.Encoder.key 1 Pbrt.Varint encoder; Pbrt.Encoder.bool x encoder; | None -> (); end; begin match v.Vyconf_types.confirm_timeout with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; Pbrt.Encoder.int32_as_varint x encoder; | None -> (); end; begin match v.Vyconf_types.comment with | Some x -> - Pbrt.Encoder.key (3, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 3 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; | None -> (); end; () let rec encode_request_rollback (v:Vyconf_types.request_rollback) encoder = - Pbrt.Encoder.key (1, Pbrt.Varint) encoder; + Pbrt.Encoder.key 1 Pbrt.Varint encoder; Pbrt.Encoder.int32_as_varint v.Vyconf_types.revision encoder; () let rec encode_request_load (v:Vyconf_types.request_load) encoder = - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string v.Vyconf_types.location encoder; begin match v.Vyconf_types.format with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; encode_request_config_format x encoder; | None -> (); end; () let rec encode_request_merge (v:Vyconf_types.request_merge) encoder = - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string v.Vyconf_types.location encoder; begin match v.Vyconf_types.format with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; encode_request_config_format x encoder; | None -> (); end; () let rec encode_request_save (v:Vyconf_types.request_save) encoder = - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string v.Vyconf_types.location encoder; begin match v.Vyconf_types.format with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; encode_request_config_format x encoder; | None -> (); end; @@ -930,12 +930,12 @@ let rec encode_request_save (v:Vyconf_types.request_save) encoder = let rec encode_request_show_config (v:Vyconf_types.request_show_config) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; begin match v.Vyconf_types.format with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; encode_request_config_format x encoder; | None -> (); end; @@ -943,19 +943,19 @@ let rec encode_request_show_config (v:Vyconf_types.request_show_config) encoder let rec encode_request_exists (v:Vyconf_types.request_exists) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; () let rec encode_request_get_value (v:Vyconf_types.request_get_value) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; begin match v.Vyconf_types.output_format with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; encode_request_output_format x encoder; | None -> (); end; @@ -963,12 +963,12 @@ let rec encode_request_get_value (v:Vyconf_types.request_get_value) encoder = let rec encode_request_get_values (v:Vyconf_types.request_get_values) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; begin match v.Vyconf_types.output_format with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; encode_request_output_format x encoder; | None -> (); end; @@ -976,12 +976,12 @@ let rec encode_request_get_values (v:Vyconf_types.request_get_values) encoder = let rec encode_request_list_children (v:Vyconf_types.request_list_children) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; begin match v.Vyconf_types.output_format with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; encode_request_output_format x encoder; | None -> (); end; @@ -989,100 +989,100 @@ let rec encode_request_list_children (v:Vyconf_types.request_list_children) enco let rec encode_request_run_op_mode (v:Vyconf_types.request_run_op_mode) encoder = List.iter (fun x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; ) v.Vyconf_types.path; begin match v.Vyconf_types.output_format with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; encode_request_output_format x encoder; | None -> (); end; () let rec encode_request_enter_configuration_mode (v:Vyconf_types.request_enter_configuration_mode) encoder = - Pbrt.Encoder.key (1, Pbrt.Varint) encoder; + Pbrt.Encoder.key 1 Pbrt.Varint encoder; Pbrt.Encoder.bool v.Vyconf_types.exclusive encoder; - Pbrt.Encoder.key (2, Pbrt.Varint) encoder; + Pbrt.Encoder.key 2 Pbrt.Varint encoder; Pbrt.Encoder.bool v.Vyconf_types.override_exclusive encoder; () let rec encode_request (v:Vyconf_types.request) encoder = begin match v with | Vyconf_types.Status -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.empty_nested encoder | Vyconf_types.Setup_session x -> - Pbrt.Encoder.key (2, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_setup_session x) encoder; + Pbrt.Encoder.key 2 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_setup_session x encoder; | Vyconf_types.Set x -> - Pbrt.Encoder.key (3, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_set x) encoder; + Pbrt.Encoder.key 3 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_set x encoder; | Vyconf_types.Delete x -> - Pbrt.Encoder.key (4, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_delete x) encoder; + Pbrt.Encoder.key 4 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_delete x encoder; | Vyconf_types.Rename x -> - Pbrt.Encoder.key (5, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_rename x) encoder; + Pbrt.Encoder.key 5 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_rename x encoder; | Vyconf_types.Copy x -> - Pbrt.Encoder.key (6, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_copy x) encoder; + Pbrt.Encoder.key 6 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_copy x encoder; | Vyconf_types.Comment x -> - Pbrt.Encoder.key (7, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_comment x) encoder; + Pbrt.Encoder.key 7 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_comment x encoder; | Vyconf_types.Commit x -> - Pbrt.Encoder.key (8, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_commit x) encoder; + Pbrt.Encoder.key 8 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_commit x encoder; | Vyconf_types.Rollback x -> - Pbrt.Encoder.key (9, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_rollback x) encoder; + Pbrt.Encoder.key 9 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_rollback x encoder; | Vyconf_types.Merge x -> - Pbrt.Encoder.key (10, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_merge x) encoder; + Pbrt.Encoder.key 10 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_merge x encoder; | Vyconf_types.Save x -> - Pbrt.Encoder.key (11, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_save x) encoder; + Pbrt.Encoder.key 11 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_save x encoder; | Vyconf_types.Show_config x -> - Pbrt.Encoder.key (12, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_show_config x) encoder; + Pbrt.Encoder.key 12 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_show_config x encoder; | Vyconf_types.Exists x -> - Pbrt.Encoder.key (13, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_exists x) encoder; + Pbrt.Encoder.key 13 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_exists x encoder; | Vyconf_types.Get_value x -> - Pbrt.Encoder.key (14, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_get_value x) encoder; + Pbrt.Encoder.key 14 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_get_value x encoder; | Vyconf_types.Get_values x -> - Pbrt.Encoder.key (15, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_get_values x) encoder; + Pbrt.Encoder.key 15 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_get_values x encoder; | Vyconf_types.List_children x -> - Pbrt.Encoder.key (16, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_list_children x) encoder; + Pbrt.Encoder.key 16 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_list_children x encoder; | Vyconf_types.Run_op_mode x -> - Pbrt.Encoder.key (17, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_run_op_mode x) encoder; + Pbrt.Encoder.key 17 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_run_op_mode x encoder; | Vyconf_types.Confirm -> - Pbrt.Encoder.key (18, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 18 Pbrt.Bytes encoder; Pbrt.Encoder.empty_nested encoder | Vyconf_types.Configure x -> - Pbrt.Encoder.key (19, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request_enter_configuration_mode x) encoder; + Pbrt.Encoder.key 19 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request_enter_configuration_mode x encoder; | Vyconf_types.Exit_configure -> - Pbrt.Encoder.key (20, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 20 Pbrt.Bytes encoder; Pbrt.Encoder.empty_nested encoder | Vyconf_types.Teardown x -> - Pbrt.Encoder.key (21, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 21 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; end let rec encode_request_envelope (v:Vyconf_types.request_envelope) encoder = begin match v.Vyconf_types.token with | Some x -> - Pbrt.Encoder.key (1, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 1 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; | None -> (); end; - Pbrt.Encoder.key (2, Pbrt.Bytes) encoder; - Pbrt.Encoder.nested (encode_request v.Vyconf_types.request) encoder; + Pbrt.Encoder.key 2 Pbrt.Bytes encoder; + Pbrt.Encoder.nested encode_request v.Vyconf_types.request encoder; () let rec encode_status (v:Vyconf_types.status) encoder = @@ -1098,23 +1098,23 @@ let rec encode_status (v:Vyconf_types.status) encoder = | Vyconf_types.Path_already_exists -> Pbrt.Encoder.int_as_varint 8 encoder let rec encode_response (v:Vyconf_types.response) encoder = - Pbrt.Encoder.key (1, Pbrt.Varint) encoder; + Pbrt.Encoder.key 1 Pbrt.Varint encoder; encode_status v.Vyconf_types.status encoder; begin match v.Vyconf_types.output with | Some x -> - Pbrt.Encoder.key (2, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 2 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; | None -> (); end; begin match v.Vyconf_types.error with | Some x -> - Pbrt.Encoder.key (3, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 3 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; | None -> (); end; begin match v.Vyconf_types.warning with | Some x -> - Pbrt.Encoder.key (4, Pbrt.Bytes) encoder; + Pbrt.Encoder.key 4 Pbrt.Bytes encoder; Pbrt.Encoder.string x encoder; | None -> (); end; diff --git a/src/vyconfd.ml b/src/vyconfd.ml index d79bda9..f3816d4 100644 --- a/src/vyconfd.ml +++ b/src/vyconfd.ml @@ -5,6 +5,7 @@ open Vyconf_pb open Vyconf_types module FP = FilePath +module CT = Vyos1x.Config_tree (* On UNIX, self_init uses /dev/random for seed *) let () = Random.self_init () @@ -43,7 +44,7 @@ let make_session_token () = let setup_session world req = let token = make_session_token () in let user = "unknown user" in - let client_app = BatOption.default "unknown client" req.client_application in + let client_app = Option.value req.client_application ~default:"unknown client" in let () = Hashtbl.add sessions token (Session.make world client_app user) in {response_tmpl with output=(Some token)} @@ -95,7 +96,7 @@ let get_value world token (req: request_get_value) = try let () = (Lwt_log.debug @@ Printf.sprintf "[%s]\n" (Util.string_of_list req.path)) |> Lwt.ignore_result in let value = Session.get_value world (find_session token) req.path in - let fmt = BatOption.default Out_plain req.output_format in + let fmt = Option.value req.output_format ~default:Out_plain in let value_str = (match fmt with | Out_plain -> value @@ -106,7 +107,7 @@ let get_value world token (req: request_get_value) = let get_values world token (req: request_get_values) = try let values = Session.get_values world (find_session token) req.path in - let fmt = BatOption.default Out_plain req.output_format in + let fmt = Option.value req.output_format ~default:Out_plain in let values_str = (match fmt with | Out_plain -> Util.string_of_list @@ List.map (Printf.sprintf "\'%s\'") values @@ -117,7 +118,7 @@ let get_values world token (req: request_get_values) = let list_children world token (req: request_list_children) = try let children = Session.list_children world (find_session token) req.path in - let fmt = BatOption.default Out_plain req.output_format in + let fmt = Option.value req.output_format ~default:Out_plain in let children_str = (match fmt with | Out_plain -> Util.string_of_list @@ List.map (Printf.sprintf "\'%s\'") children @@ -127,7 +128,7 @@ let list_children world token (req: request_list_children) = let show_config world token (req: request_show_config) = try - let fmt = BatOption.default Curly req.format in + let fmt = Option.value req.format ~default:Curly in let conf_str = Session.show_config world (find_session token) req.path fmt in {response_tmpl with output=(Some conf_str)} with Session.Session_error msg -> {response_tmpl with status=Fail; error=(Some msg)} @@ -179,14 +180,14 @@ let rec handle_connection world ic oc fd () = let accept_connection world conn = let fd, _ = conn in - let ic = Lwt_io.of_fd Lwt_io.Input fd in - let oc = Lwt_io.of_fd Lwt_io.Output fd in + let ic = Lwt_io.of_fd ~mode:Lwt_io.Input fd in + let oc = Lwt_io.of_fd ~mode:Lwt_io.Output fd in Lwt.on_failure (handle_connection world ic oc fd ()) (fun e -> Lwt_log.ign_error (Printexc.to_string e)); Lwt_log.info "New connection" >>= return let main_loop basepath world () = let open Session in - let log_file = BatOption.bind !log_file (fun s -> Some (FP.concat basepath s)) in + let log_file = Option.bind !log_file (fun s -> Some (FP.concat basepath s)) in let%lwt () = Startup.setup_logger !daemonize log_file world.vyconf_config.log_template in let%lwt () = Lwt_log.notice @@ Printf.sprintf "Starting VyConf for %s" world.vyconf_config.app_name in let%lwt sock = Startup.create_socket (FP.concat basepath world.vyconf_config.socket) in @@ -194,7 +195,7 @@ let main_loop basepath world () = serve () let load_interface_definitions dir = - let open Session in +(* let open Session in *) let reftree = Startup.load_interface_definitions dir in match reftree with | Ok r -> r @@ -204,11 +205,11 @@ let make_world config dirs = let open Directories in let open Session in let reftree = load_interface_definitions dirs.interface_definitions in - let running_config = Config_tree.make "root" in + let running_config = CT.make "root" in {running_config=running_config; reference_tree=reftree; vyconf_config=config; dirs=dirs} let () = - let () = Arg.parse args (fun f -> ()) usage in + let () = Arg.parse args (fun _ -> ()) usage in let vc = Startup.load_daemon_config !config_file in let () = Lwt_log.load_rules ("* -> " ^ vc.log_level) in let dirs = Directories.make !basepath vc in @@ -218,5 +219,5 @@ let () = (FP.concat vc.config_dir vc.primary_config) (FP.concat vc.config_dir vc.fallback_config) in let world = Session.{world with running_config=config} in - let () = print_endline (Config_tree.render world.running_config) in + let () = print_endline (CT.render_config world.running_config) in Lwt_main.run @@ main_loop !basepath world () diff --git a/src/vylist.ml b/src/vylist.ml deleted file mode 100644 index cd4a32e..0000000 --- a/src/vylist.ml +++ /dev/null @@ -1,46 +0,0 @@ -let rec find p xs = - match xs with - | [] -> None - | y :: ys -> if (p y) then (Some y) - else find p ys - -let rec remove p xs = - match xs with - | [] -> [] - | y :: ys -> if (p y) then ys - else y :: (remove p ys) - -let rec replace p x xs = - match xs with - | [] -> raise Not_found - | y :: ys -> if (p y) then x :: ys - else y :: (replace p x ys) - -let rec insert_before p x xs = - match xs with - | [] -> raise Not_found - | y :: ys -> if (p y) then x :: y :: ys - else y :: (insert_before p x ys) - -let rec insert_after p x xs = - match xs with - | [] -> raise Not_found - | y :: ys -> if (p y) then y :: x :: ys - else y :: (insert_after p x ys) - -let complement xs ys = - let rec aux xs ys = - match xs, ys with - | [], _ -> ys - | _, [] -> assert false (* Can't happen *) - | p :: ps, q :: qs -> if p = q then aux ps qs - else [] - in - if List.length xs < List.length ys then aux xs ys - else aux ys xs - -let in_list xs x = - let x' = find ((=) x) xs in - match x' with - | None -> false - | Some _ -> true diff --git a/src/vylist.mli b/src/vylist.mli deleted file mode 100644 index 9135bf6..0000000 --- a/src/vylist.mli +++ /dev/null @@ -1,7 +0,0 @@ -val find : ('a -> bool) -> 'a list -> 'a option -val remove : ('a -> bool) -> 'a list -> 'a list -val replace : ('a -> bool) -> 'a -> 'a list -> 'a list -val insert_before : ('a -> bool) -> 'a -> 'a list -> 'a list -val insert_after : ('a -> bool) -> 'a -> 'a list -> 'a list -val complement : 'a list -> 'a list -> 'a list -val in_list : 'a list -> 'a -> bool diff --git a/src/vytree.ml b/src/vytree.ml deleted file mode 100644 index a3e2750..0000000 --- a/src/vytree.ml +++ /dev/null @@ -1,192 +0,0 @@ -type 'a t = { - name: string; - data: 'a; - children: 'a t list -} [@@deriving yojson] - -type position = Before of string | After of string | End | Default - -exception Empty_path -exception Duplicate_child -exception Nonexistent_path -exception Insert_error of string - -let make data name = { name = name; data = data; children = [] } - -let make_full data name children = { name = name; data = data; children = children } - -let name_of_node node = node.name -let data_of_node node = node.data -let children_of_node node = node.children - -let insert_immediate ?(position=Default) node name data children = - let new_node = make_full data name children in - let children' = - match position with - | Default -> new_node :: node.children - | End -> node.children @ [new_node] - | Before s -> Vylist.insert_before (fun x -> x.name = s) new_node node.children - | After s -> Vylist.insert_after (fun x -> x.name = s) new_node node.children - in { node with children = children' } - -let delete_immediate node name = - let children' = Vylist.remove (fun x -> x.name = name) node.children in - { node with children = children' } - -let adopt node child = - { node with children = child :: node.children } - -let replace node child = - let children = node.children in - let name = child.name in - let children' = Vylist.replace (fun x -> x.name = name) child children in - { node with children = children' } - -let replace_full node child name = - let children = node.children in - let children' = Vylist.replace (fun x -> x.name = name) child children in - { node with children = children' } - -let find node name = - Vylist.find (fun x -> x.name = name) node.children - -let find_or_fail node name = - let child = find node name in - match child with - | None -> raise Nonexistent_path - | Some child' -> child' - -let list_children node = - List.map (fun x -> x.name) node.children - -let rec do_with_child fn node path = - match path with - | [] -> raise Empty_path - | [name] -> fn node name - | name :: names -> - let next_child = find_or_fail node name in - let new_node = do_with_child fn next_child names in - replace node new_node - -let rec insert ?(position=Default) ?(children=[]) node path data = - match path with - | [] -> raise Empty_path - | [name] -> - (let last_child = find node name in - match last_child with - | None -> insert_immediate ~position:position node name data children - | (Some _) -> raise Duplicate_child) - | name :: names -> - let next_child = find node name in - match next_child with - | Some next_child' -> - let new_node = insert ~position:position ~children:children next_child' names data in - replace node new_node - | None -> - raise (Insert_error "Path does not exist") - -(** Given a node N check if it has children with duplicate names, - and merge subsequent children's children into the first child by - that name. - - While all insert functions maintain the "every child has unique name" - invariant, for nodes constructed manually with make/make_full and adopt - it may not hold, and constructing nodes this way is a sensible approach - for config parsing. Depending on the config format, duplicate node names - may be normal and even expected, such as "ethernet eth0" and "ethernet eth1" - in the "curly" format. - *) -let merge_children merge_data node = - (* Given a node N and a list of nodes NS, find all nodes in NS that - have the same name as N and merge their children into N *) - let rec merge_into n ns = - match ns with - | [] -> n - | n' :: ns' -> - if n.name = n'.name then - let children = List.append n.children n'.children in - let data = merge_data n.data n'.data in - let n = {n with children=children; data=data} in - merge_into n ns' - else merge_into n ns' - in - (* Given a list of nodes, for every node, find subsequent children with - the same name and merge them into the first node, then delete remaining - nodes from the list *) - let rec aux ns = - match ns with - | [] -> [] - | n :: ns -> - let n = merge_into n ns in - let ns = List.filter (fun x -> x.name <> n.name) ns in - n :: (aux ns) - in {node with children=(aux node.children)} - -(* When inserting at a path that, entirely or partially, - does not exist yet, create missing nodes on the way with default data *) -let rec insert_multi_level default_data node path_done path_remaining data = - match path_remaining with - | [] | [_] -> insert node (path_done @ path_remaining) data - | name :: names -> - let path_done = path_done @ [name] in - let node = insert node path_done default_data in - insert_multi_level default_data node path_done names data - -let delete node path = - do_with_child delete_immediate node path - -let rename node path newname = - let rename_immediate newname' node' name' = - let child = find_or_fail node' name' in - let child = { child with name=newname' } in - replace_full node' child name' - in do_with_child (rename_immediate newname) node path - -let update node path data = - let update_data data' node' name = - let child = find_or_fail node' name in - let child = { child with data=data' } in - replace node' child - in do_with_child (update_data data) node path - -let rec get node path = - match path with - | [] -> raise Empty_path - | [name] -> find_or_fail node name - | name :: names -> get (find_or_fail node name) names - -let get_data node path = data_of_node @@ get node path - -let exists node path = - try ignore (get node path); true - with Nonexistent_path -> false - -let get_existent_path node path = - let rec aux node path acc = - match path with - | [] -> acc - | name :: names -> - let child = find node name in - match child with - | None -> acc - | Some c -> aux c names (name :: acc) - in List.rev (aux node path []) - -let children_of_path node path = - let node' = get node path in - list_children node' - -let sorted_children_of_node cmp node = - let names = list_children node in - let names = List.sort cmp names in - List.map (find_or_fail node) names - -let copy node old_path new_path = - if exists node new_path then raise Duplicate_child else - let child = get node old_path in - insert ~position:End ~children:child.children node new_path child.data - -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 diff --git a/src/vytree.mli b/src/vytree.mli deleted file mode 100644 index 451e130..0000000 --- a/src/vytree.mli +++ /dev/null @@ -1,50 +0,0 @@ -type 'a t [@@deriving yojson] - -exception Empty_path -exception Duplicate_child -exception Nonexistent_path -exception Insert_error of string - -type position = Before of string | After of string | End | Default - -val make : 'a -> string -> 'a t -val make_full : 'a -> string -> ('a t) list -> 'a t - -val name_of_node : 'a t -> string -val data_of_node : 'a t -> 'a -val children_of_node : 'a t -> 'a t list - -val find : 'a t -> string -> 'a t option -val find_or_fail : 'a t -> string -> 'a t - -val adopt : 'a t -> 'a t -> 'a t - -val insert : ?position:position -> ?children:('a t list) -> 'a t -> string list -> 'a -> 'a t - -val insert_multi_level : 'a -> 'a t -> string list -> string list -> 'a -> 'a t - -val merge_children : ('a -> 'a -> 'a) -> 'a t -> 'a t - -val delete : 'a t -> string list -> 'a t - -val update : 'a t -> string list -> 'a -> 'a t - -val rename : 'a t -> string list -> string -> 'a t - -val list_children : 'a t -> string list - -val get : 'a t -> string list -> 'a t - -val get_existent_path : 'a t -> string list -> string list - -val get_data : 'a t -> string list -> 'a - -val exists : 'a t -> string list -> bool - -val children_of_path : 'a t -> string list -> string list - -val sorted_children_of_node : (string -> string -> int) -> 'a t -> ('a t) list - -val copy : 'a t -> string list -> string list -> 'a t - -val move : 'a t -> string list -> position -> 'a t |