diff --git a/idl/xenvm_client.ml b/idl/xenvm_client.ml index 5852eaf..806d9b5 100644 --- a/idl/xenvm_client.ml +++ b/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 diff --git a/test.xenvmd.conf b/test.xenvmd.conf index 93bb276..95be474 100644 --- a/test.xenvmd.conf +++ b/test.xenvmd.conf @@ -1,5 +1,6 @@ ( (listenPort 4000) + (listenPath None) (host_allocation_quantum 128) (host_low_water_mark 8) (vg djstest) diff --git a/xenvm/xenvm_common.ml b/xenvm/xenvm_common.ml index 1820bad..0f56e43 100644 --- a/xenvm/xenvm_common.ml +++ b/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 diff --git a/xenvmd/xenvmd.ml b/xenvmd/xenvmd.ml index 3dec7da..db50d9b 100644 --- a/xenvmd/xenvmd.ml +++ b/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 + | _ -> "" + 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 _ =