Unix domain sock

idl/xenvm_client.ml

@@ -1,5 +1,19 @@
 open Cohttp_lwt_unix
 
+let unix_domain_socket_path = ref "/var/run/xenvm.sock"
+
+let _ =
+  let service svc =
+    match svc with
+    | "file" -> Lwt.return (Some {Resolver.name="file"; port=0; tls=false})
+    | _ -> Resolver_lwt_unix.system_service svc
+  in
+  Resolver_lwt.set_service ~f:service Resolver_lwt_unix.system;
+  Resolver_lwt.add_rewrite ~host:"local" ~f:(fun svc uri ->
+      match svc.Resolver.name with
+      | "file" -> Lwt.return (`Unix_domain_socket !unix_domain_socket_path : Conduit.endp)
+      | _ -> Resolver_lwt_unix.system_resolver svc uri) Resolver_lwt_unix.system
+
 module Rpc = struct
   include Lwt
 

test.xenvmd.conf

@@ -1,5 +1,6 @@
 (
  (listenPort 4000)
+ (listenPath None)
  (host_allocation_quantum 128)
  (host_low_water_mark 8)
  (vg djstest)

xenvm/xenvm_common.ml

@@ -178,10 +178,11 @@ let copts_sect = "COMMON OPTIONS"
 
 type copts_t = {
   uri_override : string option; (* CLI set URI override *)
+  sockpath_override : string option; (* CLI set unix domain socket path override *)
   config : string;
 }
 
-let make_copts config uri_override = {uri_override; config }
+let make_copts config uri_override sockpath_override = {uri_override; config; sockpath_override }
 
 let config =
   let doc = "Path to the config directory" in
@@ -195,6 +196,10 @@ let uri_arg_required =
   let doc = "Overrides the URI of the XenVM daemon in charge of the volume group." in
   Arg.(required & opt (some string) None & info ["u"; "uri"] ~docv:"URI" ~doc)
 
+let sock_path_arg =
+  let doc = "Path to the local domain socket. Only used for file://local/ URIs" in
+  Arg.(value & opt (some string) None & info [ "S"; "sockpath"] ~docv:"PATH" ~doc)
+
 let local_allocator_path =
   let doc = "Path to the Unix domain socket where the local allocator is running." in
   Arg.(value & opt (some string) None & info [ "local-allocator-path" ] ~docv:"LOCAL" ~doc)
@@ -261,7 +266,7 @@ let output_arg default_fields =
   Term.(pure (parse_output default_fields) $ a)
 
 let copts_t =
-  Term.(pure make_copts $ config $ uri_arg)
+  Term.(pure make_copts $ config $ uri_arg $ sock_path_arg)
 
 let kib = 1024L
 let sectors = 512L
@@ -314,10 +319,11 @@ type vg_info_t = {
   uri : string;
   local_device : string;
   local_allocator_path : string option;
+  unix_domain_sock_path : string option;
 } with sexp
 
-let set_vg_info_t copts uri local_device local_allocator_path (vg_name,_) =
-  let info = {uri; local_device; local_allocator_path } in
+let set_vg_info_t copts uri local_device local_allocator_path unix_domain_sock_path (vg_name,_) =
+  let info = {uri; local_device; local_allocator_path; unix_domain_sock_path } in
   let filename = Filename.concat copts.config vg_name in
   let s = sexp_of_vg_info_t info |> Sexplib.Sexp.to_string in
   Lwt.catch (fun () -> Lwt_io.with_file ~mode:Lwt_io.Output filename (fun f ->
@@ -331,9 +337,9 @@ let set_vg_info_t copts uri local_device local_allocator_path (vg_name,_) =
       exit 1
     |e -> Lwt.fail e)
 
-let run_set_vg_info_t config uri local_allocator_path local_device vg_name =
-  let copts = make_copts config (Some uri) in
-  Lwt_main.run (set_vg_info_t copts uri local_device local_allocator_path vg_name)
+let run_set_vg_info_t config uri local_allocator_path local_device unix_domain_sock_path vg_name =
+  let copts = make_copts config (Some uri) unix_domain_sock_path in
+  Lwt_main.run (set_vg_info_t copts uri local_device local_allocator_path unix_domain_sock_path vg_name)
 
 let get_vg_info_t copts vg_name =
   let open Lwt in
@@ -354,7 +360,7 @@ let set_vg_info_cmd =
     `P "This command takes a physical device path and a URI, and will write these to the
 filesystem. Subsequent xenvm commands will use these as defaults.";
   ] in
-  Term.(pure run_set_vg_info_t $ config $ uri_arg_required $ local_allocator_path $ physical_device_arg_required $ name_arg),
+  Term.(pure run_set_vg_info_t $ config $ uri_arg_required $ local_allocator_path $ physical_device_arg_required $ sock_path_arg $ name_arg),
   Term.info "set-vg-info" ~sdocs:copts_sect ~doc ~man
 
 
@@ -369,9 +375,14 @@ let set_uri copts vg_info_opt =
       | Some info -> info.uri
       | None -> "http://127.0.0.1:4000/"
   in
-  Xenvm_client.Rpc.uri := uri
-
-
+  Xenvm_client.Rpc.uri := uri;
+  match copts.sockpath_override with
+  | Some x -> Xenvm_client.unix_domain_socket_path := x
+  | None ->
+    match vg_info_opt with
+    | Some { unix_domain_sock_path=Some x } ->
+      Xenvm_client.unix_domain_socket_path := x
+    | _ -> ()
 
 let padto blank n s =
   let result = String.make n blank in

xenvmd/xenvmd.ml

@@ -6,6 +6,7 @@ open Errors
 module Config = struct
   type t = {
     listenPort: int; (* TCP port number to listen on *)
+    listenPath: string option; (* path of a unix-domain socket to listen on *)
     host_allocation_quantum: int64; (* amount of allocate each host at a time (MiB) *)
     host_low_water_mark: int64; (* when the free memory drops below, we allocate (MiB) *)
     vg: string; (* name of the volume group *)
@@ -561,9 +562,10 @@ let handler ~info (ch,conn) req body =
   XenvmServer.process () (Jsonrpc.call_of_string bodystr) >>= fun result ->
   Server.respond_string ~status:`OK ~body:(Jsonrpc.string_of_response result) ()
 
-let run port config daemon =
+let run port sock_path config daemon =
   let config = Config.t_of_sexp (Sexplib.Sexp.load_sexp config) in
   let config = { config with Config.listenPort = match port with None -> config.Config.listenPort | Some x -> x } in
+  let config = { config with Config.listenPath = match sock_path with None -> config.Config.listenPath | Some x -> Some x } in
   if daemon then Lwt_daemon.daemonize ();
   let t =
     info "Started with configuration: %s" (Sexplib.Sexp.to_string_hum (Config.sexp_of_t config));
@@ -592,17 +594,35 @@ let run port config daemon =
       >>= fun () ->
       service_queues () in
 
-    let service_http () =
-      Printf.printf "Listening for HTTP request on: %d\n" config.Config.listenPort;
-      let info = Printf.sprintf "Served by Cohttp/Lwt listening on port %d" config.Config.listenPort in
+    let service_http mode =
+      let ty = match mode with
+        | `TCP (`Port x) -> Printf.sprintf "TCP port %d" x
+        | `Unix_domain_socket (`File p) -> Printf.sprintf "Unix domain socket '%s'" p
+        | _ -> "<unknown>"
+      in
+      Printf.printf "Listening for HTTP request on: %s\n" ty;
+      let info = Printf.sprintf "Served by Cohttp/Lwt listening on %s" ty in
       let conn_closed (ch,conn) = () in
       let callback = handler ~info in
       let c = Server.make ~callback ~conn_closed () in
-      let mode = `TCP (`Port config.Config.listenPort) in
       (* Listen for regular API calls *)
       Server.create ~mode c in
 
-    Lwt.join [ service_queues (); service_http () ] in
+    let tcp_mode = `TCP (`Port config.Config.listenPort) in
+
+    begin
+      match config.Config.listenPath with
+      | Some p ->
+        (* Remove the socket first, if it already exists *)
+        Lwt.catch (fun () -> Lwt_unix.unlink p) (fun _ -> Lwt.return ()) >>= fun () -> 
+        Lwt.return [ tcp_mode; `Unix_domain_socket (`File p) ]            
+      | None ->
+        Lwt.return [ tcp_mode ]
+    end >>= fun service_modes ->
+
+    let threads = List.map service_http service_modes in
+
+    Lwt.join ((service_queues ())::threads) in
 
   Lwt_main.run t
 
@@ -621,6 +641,10 @@ let port =
   let doc = "TCP port of xenvmd server" in
   Arg.(value & opt (some int) None & info [ "port" ] ~docv:"PORT" ~doc)
 
+let sock_path =
+  let doc = "Path to create unix-domain socket for server" in
+  Arg.(value & opt (some string) None & info [ "path" ] ~docv:"PATH" ~doc)
+
 let config =
   let doc = "Path to the config file" in
   Arg.(value & opt file "remoteConfig" & info [ "config" ] ~docv:"CONFIG" ~doc)
@@ -635,7 +659,7 @@ let cmd =
     `S "EXAMPLES";
     `P "TODO";
   ] in
-  Term.(pure run $ port $ config $ daemon),
+  Term.(pure run $ port $ sock_path $ config $ daemon),
   Term.info "xenvmd" ~version:"0.1" ~doc ~man
 
 let _ =