diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 65e4563..ae2d781 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -2,12 +2,13 @@ (* the process responsible for buffering console IO *) -(* communication channel is a single unix domain socket shared between vmmd and - vmm_console. The vmmd can issue the following commands: - - Add name --> creates a new console slurper for name - - Attach name since --> attaches console of name since counter, whenever - console output to name is reported, this will be forwarded as Data - - Detach name --> detaches console *) +(* communication channel is a single unix domain socket. The following commands + can be issued: + - Add name (by vmmd) --> creates a new console slurper for name, + and starts a read_console task + - Attach name --> attaches console of name: send existing stuff to client, + and record the requesting socket to receive further messages. A potential + earlier subscriber to the same console is closed. *) open Lwt.Infix @@ -83,28 +84,18 @@ let attach s id = Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ; match String.Map.find name !t with | None -> Lwt.return (Error (`Msg "not found")) - | Some _ -> - active := String.Map.add name s !active ; - Lwt.return (Ok "attached") - -let detach id = - let name = Vmm_core.string_of_id id in - active := String.Map.remove name !active ; - Lwt.return (Ok "removed") - -let history s name since = - match String.Map.find (Vmm_core.string_of_id name) !t with - | None -> Lwt.return (Rresult.R.error_msgf "ring %a not found (%d): %a" - Vmm_core.pp_id name (String.Map.cardinal !t) - Fmt.(list ~sep:(unit ";") string) - (List.map fst (String.Map.bindings !t))) | Some r -> - let entries = Vmm_ring.read_history r since in + let entries = Vmm_ring.read r in Logs.debug (fun m -> m "found %d history" (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> - Vmm_lwt.write_wire s (Vmm_wire.Console.data my_version name i v) >|= fun _ -> ()) - entries >|= fun () -> - Ok "success" + let msg = Vmm_wire.Console.data my_version id i v in + Vmm_lwt.write_wire s msg >|= fun _ -> ()) + entries >>= fun () -> + (match String.Map.find name !active with + | None -> Lwt.return_unit + | Some s -> Vmm_lwt.safe_close s) >|= fun () -> + active := String.Map.add name s !active ; + Ok "attached" let handle s addr () = Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr addr) ; @@ -120,22 +111,16 @@ let handle s addr () = Logs.err (fun m -> m "unexpected reply") ; loop () | Ok (hdr, data) -> - (if not (Vmm_wire.version_eq hdr.version my_version) then + (if not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) then Lwt.return (Error (`Msg "ignoring data with bad version")) else match Vmm_wire.decode_strings data with | Error e -> Lwt.return (Error e) - | Ok (id, off) -> match Vmm_wire.Console.int_to_op hdr.tag with + | Ok (id, _) -> match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with | Some Vmm_wire.Console.Add_console -> add_fifo id | Some Vmm_wire.Console.Attach_console -> attach s id - | Some Vmm_wire.Console.Detach_console -> detach id - | Some Vmm_wire.Console.History -> - (match Vmm_wire.decode_ptime ~off data with - | Error e -> Lwt.return (Error e) - | Ok since -> history s id since) | Some Vmm_wire.Console.Data -> Lwt.return (Error (`Msg "unexpected Data")) - | None -> - Lwt.return (Error (`Msg "unknown command"))) >>= (function + | None -> Lwt.return (Error (`Msg "unknown command"))) >>= (function | Ok msg -> Vmm_lwt.write_wire s (Vmm_wire.success ~msg my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag) | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; @@ -179,7 +164,7 @@ let setup_log = let socket = let doc = "Socket to listen on" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "cons" + "sock")) in + let sock = Vmm_core.socket_path `Console in Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) let cmd = diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index a13450c..62d389d 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -354,7 +354,7 @@ let host_port : (string * int) Arg.converter = let socket = let doc = "Stat socket to connect onto" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in + let sock = Vmm_core.socket_path `Stats in Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) let influx = diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 04b1a4e..ba5824e 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -237,7 +237,7 @@ let setup_log = let socket = let doc = "Socket to listen on" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "log" + "sock")) in + let sock = Vmm_core.socket_path `Log in Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) let file = diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 85c100a..af82442 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -154,6 +154,8 @@ let setup_log = $ Fmt_cli.style_renderer () $ Logs_cli.level ()) +(* TODO needs CRL as well, plus socket(s) *) + let cacert = let doc = "CA certificate" in Arg.(required & pos 0 (some file) None & info [] ~doc) diff --git a/app/vmmc.ml b/app/vmmc.ml index df61962..e300dde 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -7,52 +7,6 @@ open Vmm_core let my_version = `WV2 let my_command = 1L -(* -let process db hdr data = - let open Vmm_wire in - let open Rresult.R.Infix in - if not (version_eq hdr.version my_version) then - Logs.err (fun m -> m "unknown wire protocol version") - else - let r = - match hdr.tag with - | x when x = Client.stat_msg_tag -> - Client.decode_stat data >>= fun (ru, vmm, ifd) -> - Logs.app (fun m -> m "statistics: %a %a %a" - pp_rusage ru - Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm - Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ; - Ok () - | x when x = Client.log_msg_tag -> - Client.decode_log data >>= fun log -> - Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ; - Ok () - | x when x = Client.console_msg_tag -> - Client.decode_console data >>= fun (name, ts, msg) -> - Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ; - Ok () - | x when x = Client.info_msg_tag -> - Client.decode_info data >>= fun vms -> - List.iter (fun (name, cmd, pid, taps) -> - Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name) - cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) - vms ; - Ok () - | x when x = fail_tag -> - decode_str data >>= fun (msg, _) -> - Logs.err (fun m -> m "failed %s" msg) ; - Ok () - | x when x = success_tag -> - decode_str data >>= fun (msg, _) -> - Logs.app (fun m -> m "success %s" msg) ; - Ok () - | x -> Rresult.R.error_msgf "unknown header tag %02X" x - in - match r with - | Ok () -> () - | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg) -*) - let process fd = Vmm_lwt.read_wire fd >|= function | Error _ -> Error () @@ -76,15 +30,19 @@ let process fd = end end -let connect socket = +let socket t = function + | Some x -> x + | None -> Vmm_core.socket_path t + +let connect socket_path = let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in Lwt_unix.set_close_on_exec c ; - Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket) >|= fun () -> + Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> c -let info_ _ socket name = +let info_ _ opt_socket name = Lwt_main.run ( - connect socket >>= fun fd -> + connect (socket `Vmmd opt_socket) >>= fun fd -> let name' = Astring.String.cuts ~empty:false ~sep:"." name in let info = Vmm_wire.Vm.info my_command my_version name' in (Vmm_lwt.write_wire fd info >>= function @@ -105,8 +63,8 @@ let info_ _ socket name = ) ; `Ok () -let really_destroy socket name = - connect socket >>= fun fd -> +let really_destroy opt_socket name = + connect (socket `Vmmd opt_socket) >>= fun fd -> let cmd = Vmm_wire.Vm.destroy my_command my_version (Astring.String.cuts ~empty:false ~sep:"." name) in (Vmm_lwt.write_wire fd cmd >>= function | Ok () -> @@ -116,11 +74,11 @@ let really_destroy socket name = | Error `Exception -> Lwt.return_unit) >>= fun () -> Vmm_lwt.safe_close fd -let destroy _ socket name = - Lwt_main.run (really_destroy socket name) ; +let destroy _ opt_socket name = + Lwt_main.run (really_destroy opt_socket name) ; `Ok () -let create _ socket force name image cpuid requested_memory boot_params block_device network = +let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = let image' = match Bos.OS.File.read (Fpath.v image) with | Ok data -> data | Error (`Msg s) -> invalid_arg s @@ -132,6 +90,7 @@ let create _ socket force name image cpuid requested_memory boot_params block_de and argv = match boot_params with | [] -> None | xs -> Some xs + (* TODO we could do the compression btw *) and vmimage = `Ukvm_amd64, Cstruct.of_string image' in let vm_config = { @@ -140,10 +99,10 @@ let create _ socket force name image cpuid requested_memory boot_params block_de } in Lwt_main.run ( (if force then - really_destroy socket name + really_destroy opt_socket name else Lwt.return_unit) >>= fun () -> - connect socket >>= fun fd -> + connect (socket `Vmmd opt_socket) >>= fun fd -> let vm = Vmm_wire.Vm.create my_command my_version vm_config in (Vmm_lwt.write_wire fd vm >>= function | Error `Exception -> Lwt.return_unit @@ -154,6 +113,58 @@ let create _ socket force name image cpuid requested_memory boot_params block_de ) ; `Ok () +let console _ opt_socket name = + Lwt_main.run ( + connect (socket `Console opt_socket) >>= fun fd -> + let cmd = Vmm_wire.Console.attach my_command my_version (Astring.String.cuts ~empty:false ~sep:"." name) in + (Vmm_lwt.write_wire fd cmd >>= function + | Error `Exception -> + Logs.err (fun m -> m "couldn't write to socket") ; + Lwt.return_unit + | Ok () -> + (* now we busy read and process console output *) + let rec loop () = + Vmm_lwt.read_wire fd >>= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () + | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit + | Ok (hdr, data) -> + Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ; + if Vmm_wire.is_fail hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ; + Lwt.return_unit + else if Vmm_wire.is_reply hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; + loop () + else + let r = + let open Rresult.R.Infix in + match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with + | Some Data -> + Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) -> + Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) -> + Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ; + Ok () + | _ -> + Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)) + in + match r with + | Ok () -> loop () + | Error (`Msg msg) -> + Logs.err (fun m -> m "%s" msg) ; + Lwt.return_unit + in + loop ()) >>= fun () -> + Vmm_lwt.safe_close fd) ; + `Ok () + let help _ _ man_format cmds = function | None -> `Help (`Pager, None) | Some t when List.mem t cmds -> `Help (man_format, Some t) @@ -173,8 +184,7 @@ let setup_log = let socket = let doc = "Socket to connect to" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "vmmd" + "sock")) in - Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) + Arg.(value & opt (some string) None & info [ "s" ; "socket" ] ~doc) let force = let doc = "force VM creation." in @@ -185,7 +195,7 @@ let image = Arg.(required & pos 1 (some file) None & info [] ~doc) let vm_name = - let doc = "Name virtual machine config." in + let doc = "Name virtual machine." in Arg.(required & pos 0 (some string) None & info [] ~doc) let destroy_cmd = @@ -235,6 +245,15 @@ let create_cmd = Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), Term.info "create" ~doc ~man +let console_cmd = + let doc = "console of a VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows console output of a VMs."] + in + Term.(ret (const console $ setup_log $ socket $ vm_name)), + Term.info "console" ~doc ~man + let help_cmd = let topic = let doc = "The topic to get help on. `topics' lists the topics." in @@ -257,7 +276,7 @@ let default_cmd = Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ] +let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ; console_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/app/vmmd.ml b/app/vmmd.ml index 8202458..9b54b4b 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -61,56 +61,63 @@ let handle state out c_fd fd addr = | `Create cont -> (* data contained a write to console, we need to wait for its reply first *) Vmm_lwt.read_wire c_fd >>= function - | Ok (_, data) when Vmm_wire.is_fail hdr -> - Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; - Lwt.return_unit - | Ok (_, _) when Vmm_wire.is_reply hdr -> - (* assert hdr.id = id! *) - (* TODO slightly more tricky, since we need to "Vmm_lwt.wait_and_clear" in here *) - let await, wakeme = Lwt.wait () in - begin match cont !state await with - | Error (`Msg msg) -> - Logs.err (fun m -> m "create continuation failed %s" msg) ; - Lwt.return_unit - | Ok (state'', out, vm) -> - state := state'' ; - s := { !s with vm_created = succ !s.vm_created } ; - Lwt.async (fun () -> - Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', out' = Vmm_engine.handle_shutdown !state vm r in - s := { !s with vm_destroyed = succ !s.vm_destroyed } ; - state := state' ; - process out' >|= fun () -> - Lwt.wakeup wakeme ()) ; - process out >>= fun () -> - begin match Vmm_engine.setup_stats !state vm with - | Ok (state', out) -> - state := state' ; - process out (* TODO: need to read from stats socket! *) - | Error (`Msg e) -> - Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; - Lwt.return_unit - end + | Ok (hdr, data) -> + if Vmm_wire.is_fail hdr then begin + Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; + Lwt.return_unit + end else if Vmm_wire.is_reply hdr then begin + (* assert hdr.id = id! *) + let await, wakeme = Lwt.wait () in + begin match cont !state await with + | Error (`Msg msg) -> + Logs.err (fun m -> m "create continuation failed %s" msg) ; + Lwt.return_unit + | Ok (state'', out, vm) -> + state := state'' ; + s := { !s with vm_created = succ !s.vm_created } ; + Lwt.async (fun () -> + Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> + let state', out' = Vmm_engine.handle_shutdown !state vm r in + s := { !s with vm_destroyed = succ !s.vm_destroyed } ; + state := state' ; + process out' >|= fun () -> + Lwt.wakeup wakeme ()) ; + process out >>= fun () -> + begin match Vmm_engine.setup_stats !state vm with + | Ok (state', out) -> + state := state' ; + process out (* TODO: need to read from stats socket! *) + | Error (`Msg e) -> + Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; + Lwt.return_unit + end + end + end else begin + Logs.err (fun m -> m "reading from console %lx, %a" hdr.Vmm_wire.tag Cstruct.hexdump_pp data) ; + Lwt.return_unit end - | _ -> + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while reading from console" msg) ; + Lwt.return_unit + | Error _ -> Logs.err (fun m -> m "error while reading from console") ; - Lwt.return_unit) >>= fun () -> + Lwt.return_unit ) >>= fun () -> Vmm_lwt.safe_close fd -let init_sock dir name = +let init_sock sock = + let name = Vmm_core.socket_path sock in let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in Lwt_unix.set_close_on_exec c ; - let addr = Fpath.(dir / name + "sock") in Lwt.catch (fun () -> - Lwt_unix.(connect c (ADDR_UNIX (Fpath.to_string addr))) >|= fun () -> Some c) + Lwt_unix.(connect c (ADDR_UNIX name)) >|= fun () -> Some c) (fun e -> - Logs.warn (fun m -> m "error %s connecting to socket %a" - (Printexc.to_string e) Fpath.pp addr) ; + Logs.warn (fun m -> m "error %s connecting to socket %s" + (Printexc.to_string e) name) ; (Lwt.catch (fun () -> Lwt_unix.close c) (fun _ -> Lwt.return_unit)) >|= fun () -> None) -let create_mbox name = - init_sock Vmm_core.tmpdir name >|= function +let create_mbox sock = + init_sock sock >|= function | None -> None | Some fd -> let mvar = Lwt_mvar.create_empty () in @@ -122,19 +129,18 @@ let create_mbox name = Lwt_mvar.take mvar >>= fun data -> Vmm_lwt.write_wire fd data >>= function | Ok () -> loop () - | Error `Exception -> invalid_arg ("exception while writing to " ^ name) ; + | Error `Exception -> invalid_arg ("exception while writing to " ^ Fmt.to_to_string Vmm_core.pp_socket sock) ; in Lwt.async loop ; Some (mvar, fd) -let server_socket dir name = - let file = Fpath.(dir / name + "sock") in - let sock = Fpath.to_string file in - (Lwt_unix.file_exists sock >>= function - | true -> Lwt_unix.unlink sock +let server_socket sock = + let name = Vmm_core.socket_path sock in + (Lwt_unix.file_exists name >>= function + | true -> Lwt_unix.unlink name | false -> Lwt.return_unit) >>= fun () -> let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in - Lwt_unix.(bind s (ADDR_UNIX sock)) >|= fun () -> + Lwt_unix.(bind s (ADDR_UNIX name)) >|= fun () -> Lwt_unix.listen s 1 ; s @@ -143,15 +149,17 @@ let rec stats_loop () = Lwt_unix.sleep 600. >>= fun () -> stats_loop () +(* TODO nobody reads stat and log file descriptors - that's likely a bad idea! + - create_mbox could after take & write do a read and check for failures! *) let jump _ = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run - (server_socket Vmm_core.tmpdir "vmmd" >>= fun ss -> - (create_mbox "cons" >|= function + (server_socket `Vmmd >>= fun ss -> + (create_mbox `Console >|= function | None -> invalid_arg "cannot connect to console socket" | Some c -> c) >>= fun (c, c_fd) -> - create_mbox "stat" >>= fun s -> - (create_mbox "log" >|= function + create_mbox `Stats >>= fun s -> + (create_mbox `Log >|= function | None -> invalid_arg "cannot connect to log socket" | Some l -> l) >>= fun (l, _l_fd) -> let state = ref (Vmm_engine.init ()) in diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 54bbcbd..259b560 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -12,7 +12,7 @@ let () = (* Pkg.bin "app/vmm_client" ; *) (* Pkg.bin "app/vmm_tls_endpoint" ; *) Pkg.bin "app/vmmc" ; - Pkg.bin "provision/vmm_req_permissions" ; + Pkg.bin "provision/vmm_req_command" ; Pkg.bin "provision/vmm_req_delegation" ; Pkg.bin "provision/vmm_req_vm" ; Pkg.bin "provision/vmm_sign" ; diff --git a/provision/vmm_provision.ml b/provision/vmm_provision.ml index 9579047..0103eda 100644 --- a/provision/vmm_provision.ml +++ b/provision/vmm_provision.ml @@ -1,6 +1,6 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -let asn_version = `AV0 +let asn_version = `AV1 let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); diff --git a/provision/vmm_req_command.ml b/provision/vmm_req_command.ml new file mode 100644 index 0000000..a57d3ea --- /dev/null +++ b/provision/vmm_req_command.ml @@ -0,0 +1,62 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Vmm_provision + +open Rresult.R.Infix + +open Vmm_asn + +let cmd_csr name key command block_device block_size = + let bd = match block_device with + | None -> [] + | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ] + in + let bs = match block_size with + | None -> [] + | Some x -> [ (false, `Unsupported (Oid.memory, int_to_cstruct x)) ] + in + let exts = + [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ; + (false, `Unsupported (Oid.command, command_to_cstruct command)) ] @ bd @ bs + and name = [ `CN name ] + in + X509.CA.request name ~extensions:[`Extensions exts] key + +let jump _ name key command block_device block_size = + Nocrypto_entropy_unix.initialize () ; + match + priv_key key name >>= fun key -> + let csr = cmd_csr name key command block_device block_size in + let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in + Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc) + with + | Ok () -> `Ok () + | Error (`Msg m) -> `Error (false, m) + +open Cmdliner + +let cmd = + let parse s = + match Vmm_core.command_of_string s with + | Some x -> `Ok x + | None -> `Error "invalid command" + in + (parse, Vmm_core.pp_command) + +let command = + let doc = "command" in + Arg.(required & pos 1 (some cmd) None & info [] ~doc) + +let block_device = + let doc = "block device" in + Arg.(value & opt (some string) None & info [ "block-device" ] ~doc) + +let block_size = + let doc = "block size in MB" in + Arg.(value & opt (some int) None & info [ "block-size" ] ~doc) + +let cmd = + Term.(ret (const jump $ setup_log $ nam $ key $ command $ block_device $ block_size)), + Term.info "vmm_req_command" ~version:"%%VERSION_NUM%%" + +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/vmm_req_permissions.ml b/provision/vmm_req_permissions.ml deleted file mode 100644 index 72abcc2..0000000 --- a/provision/vmm_req_permissions.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Vmm_provision - -open Rresult.R.Infix - -open Vmm_asn - -let cmd_csr name key permissions = - let exts = - [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ; - (false, `Unsupported (Oid.permissions, permissions_to_cstruct permissions)) ] - and name = [ `CN name ] - in - X509.CA.request name ~extensions:[`Extensions exts] key - -let jump _ name key permissions = - Nocrypto_entropy_unix.initialize () ; - match - priv_key key name >>= fun key -> - let csr = cmd_csr name key permissions in - let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in - Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc) - with - | Ok () -> `Ok () - | Error (`Msg m) -> `Error (false, m) - -open Cmdliner - -let cmd = - let parse s = - match Vmm_core.permission_of_string s with - | Some x -> `Ok x - | None -> `Error "invalid permission" - in - (parse, Vmm_core.pp_permission) - -let permissions = - let doc = "permissions" in - Arg.(value & opt_all cmd [] & info [ "p" ; "permission" ] ~doc) - -let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ permissions)), - Term.info "vmm_req_permissions" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml index 512abd4..60e1273 100644 --- a/provision/vmm_req_vm.ml +++ b/provision/vmm_req_vm.ml @@ -16,7 +16,7 @@ let vm_csr key name image cpu mem args block net force compression = and net = match net with | [] -> [] | xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ] - and cmd = if force then `Force_create else `Create + and cmd = if force then `Force_create_vm else `Create_vm in let image = match compression with | 0 -> image_to_cstruct (`Ukvm_amd64, image) @@ -29,7 +29,7 @@ let vm_csr key name image cpu mem args block net force compression = (false, `Unsupported (Oid.cpuid, int_to_cstruct cpu)) ; (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ; (false, `Unsupported (Oid.vmimage, image)) ; - (false, `Unsupported (Oid.permissions, permissions_to_cstruct [ cmd ])) ; + (false, `Unsupported (Oid.command, command_to_cstruct cmd)) ; ] @ block @ arg @ net and name = [ `CN name ] in diff --git a/provision/vmm_revoke.ml b/provision/vmm_revoke.ml index 5a04e44..66239b6 100644 --- a/provision/vmm_revoke.ml +++ b/provision/vmm_revoke.ml @@ -45,7 +45,7 @@ let jump _ db cacert cakey crl cn serial = priv_key None name >>= fun key -> let csr = X509.CA.request [ `CN name ] key in let extensions = [ (false, `Unsupported (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct asn_version)) ; - (false, `Unsupported (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct [ `Crl ])) ; + (false, `Unsupported (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct `Crl)) ; (false, `Unsupported (Vmm_asn.Oid.crl, crl_cs)) ] @ l_exts in sign ~dbname:(Fpath.v db) extensions issuer cakey csr (Duration.of_hour 1) diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml index 8803ace..b425818 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -59,7 +59,7 @@ let sign dbname cacert key csr days = (match has Vmm_asn.Oid.vmimage req_exts, has Vmm_asn.Oid.vms req_exts with | true, false -> Ok `Vm | false, true -> Ok `Delegation - | false, false -> Ok `Permission + | false, false -> Ok `Command | _ -> Error (`Msg "cannot categorise signing request")) >>= (function | `Vm -> Logs.app (fun m -> m "categorised as a virtual machine request") ; @@ -160,20 +160,9 @@ let sign dbname cacert key csr days = | None -> s_exts | Some a -> (Vmm_asn.Oid.argv, Vmm_asn.strings_to_cstruct a) :: s_exts in - opt Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms -> - Logs.app (fun m -> m "using permission %a" - Fmt.(option ~none:(unit "none") - (list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ; - let perm = match perms with - | Some [ `Force_create ] -> [ `Force_create ] - | Some [ `Create ] -> [ `Create ] - | _ -> - Logs.warn (fun m -> m "weird permissions (%a), replaced with create" - Fmt.(option ~none:(unit "none") - (list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ; - [ `Create ] - in - let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perm) :: s_exts in + req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command -> + Logs.app (fun m -> m "using command %a" Vmm_core.pp_command command) ; + let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: s_exts in let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in Ok (exts @ l_exts) | `Delegation -> @@ -254,11 +243,23 @@ let sign dbname cacert key csr days = | Some (Some x) when x >= succ len -> Ok () | Some _ -> Error (`Msg "cannot delegate that deep")) >>= fun () -> Ok (exts @ d_exts ~len ()) - | `Permission -> - req Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms -> - Logs.app (fun m -> m "an interactive certificate with permissions %a" - Fmt.(list ~sep:(unit ", ") Vmm_core.pp_permission) perms) ; - let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perms) :: s_exts in + | `Command -> + req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command -> + Logs.app (fun m -> m "a leaf certificate with command %a" + Vmm_core.pp_command command) ; + let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: s_exts in + (match command with + | `Create_block | `Destroy_block -> + req Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>| fun block_device -> + Logs.app (fun m -> m "block device %s" block_device) ; + (Vmm_asn.Oid.block_device, Vmm_asn.string_to_cstruct block_device) :: s_exts + | _ -> Ok s_exts) >>= fun s_exts -> + (match command with + | `Create_block -> + req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>| fun block_size -> + Logs.app (fun m -> m "block size %dMB" block_size) ; + (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct block_size) :: s_exts + | _ -> Ok s_exts) >>= fun s_exts -> let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in Ok (exts @ l_exts)) >>= fun extensions -> sign ~dbname extensions issuer key csr (Duration.of_day days) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 099c1c0..88af92d 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -19,7 +19,7 @@ module Oid = struct let cpuids = m <| 4 (* TODO: embed host URL (well, or use common name / SubjectAlternativeName with IP, and static port?) *) - (* used in both CA and VM certs *) + (* used in both CA and VM certs, also for block_create *) let memory = m <| 5 (* used only in VM certs *) @@ -29,26 +29,29 @@ module Oid = struct let vmimage = m <| 9 let argv = m <| 10 - (* used in VM certs and other leaf certs *) - let permissions = m <| 42 + (* used in leaf certs *) + let command = m <| 42 (* used in CRL certs *) let crl = m <| 43 end -let perms : permission list Asn.t = - Asn.S.bit_string_flags [ - 0, `All ; (* no *) - 1, `Info ; - 2, `Create ; - 3, `Block ; (* create [name] [size] ; destroy [name] *) +let command : command Asn.t = + let alist = [ + 0, `Info ; + 1, `Create_vm ; + 2, `Force_create_vm ; + 3, `Destroy_vm ; 4, `Statistics ; 5, `Console ; 6, `Log ; 7, `Crl ; - 9, `Force_create ; - (* 10, `Destroy ; (* [name] *) *) + 8, `Create_block ; + 9, `Destroy_block ; ] + in + let rev = List.map (fun (k, v) -> (v, k)) alist in + Asn.S.enumerated (fun i -> List.assoc i alist) (fun k -> List.assoc k rev) open Rresult.R.Infix @@ -118,7 +121,7 @@ let image = let image_of_cstruct, image_to_cstruct = projections_of image -let permissions_of_cstruct, permissions_to_cstruct = projections_of perms +let command_of_cstruct, command_to_cstruct = projections_of command let req label cert oid f = match X509.Extension.unsupported cert oid with @@ -130,23 +133,28 @@ let opt cert oid f = | None -> Ok None | Some (_, data) -> f data >>| fun s -> Some s -type version = [ `AV0 ] +type version = [ `AV0 | `AV1 ] let version_of_int = function | 0 -> Ok `AV0 + | 1 -> Ok `AV1 | _ -> Error (`Msg "couldn't parse version") let version_to_int = function | `AV0 -> 0 + | `AV1 -> 1 let pp_version ppf v = Fmt.int ppf (match v with - | `AV0 -> 0) + | `AV0 -> 0 + | `AV1 -> 1) let version_eq a b = match a, b with | `AV0, `AV0 -> true + | `AV1, `AV1 -> true + | _ -> false let version_to_cstruct v = int_to_cstruct (version_to_int v) @@ -209,6 +217,14 @@ let vm_of_cert prefix cert = let network = match network with None -> [] | Some x -> x in Ok { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } -let permissions_of_cert version cert = +let command_of_cert version cert = version_of_cert version cert >>= fun () -> - req "permissions" cert Oid.permissions permissions_of_cstruct + req "command" cert Oid.command command_of_cstruct + +let block_device_of_cert version cert = + version_of_cert version cert >>= fun () -> + req "block-device" cert Oid.block_device string_of_cstruct + +let block_size_of_cert version cert = + version_of_cert version cert >>= fun () -> + req "block-size" cert Oid.memory int_of_cstruct diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 6c290f3..30143c9 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -62,10 +62,8 @@ module Oid : sig (** {2 OID used in administrative certificates} *) - (** [permissions] is a [BIT_STRING] denoting the permissions this certificate - has: 0 for All, 1 for Info, 2 for Image, 3 for Block, 4 for Statistics, 5 - for Console, 6 for Log. *) - val permissions : Asn.OID.t + (** [command] is a [BIT_STRING] denoting the command this certificate. *) + val command : Asn.OID.t (** [crl] is a [OCTET_STRING] denoting the revocation list of the intermediate @@ -76,7 +74,7 @@ end (** {1 Encoding and decoding functions} *) (** The type of versions of the ASN.1 grammar defined above. *) -type version = [ `AV0 ] +type version = [ `AV0 | `AV1 ] (** [version_eq a b] is true if [a] and [b] are equal. *) val version_eq : version -> version -> bool @@ -91,12 +89,12 @@ val version_to_cstruct : version -> Cstruct.t encoding [buffer] or an error. *) val version_of_cstruct : Cstruct.t -> (version, [> `Msg of string ]) result -(** [permissions_to_cstruct perms] is the DER encoded permission list. *) -val permissions_to_cstruct : Vmm_core.permission list -> Cstruct.t +(** [command_to_cstruct perms] is the DER encoded command. *) +val command_to_cstruct : Vmm_core.command -> Cstruct.t -(** [permissions_of_cstruct buffer] is either a decoded permissions list of - the DER encoded [buffer] or an error. *) -val permissions_of_cstruct : Cstruct.t -> (Vmm_core.permission list, [> `Msg of string ]) result +(** [command_of_cstruct buffer] is either a decoded command of the DER encoded + [buffer] or an error. *) +val command_of_cstruct : Cstruct.t -> (Vmm_core.command, [> `Msg of string ]) result (** [bridges_to_cstruct bridges] is the DER encoded bridges. *) val bridges_to_cstruct : Vmm_core.bridge list -> Cstruct.t @@ -157,5 +155,11 @@ val crl_of_cert : X509.t -> (X509.CRL.c, [> `Msg of string ]) result (** [delegation_of_cert version cert] is either the decoded delegation, or an error. *) val delegation_of_cert : version -> X509.t -> (Vmm_core.delegation, [> `Msg of string ]) result -(** [permissions_of_cert version cert] is either the decoded permission list, or an error. *) -val permissions_of_cert : version -> X509.t -> (Vmm_core.permission list, [> `Msg of string ]) result +(** [command_of_cert version cert] is either the decoded command, or an error. *) +val command_of_cert : version -> X509.t -> (Vmm_core.command, [> `Msg of string ]) result + +(** [block_device_of_cert version cert] is either the decoded block device, or an error. *) +val block_device_of_cert : version -> X509.t -> (string, [> `Msg of string ]) result + +(** [block_size_of_cert version cert] is either the decoded block size, or an error. *) +val block_size_of_cert : version -> X509.t -> (int, [> `Msg of string ]) result diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 74d2fcf..235c0e3 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -7,6 +7,19 @@ open Rresult.R.Infix let tmpdir = Fpath.(v "/var" / "run" / "albatross") let dbdir = Fpath.(v "/var" / "db" / "albatross") +let socket_path = + let path name = Fpath.(to_string (tmpdir / name + "sock")) in + function + | `Console -> path "console" + | `Vmmd -> path "vmmd" + | `Stats -> path "stat" + | `Log -> path "log" + +let pp_socket ppf t = + let name = socket_path t in + Fmt.pf ppf "socket: %s" name + + module I = struct type t = int let compare : int -> int -> int = compare @@ -16,77 +29,37 @@ module IS = Set.Make(I) module IM = Map.Make(I) module IM64 = Map.Make(Int64) -type permission = - [ `All | `Info | `Create | `Block | `Statistics | `Console | `Log | `Crl | `Force_create] +type command = + [ `Info | `Create_vm | `Force_create_vm | `Destroy_vm + | `Statistics | `Console | `Log | `Crl + | `Create_block | `Destroy_block ] -let pp_permission ppf = function - | `All -> Fmt.pf ppf "all" - | `Info -> Fmt.pf ppf "info" - | `Create -> Fmt.pf ppf "create" - | `Block -> Fmt.pf ppf "block" - | `Statistics -> Fmt.pf ppf "statistics" - | `Console -> Fmt.pf ppf "console" - | `Log -> Fmt.pf ppf "log" - | `Crl -> Fmt.pf ppf "crl" - | `Force_create -> Fmt.pf ppf "force-create" +let pp_command ppf cmd = + Fmt.string ppf @@ match cmd with + | `Info -> "info" + | `Create_vm -> "create-vm" + | `Force_create_vm -> "force-create-vm" + | `Destroy_vm -> "destroy-vm" + | `Statistics -> "statistics" + | `Console -> "console" + | `Log -> "log" + | `Crl -> "crl" + | `Create_block -> "create-block" + | `Destroy_block -> "destroy-block" -let permission_of_string = function - | x when x = "all" -> Some `All +let command_of_string = function | x when x = "info" -> Some `Info - | x when x = "create" -> Some `Create - | x when x = "block" -> Some `Block + | x when x = "create-vm" -> Some `Create_vm + | x when x = "force-create-vm" -> Some `Force_create_vm + | x when x = "destroy-vm" -> Some `Destroy_vm | x when x = "statistics" -> Some `Statistics | x when x = "console" -> Some `Console | x when x = "log" -> Some `Log | x when x = "crl" -> Some `Crl - | x when x = "force-create" -> Some `Force_create + | x when x = "create-block" -> Some `Create_block + | x when x = "destroy-block" -> Some `Destroy_block | _ -> None -type cmd = - | Info - | Destroy_vm - | Create_block - | Destroy_block - | Statistics - | Attach - | Detach - | Log - -let pp_cmd ppf = function - | Info -> Fmt.pf ppf "info" - | Destroy_vm -> Fmt.pf ppf "destroy" - | Create_block -> Fmt.pf ppf "create-block" - | Destroy_block -> Fmt.pf ppf "destroy-block" - | Statistics -> Fmt.pf ppf "statistics" - | Attach -> Fmt.pf ppf "attach" - | Detach -> Fmt.pf ppf "detach" - | Log -> Fmt.pf ppf "log" - -let cmd_of_string = function - | x when x = "info" -> Some Info - | x when x = "destroy" -> Some Destroy_vm - | x when x = "create-block" -> Some Create_block - | x when x = "destroy-block" -> Some Destroy_block - | x when x = "statistics" -> Some Statistics - | x when x = "attach" -> Some Attach - | x when x = "detach" -> Some Detach - | x when x = "log" -> Some Log - | _ -> None - -let cmd_allowed permissions cmd = - List.mem `All permissions || - let perm = match cmd with - | Info -> `Info - | Destroy_vm -> `Create - | Create_block -> `Block - | Destroy_block -> `Block - | Statistics -> `Statistics - | Attach -> `Console - | Detach -> `Console - | Log -> `Log - in - List.mem perm permissions - type vmtype = [ `Ukvm_amd64 | `Ukvm_arm64 | `Ukvm_amd64_compressed ] let vmtype_to_int = function diff --git a/src/vmm_ring.ml b/src/vmm_ring.ml index 55ef7e3..f49d6e7 100644 --- a/src/vmm_ring.ml +++ b/src/vmm_ring.ml @@ -19,6 +19,24 @@ let write t v = let dec t n = (pred n + t.size) mod t.size +let written (ts, _) = not (Ptime.equal ts Ptime.min) + +let read t = + let rec go s acc idx = + if idx = s then (* don't read it twice *) + acc + else + let entry = Array.get t.data idx in + if written entry then go s (entry :: acc) (dec t idx) + else acc + in + let idx = dec t t.write in + let s = + let entry = Array.get t.data idx in + if written entry then [entry] else [] + in + go idx s (dec t idx) + let earlier ts than = if ts = Ptime.min then true else Ptime.is_earlier ts ~than diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 26330bf..2c138bb 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -227,23 +227,17 @@ module Console = struct type op = | Add_console | Attach_console - | Detach_console - | History | Data (* is a reply, never acked *) let op_to_int = function | Add_console -> 0x0100l | Attach_console -> 0x0101l - | Detach_console -> 0x0102l - | History -> 0x0103l - | Data -> 0x0104l + | Data -> 0x0102l let int_to_op = function | 0x0100l -> Some Add_console | 0x0101l -> Some Attach_console - | 0x0102l -> Some Detach_console - | 0x0103l -> Some History - | 0x0104l -> Some Data + | 0x0102l -> Some Data | _ -> None let data version name ts msg = @@ -255,15 +249,11 @@ module Console = struct in encode version ~name ~body 0L (op_to_int Data) - let add id version name = encode ~name version id (op_to_int Add_console) + let add id version name = + encode ~name version id (op_to_int Add_console) - let attach id version name = encode ~name version id (op_to_int Attach_console) - - let detach id version name = encode ~name version id (op_to_int Detach_console) - - let history id version name since = - let body = encode_ptime since in - encode ~name ~body version id (op_to_int History) + let attach id version name = + encode ~name version id (op_to_int Attach_console) end module Stats = struct diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index 37657b1..b1f5445 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -1,5 +1,5 @@ -let asn_version = `AV0 +let asn_version = `AV1 let handle_single_revocation t prefix serial = let id = identifier serial in diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index 644cc62..ce12b0f 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -84,7 +84,7 @@ let setup_log = let socket = let doc = "Socket to listen on" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in + let sock = Vmm_core.socket_path `Stats in Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) let interval =