Merge pull request #11 from jestabro/vyconf-minimal

T6718: use the vyconf daemon for validation of set commands

1 files changed, 53 insertions, 37 deletions

diff --git a/src/vyconfd.ml b/src/vyconfd.ml
index d79bda9..7c4caeb 100644
--- a/src/vyconfd.ml
+++ b/src/vyconfd.ml
@@ -1,10 +1,14 @@
 open Lwt
-open Defaults
-open Vyconf_config
-open Vyconf_pb
-open Vyconf_types
+
+open Vyconf_connect.Vyconf_pbt
+open Vyconfd_config.Defaults
+open Vyconfd_config.Vyconf_config
 
 module FP = FilePath
+module CT = Vyos1x.Config_tree
+module Gen = Vyos1x.Generate
+module Session = Vyconfd_config.Session
+module Directories = Vyconfd_config.Directories
 
 (* On UNIX, self_init uses /dev/random for seed *)
 let () = Random.self_init ()
@@ -43,7 +47,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)}
 
@@ -80,10 +84,10 @@ let exit_conf_mode world token =
     in Hashtbl.replace sessions token session;
     response_tmpl
 
-let teardown_session token =
+let teardown token =
     try
         Hashtbl.remove sessions token;
-        response_tmpl
+        {response_tmpl with status=Success}
     with Not_found ->
         {response_tmpl with status=Fail; error=(Some "Session not found")}
 
@@ -93,9 +97,9 @@ let exists world token (req: request_exists) =
 
 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 () = (Lwt_log.debug @@ Printf.sprintf "[%s]\n" (Vyos1x.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,45 +110,52 @@ 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
-          | Out_json -> Util.json_of_list values)
+          | Out_plain -> Vyos1x.Util.string_of_list @@ List.map (Printf.sprintf "\'%s\'") values
+          | Out_json -> Vyos1x.Util.json_of_list values)
         in {response_tmpl with output=(Some values_str)}
     with Session.Session_error msg -> {response_tmpl with status=Fail; error=(Some msg)}
 
 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
-          | Out_json -> Util.json_of_list children)
+          | Out_plain -> Vyos1x.Util.string_of_list @@ List.map (Printf.sprintf "\'%s\'") children
+          | Out_json -> Vyos1x.Util.json_of_list children)
          in {response_tmpl with output=(Some children_str)}
     with Session.Session_error msg -> {response_tmpl with status=Fail; error=(Some msg)}
 
 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)}
 
+let validate world token (req: request_validate) =
+    try
+        let () = (Lwt_log.debug @@ Printf.sprintf "[%s]\n" (Vyos1x.Util.string_of_list req.path)) |> Lwt.ignore_result in
+        let () = Session.validate world (find_session token) req.path in
+        response_tmpl
+    with Session.Session_error msg -> {response_tmpl with status=Fail; error=(Some msg)}
+
 let send_response oc resp =
     let enc = Pbrt.Encoder.create () in
-    let%lwt () = encode_response resp enc |> return in
+    let%lwt () = encode_pb_response resp enc |> return in
     let%lwt resp_msg = Pbrt.Encoder.to_bytes enc |> return in
-    let%lwt () = Message.write oc resp_msg in
+    let%lwt () = Vyconf_connect.Message.write oc resp_msg in
     Lwt.return ()
 
-let rec handle_connection world ic oc fd () =
+let rec handle_connection world ic oc () =
     try%lwt
-        let%lwt req_msg = Message.read ic in
+        let%lwt req_msg = Vyconf_connect.Message.read ic in
         let%lwt req =
             try
-                let envelope = decode_request_envelope (Pbrt.Decoder.of_bytes req_msg) in
+                let envelope = decode_pb_request_envelope (Pbrt.Decoder.of_bytes req_msg) in
                 Lwt.return (Ok (envelope.token, envelope.request))
             with Pbrt.Decoder.Failure e -> Lwt.return (Error (Pbrt.Decoder.error_to_string e))
         in
@@ -157,7 +168,7 @@ let rec handle_connection world ic oc fd () =
                     | _, Status -> response_tmpl
                     | _, Setup_session r -> setup_session world r
                     | None, _ -> {response_tmpl with status=Fail; output=(Some "Operation requires session token")}
-                    | Some t, Teardown _ -> teardown_session t
+                    | Some t, Teardown _ -> teardown t
                     | Some t, Configure r -> enter_conf_mode r t
                     | Some t, Exit_configure -> exit_conf_mode world t
                     | Some t, Exists r -> exists world t r
@@ -165,28 +176,29 @@ let rec handle_connection world ic oc fd () =
                     | Some t, Get_values r -> get_values world t r
                     | Some t, List_children r -> list_children world t r
                     | Some t, Show_config r -> show_config world t r
+                    | Some t, Validate r -> validate world t r
                     | _ -> failwith "Unimplemented"
                 end) |> Lwt.return
         in
         let%lwt () = send_response oc resp in
-        handle_connection world ic oc fd ()
+        handle_connection world ic oc ()
     with
     | Failure e -> 
         let%lwt () = Lwt_log.error e in
         let%lwt () = send_response oc ({response_tmpl with status=Fail; error=(Some e)}) in
-        handle_connection world ic oc fd ()
-    | End_of_file -> Lwt_log.info "Connection closed" >>= return 
+        handle_connection world ic oc ()
+    | End_of_file -> Lwt_log.info "Connection closed" >>= (fun () -> Lwt_io.close ic) >>= return
 
 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
-    Lwt.on_failure (handle_connection world ic oc fd ()) (fun e -> Lwt_log.ign_error (Printexc.to_string e));
+    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 ()) (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,29 +206,33 @@ let main_loop basepath world () =
     serve ()
 
 let load_interface_definitions dir =
-    let open Session in
-    let reftree = Startup.load_interface_definitions dir in
+    let reftree = Gen.load_interface_definitions dir in
+    match reftree with
+    | Ok r -> r
+    | Error s -> Startup.panic s
+
+let read_reference_tree file =
+    let reftree = Startup.read_reference_tree file in
     match reftree with
     | Ok r -> r
     | Error s -> Startup.panic s
 
 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
+    (* the reference_tree json file is generated at vyos-1x build time *)
+    let reftree = read_reference_tree (FP.concat config.config_dir config.reference_tree) in
+    let running_config = CT.make "" 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
-  Startup.check_dirs dirs;
+  Startup.check_validators_dir dirs;
   let world = make_world vc dirs in
   let config = Startup.load_config_failsafe
       (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
   Lwt_main.run @@ main_loop !basepath world ()