T8061: add reference_path_exists request

Check whether a given config path has a form compatible with the
reference tree, irrespective of validity of values.

8 files changed, 102 insertions, 1 deletions

diff --git a/src/session.ml b/src/session.ml
index 478c423..c869a1a 100644
--- a/src/session.ml
+++ b/src/session.ml
@@ -391,6 +391,9 @@ let config_unsaved w s file id =
         with Session_error _ -> true (* false positive on unlikely error *)
     in remove_file tmp_save; res
 
+let reference_path_exists w _s path =
+    RT.reference_path_exists w.reference_tree path
+
 let write_running_cache w =
     (* alert exn Internal.write_internal:
         [Internal.Write_error] caught
diff --git a/src/session.mli b/src/session.mli
index cb49bf6..20e0c52 100644
--- a/src/session.mli
+++ b/src/session.mli
@@ -94,3 +94,5 @@ val get_config : world -> session_data -> string -> string
 val cleanup_config : world -> string -> unit
 
 val show_config : world -> session_data -> string list -> string
+
+val reference_path_exists : world -> session_data -> string list -> bool
diff --git a/src/vyconf_cli_compat.ml b/src/vyconf_cli_compat.ml
index 6ebd1f1..ae0d378 100644
--- a/src/vyconf_cli_compat.ml
+++ b/src/vyconf_cli_compat.ml
@@ -10,6 +10,7 @@ type op_t =
     | OpShowConfig
     | OpSessionChanged
     | OpConfigUnsaved
+    | OpReferencePathExists
 
 let op_of_arg s =
     match s with
@@ -21,6 +22,7 @@ let op_of_arg s =
     | "showCfg" -> OpShowConfig
     | "sessionChanged" -> OpSessionChanged
     | "sessionUnsaved" -> OpConfigUnsaved
+    | "validateTmplPath" -> OpReferencePathExists
     | _ -> failwith (Printf.sprintf "Unknown operation %s" s)
 
 let in_cli_config_session () =
@@ -91,6 +93,7 @@ let main op path =
         | OpShowConfig -> show_config c path
         | OpSessionChanged -> session_changed c
         | OpConfigUnsaved -> config_unsaved c None
+        | OpReferencePathExists -> reference_path_exists c path
         end
     | Error e -> Error e |> Lwt.return
     in
@@ -128,7 +131,7 @@ let () =
         with Failure msg -> let () = print_endline msg in exit 1
     in
     match op, path_list with
-    | OpSetEditLevel, [] ->
+    | OpSetEditLevel, [] | OpReferencePathExists, [] ->
         let () = print_endline "Must specify config path" in exit 1
     | _, _ ->
         let result = Lwt_main.run (main op path_list) in exit result
diff --git a/src/vyconf_client.ml b/src/vyconf_client.ml
index 76b6680..20899fe 100644
--- a/src/vyconf_client.ml
+++ b/src/vyconf_client.ml
@@ -229,3 +229,11 @@ let config_unsaved client file =
     | Success -> Lwt.return (Ok "")
     | Fail -> Error (Option.value resp.error ~default:"") |> Lwt.return
     | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return
+
+let reference_path_exists client path =
+    let req = Reference_path_exists {path=path;} in
+    let%lwt resp = do_request client req in
+    match resp.status with
+    | Success -> Lwt.return (Ok "")
+    | Fail -> Error (Option.value resp.error ~default:"") |> Lwt.return
+    | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return
diff --git a/src/vyconf_client.mli b/src/vyconf_client.mli
index a3744d7..7fe2dd8 100644
--- a/src/vyconf_client.mli
+++ b/src/vyconf_client.mli
@@ -49,3 +49,5 @@ val get_edit_level : t -> (string, string) result Lwt.t
 val edit_level_root : t -> (string, string) result Lwt.t
 
 val config_unsaved : t -> string option -> (string, string) result Lwt.t
+
+val reference_path_exists : t -> string list -> (string, string) result Lwt.t
diff --git a/src/vyconf_pbt.ml b/src/vyconf_pbt.ml
index 85eb4e3..e4b4935 100644
--- a/src/vyconf_pbt.ml
+++ b/src/vyconf_pbt.ml
@@ -183,6 +183,10 @@ type request_config_unsaved = {
   file : string option;
 }
 
+type request_reference_path_exists = {
+  path : string list;
+}
+
 type request =
   | Prompt
   | Setup_session of request_setup_session
@@ -222,6 +226,7 @@ type request =
   | Get_edit_level of request_get_edit_level
   | Edit_level_root of request_edit_level_root
   | Config_unsaved of request_config_unsaved
+  | Reference_path_exists of request_reference_path_exists
 
 type request_envelope = {
   token : string option;
@@ -525,6 +530,12 @@ let rec default_request_config_unsaved
   file;
 }
 
+let rec default_request_reference_path_exists 
+  ?path:((path:string list) = [])
+  () : request_reference_path_exists  = {
+  path;
+}
+
 let rec default_request (): request = Prompt
 
 let rec default_request_envelope 
@@ -887,6 +898,14 @@ let default_request_config_unsaved_mutable () : request_config_unsaved_mutable =
   file = None;
 }
 
+type request_reference_path_exists_mutable = {
+  mutable path : string list;
+}
+
+let default_request_reference_path_exists_mutable () : request_reference_path_exists_mutable = {
+  path = [];
+}
+
 type request_envelope_mutable = {
   mutable token : string option;
   mutable request : request;
@@ -1182,6 +1201,12 @@ let rec pp_request_config_unsaved fmt (v:request_config_unsaved) =
   in
   Pbrt.Pp.pp_brk pp_i fmt ()
 
+let rec pp_request_reference_path_exists fmt (v:request_reference_path_exists) = 
+  let pp_i fmt () =
+    Pbrt.Pp.pp_record_field ~first:true "path" (Pbrt.Pp.pp_list Pbrt.Pp.pp_string) fmt v.path;
+  in
+  Pbrt.Pp.pp_brk pp_i fmt ()
+
 let rec pp_request fmt (v:request) =
   match v with
   | Prompt  -> Format.fprintf fmt "Prompt"
@@ -1222,6 +1247,7 @@ let rec pp_request fmt (v:request) =
   | Get_edit_level x -> Format.fprintf fmt "@[<hv2>Get_edit_level(@,%a)@]" pp_request_get_edit_level x
   | Edit_level_root x -> Format.fprintf fmt "@[<hv2>Edit_level_root(@,%a)@]" pp_request_edit_level_root x
   | Config_unsaved x -> Format.fprintf fmt "@[<hv2>Config_unsaved(@,%a)@]" pp_request_config_unsaved x
+  | Reference_path_exists x -> Format.fprintf fmt "@[<hv2>Reference_path_exists(@,%a)@]" pp_request_reference_path_exists x
 
 let rec pp_request_envelope fmt (v:request_envelope) = 
   let pp_i fmt () =
@@ -1658,6 +1684,13 @@ let rec encode_pb_request_config_unsaved (v:request_config_unsaved) encoder =
   end;
   ()
 
+let rec encode_pb_request_reference_path_exists (v:request_reference_path_exists) encoder = 
+  Pbrt.List_util.rev_iter_with (fun x encoder -> 
+    Pbrt.Encoder.string x encoder;
+    Pbrt.Encoder.key 1 Pbrt.Bytes encoder; 
+  ) v.path encoder;
+  ()
+
 let rec encode_pb_request (v:request) encoder = 
   begin match v with
   | Prompt ->
@@ -1774,6 +1807,9 @@ let rec encode_pb_request (v:request) encoder =
   | Config_unsaved x ->
     Pbrt.Encoder.nested encode_pb_request_config_unsaved x encoder;
     Pbrt.Encoder.key 38 Pbrt.Bytes encoder; 
+  | Reference_path_exists x ->
+    Pbrt.Encoder.nested encode_pb_request_reference_path_exists x encoder;
+    Pbrt.Encoder.key 39 Pbrt.Bytes encoder; 
   end
 
 let rec encode_pb_request_envelope (v:request_envelope) encoder = 
@@ -2714,6 +2750,25 @@ let rec decode_pb_request_config_unsaved d =
     file = v.file;
   } : request_config_unsaved)
 
+let rec decode_pb_request_reference_path_exists d =
+  let v = default_request_reference_path_exists_mutable () in
+  let continue__= ref true in
+  while !continue__ do
+    match Pbrt.Decoder.key d with
+    | None -> (
+      v.path <- List.rev v.path;
+    ); continue__ := false
+    | Some (1, Pbrt.Bytes) -> begin
+      v.path <- (Pbrt.Decoder.string d) :: v.path;
+    end
+    | Some (1, pk) -> 
+      Pbrt.Decoder.unexpected_payload "Message(request_reference_path_exists), field(1)" pk
+    | Some (_, payload_kind) -> Pbrt.Decoder.skip d payload_kind
+  done;
+  ({
+    path = v.path;
+  } : request_reference_path_exists)
+
 let rec decode_pb_request d = 
   let rec loop () = 
     let ret:request = match Pbrt.Decoder.key d with
@@ -2765,6 +2820,7 @@ let rec decode_pb_request d =
       | Some (36, _) -> (Get_edit_level (decode_pb_request_get_edit_level (Pbrt.Decoder.nested d)) : request) 
       | Some (37, _) -> (Edit_level_root (decode_pb_request_edit_level_root (Pbrt.Decoder.nested d)) : request) 
       | Some (38, _) -> (Config_unsaved (decode_pb_request_config_unsaved (Pbrt.Decoder.nested d)) : request) 
+      | Some (39, _) -> (Reference_path_exists (decode_pb_request_reference_path_exists (Pbrt.Decoder.nested d)) : request) 
       | Some (n, payload_kind) -> (
         Pbrt.Decoder.skip d payload_kind; 
         loop () 
diff --git a/src/vyconf_pbt.mli b/src/vyconf_pbt.mli
index 285abfb..197d7d4 100644
--- a/src/vyconf_pbt.mli
+++ b/src/vyconf_pbt.mli
@@ -190,6 +190,10 @@ type request_config_unsaved = {
   file : string option;
 }
 
+type request_reference_path_exists = {
+  path : string list;
+}
+
 type request =
   | Prompt
   | Setup_session of request_setup_session
@@ -229,6 +233,7 @@ type request =
   | Get_edit_level of request_get_edit_level
   | Edit_level_root of request_edit_level_root
   | Config_unsaved of request_config_unsaved
+  | Reference_path_exists of request_reference_path_exists
 
 type request_envelope = {
   token : string option;
@@ -511,6 +516,12 @@ val default_request_config_unsaved :
   request_config_unsaved
 (** [default_request_config_unsaved ()] is the default value for type [request_config_unsaved] *)
 
+val default_request_reference_path_exists : 
+  ?path:string list ->
+  unit ->
+  request_reference_path_exists
+(** [default_request_reference_path_exists ()] is the default value for type [request_reference_path_exists] *)
+
 val default_request : unit -> request
 (** [default_request ()] is the default value for type [request] *)
 
@@ -656,6 +667,9 @@ val pp_request_edit_level_root : Format.formatter -> request_edit_level_root ->
 val pp_request_config_unsaved : Format.formatter -> request_config_unsaved -> unit 
 (** [pp_request_config_unsaved v] formats v *)
 
+val pp_request_reference_path_exists : Format.formatter -> request_reference_path_exists -> unit 
+(** [pp_request_reference_path_exists v] formats v *)
+
 val pp_request : Format.formatter -> request -> unit 
 (** [pp_request v] formats v *)
 
@@ -791,6 +805,9 @@ val encode_pb_request_edit_level_root : request_edit_level_root -> Pbrt.Encoder.
 val encode_pb_request_config_unsaved : request_config_unsaved -> Pbrt.Encoder.t -> unit
 (** [encode_pb_request_config_unsaved v encoder] encodes [v] with the given [encoder] *)
 
+val encode_pb_request_reference_path_exists : request_reference_path_exists -> Pbrt.Encoder.t -> unit
+(** [encode_pb_request_reference_path_exists v encoder] encodes [v] with the given [encoder] *)
+
 val encode_pb_request : request -> Pbrt.Encoder.t -> unit
 (** [encode_pb_request v encoder] encodes [v] with the given [encoder] *)
 
@@ -926,6 +943,9 @@ val decode_pb_request_edit_level_root : Pbrt.Decoder.t -> request_edit_level_roo
 val decode_pb_request_config_unsaved : Pbrt.Decoder.t -> request_config_unsaved
 (** [decode_pb_request_config_unsaved decoder] decodes a [request_config_unsaved] binary value from [decoder] *)
 
+val decode_pb_request_reference_path_exists : Pbrt.Decoder.t -> request_reference_path_exists
+(** [decode_pb_request_reference_path_exists decoder] decodes a [request_reference_path_exists] binary value from [decoder] *)
+
 val decode_pb_request : Pbrt.Decoder.t -> request
 (** [decode_pb_request decoder] decodes a [request] binary value from [decoder] *)
 
diff --git a/src/vyconfd.ml b/src/vyconfd.ml
index dc302e5..95e951e 100644
--- a/src/vyconfd.ml
+++ b/src/vyconfd.ml
@@ -417,6 +417,12 @@ let config_unsaved world token (req: request_config_unsaved) =
     then response_tmpl
     else {response_tmpl with status=Fail}
 
+let reference_path_exists world token (req: request_reference_path_exists) =
+    let path = req.path in
+    if Session.reference_path_exists world (find_session token) path
+    then response_tmpl
+    else {response_tmpl with status=Fail}
+
 let send_response oc resp =
     let enc = Pbrt.Encoder.create () in
     let%lwt () = encode_pb_response resp enc |> return in
@@ -474,6 +480,7 @@ let rec handle_connection world ic oc () =
                     | Some t, Get_edit_level r -> get_edit_level world t r
                     | Some t, Edit_level_root r -> edit_level_root world t r
                     | Some t, Config_unsaved r -> config_unsaved world t r
+                    | Some t, Reference_path_exists r -> reference_path_exists world t r
                     | _ -> failwith "Unimplemented"
                     ) |> Lwt.return
                end