reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

less is more, also unify default socket paths

Browse source 
and vmmc console command
This commit is contained in:
Hannes Mehnert 2018-09-19 21:16:44 +02:00
parent bd10209297
commit e7b4742964
20 changed files with 359 additions and 327 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

55
app/vmm_console.ml
View file

@ -2,12 +2,13 @@
(* the process responsible for buffering console IO *) (* the process responsible for buffering console IO *)
(* communication channel is a single unix domain socket shared between vmmd and (* communication channel is a single unix domain socket. The following commands
vmm_console. The vmmd can issue the following commands: can be issued:
- Add name --> creates a new console slurper for name - Add name (by vmmd) --> creates a new console slurper for name,
- Attach name since --> attaches console of name since counter, whenever and starts a read_console task
console output to name is reported, this will be forwarded as Data - Attach name --> attaches console of name: send existing stuff to client,
- Detach name --> detaches console *) and record the requesting socket to receive further messages. A potential
earlier subscriber to the same console is closed. *)
open Lwt.Infix 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) ; Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ;
match String.Map.find name !t with match String.Map.find name !t with
| None -> Lwt.return (Error (`Msg "not found")) | 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 -> | 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)) ; Logs.debug (fun m -> m "found %d history" (List.length entries)) ;
Lwt_list.iter_s (fun (i, v) -> Lwt_list.iter_s (fun (i, v) ->
Vmm_lwt.write_wire s (Vmm_wire.Console.data my_version name i v) >|= fun _ -> ()) let msg = Vmm_wire.Console.data my_version id i v in
entries >|= fun () -> Vmm_lwt.write_wire s msg >|= fun _ -> ())
Ok "success" 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 () = let handle s addr () =
Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr 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") ; Logs.err (fun m -> m "unexpected reply") ;
loop () loop ()
| Ok (hdr, data) -> | 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")) Lwt.return (Error (`Msg "ignoring data with bad version"))
else else
match Vmm_wire.decode_strings data with match Vmm_wire.decode_strings data with
| Error e -> Lwt.return (Error e) | 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.Add_console -> add_fifo id
| Some Vmm_wire.Console.Attach_console -> attach s 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")) | Some Vmm_wire.Console.Data -> Lwt.return (Error (`Msg "unexpected Data"))
| None -> | None -> Lwt.return (Error (`Msg "unknown command"))) >>= (function
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) | Ok msg -> Vmm_lwt.write_wire s (Vmm_wire.success ~msg my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag)
| Error (`Msg msg) -> | Error (`Msg msg) ->
Logs.err (fun m -> m "error while processing command: %s" msg) ; Logs.err (fun m -> m "error while processing command: %s" msg) ;
@ -179,7 +164,7 @@ let setup_log =
let socket = let socket =
let doc = "Socket to listen on" in 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) Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let cmd = let cmd =

2
app/vmm_influxdb_stats.ml
View file

@ -354,7 +354,7 @@ let host_port : (string * int) Arg.converter =
let socket = let socket =
let doc = "Stat socket to connect onto" in 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) Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let influx = let influx =

2
app/vmm_log.ml
View file

@ -237,7 +237,7 @@ let setup_log =
let socket = let socket =
let doc = "Socket to listen on" in 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) Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let file = let file =

2
app/vmm_tls_endpoint.ml
View file

@ -154,6 +154,8 @@ let setup_log =
$ Fmt_cli.style_renderer () $ Fmt_cli.style_renderer ()
$ Logs_cli.level ()) $ Logs_cli.level ())
(* TODO needs CRL as well, plus socket(s) *)
let cacert = let cacert =
let doc = "CA certificate" in let doc = "CA certificate" in
Arg.(required & pos 0 (some file) None & info [] ~doc) Arg.(required & pos 0 (some file) None & info [] ~doc)

141
app/vmmc.ml
View file

@ -7,52 +7,6 @@ open Vmm_core
let my_version = `WV2 let my_version = `WV2
let my_command = 1L 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 = let process fd =
Vmm_lwt.read_wire fd >|= function Vmm_lwt.read_wire fd >|= function
| Error _ -> Error () | Error _ -> Error ()
@ -76,15 +30,19 @@ let process fd =
end end
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 let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec c ; 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 c
let info_ _ socket name = let info_ _ opt_socket name =
Lwt_main.run ( 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 name' = Astring.String.cuts ~empty:false ~sep:"." name in
let info = Vmm_wire.Vm.info my_command my_version name' in let info = Vmm_wire.Vm.info my_command my_version name' in
(Vmm_lwt.write_wire fd info >>= function (Vmm_lwt.write_wire fd info >>= function
@ -105,8 +63,8 @@ let info_ _ socket name =
) ; ) ;
`Ok () `Ok ()
let really_destroy socket name = let really_destroy opt_socket name =
connect socket >>= fun fd -> 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 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 (Vmm_lwt.write_wire fd cmd >>= function
| Ok () -> | Ok () ->
@ -116,11 +74,11 @@ let really_destroy socket name =
| Error `Exception -> Lwt.return_unit) >>= fun () -> | Error `Exception -> Lwt.return_unit) >>= fun () ->
Vmm_lwt.safe_close fd Vmm_lwt.safe_close fd
let destroy _ socket name = let destroy _ opt_socket name =
Lwt_main.run (really_destroy socket name) ; Lwt_main.run (really_destroy opt_socket name) ;
`Ok () `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 let image' = match Bos.OS.File.read (Fpath.v image) with
| Ok data -> data | Ok data -> data
| Error (`Msg s) -> invalid_arg s | 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 and argv = match boot_params with
| [] -> None | [] -> None
| xs -> Some xs | xs -> Some xs
(* TODO we could do the compression btw *)
and vmimage = `Ukvm_amd64, Cstruct.of_string image' and vmimage = `Ukvm_amd64, Cstruct.of_string image'
in in
let vm_config = { let vm_config = {
@ -140,10 +99,10 @@ let create _ socket force name image cpuid requested_memory boot_params block_de
} in } in
Lwt_main.run ( Lwt_main.run (
(if force then (if force then
really_destroy socket name really_destroy opt_socket name
else else
Lwt.return_unit) >>= fun () -> 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 let vm = Vmm_wire.Vm.create my_command my_version vm_config in
(Vmm_lwt.write_wire fd vm >>= function (Vmm_lwt.write_wire fd vm >>= function
| Error `Exception -> Lwt.return_unit | Error `Exception -> Lwt.return_unit
@ -154,6 +113,58 @@ let create _ socket force name image cpuid requested_memory boot_params block_de
) ; ) ;
`Ok () `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 let help _ _ man_format cmds = function
| None -> `Help (`Pager, None) | None -> `Help (`Pager, None)
| Some t when List.mem t cmds -> `Help (man_format, Some t) | Some t when List.mem t cmds -> `Help (man_format, Some t)
@ -173,8 +184,7 @@ let setup_log =
let socket = let socket =
let doc = "Socket to connect to" in let doc = "Socket to connect to" in
let sock = Fpath.(to_string (Vmm_core.tmpdir / "vmmd" + "sock")) in Arg.(value & opt (some string) None & info [ "s" ; "socket" ] ~doc)
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let force = let force =
let doc = "force VM creation." in let doc = "force VM creation." in
@ -185,7 +195,7 @@ let image =
Arg.(required & pos 1 (some file) None & info [] ~doc) Arg.(required & pos 1 (some file) None & info [] ~doc)
let vm_name = 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) Arg.(required & pos 0 (some string) None & info [] ~doc)
let destroy_cmd = 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.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)),
Term.info "create" ~doc ~man 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 help_cmd =
let topic = let topic =
let doc = "The topic to get help on. `topics' lists the topics." in 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.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man 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 () = let () =
match Term.eval_choice default_cmd cmds match Term.eval_choice default_cmd cmds

108
app/vmmd.ml
View file

@ -61,56 +61,63 @@ let handle state out c_fd fd addr =
| `Create cont -> | `Create cont ->
(* data contained a write to console, we need to wait for its reply first *) (* data contained a write to console, we need to wait for its reply first *)
Vmm_lwt.read_wire c_fd >>= function Vmm_lwt.read_wire c_fd >>= function
| Ok (_, data) when Vmm_wire.is_fail hdr -> | Ok (hdr, data) ->
Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; if Vmm_wire.is_fail hdr then begin
Lwt.return_unit Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ;
| Ok (_, _) when Vmm_wire.is_reply hdr -> Lwt.return_unit
(* assert hdr.id = id! *) end else if Vmm_wire.is_reply hdr then begin
(* TODO slightly more tricky, since we need to "Vmm_lwt.wait_and_clear" in here *) (* assert hdr.id = id! *)
let await, wakeme = Lwt.wait () in let await, wakeme = Lwt.wait () in
begin match cont !state await with begin match cont !state await with
| Error (`Msg msg) -> | Error (`Msg msg) ->
Logs.err (fun m -> m "create continuation failed %s" msg) ; Logs.err (fun m -> m "create continuation failed %s" msg) ;
Lwt.return_unit Lwt.return_unit
| Ok (state'', out, vm) -> | Ok (state'', out, vm) ->
state := state'' ; state := state'' ;
s := { !s with vm_created = succ !s.vm_created } ; s := { !s with vm_created = succ !s.vm_created } ;
Lwt.async (fun () -> Lwt.async (fun () ->
Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> 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 let state', out' = Vmm_engine.handle_shutdown !state vm r in
s := { !s with vm_destroyed = succ !s.vm_destroyed } ; s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
state := state' ; state := state' ;
process out' >|= fun () -> process out' >|= fun () ->
Lwt.wakeup wakeme ()) ; Lwt.wakeup wakeme ()) ;
process out >>= fun () -> process out >>= fun () ->
begin match Vmm_engine.setup_stats !state vm with begin match Vmm_engine.setup_stats !state vm with
| Ok (state', out) -> | Ok (state', out) ->
state := state' ; state := state' ;
process out (* TODO: need to read from stats socket! *) process out (* TODO: need to read from stats socket! *)
| Error (`Msg e) -> | Error (`Msg e) ->
Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ;
Lwt.return_unit Lwt.return_unit
end 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 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") ; Logs.err (fun m -> m "error while reading from console") ;
Lwt.return_unit) >>= fun () -> Lwt.return_unit ) >>= fun () ->
Vmm_lwt.safe_close fd 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 let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec c ; Lwt_unix.set_close_on_exec c ;
let addr = Fpath.(dir / name + "sock") in
Lwt.catch (fun () -> 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 -> (fun e ->
Logs.warn (fun m -> m "error %s connecting to socket %a" Logs.warn (fun m -> m "error %s connecting to socket %s"
(Printexc.to_string e) Fpath.pp addr) ; (Printexc.to_string e) name) ;
(Lwt.catch (fun () -> Lwt_unix.close c) (fun _ -> Lwt.return_unit)) >|= fun () -> (Lwt.catch (fun () -> Lwt_unix.close c) (fun _ -> Lwt.return_unit)) >|= fun () ->
None) None)
let create_mbox name = let create_mbox sock =
init_sock Vmm_core.tmpdir name >|= function init_sock sock >|= function
| None -> None | None -> None
| Some fd -> | Some fd ->
let mvar = Lwt_mvar.create_empty () in let mvar = Lwt_mvar.create_empty () in
@ -122,19 +129,18 @@ let create_mbox name =
Lwt_mvar.take mvar >>= fun data -> Lwt_mvar.take mvar >>= fun data ->
Vmm_lwt.write_wire fd data >>= function Vmm_lwt.write_wire fd data >>= function
| Ok () -> loop () | 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 in
Lwt.async loop ; Lwt.async loop ;
Some (mvar, fd) Some (mvar, fd)
let server_socket dir name = let server_socket sock =
let file = Fpath.(dir / name + "sock") in let name = Vmm_core.socket_path sock in
let sock = Fpath.to_string file in (Lwt_unix.file_exists name >>= function
(Lwt_unix.file_exists sock >>= function | true -> Lwt_unix.unlink name
| true -> Lwt_unix.unlink sock
| false -> Lwt.return_unit) >>= fun () -> | false -> Lwt.return_unit) >>= fun () ->
let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in 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 ; Lwt_unix.listen s 1 ;
s s
@ -143,15 +149,17 @@ let rec stats_loop () =
Lwt_unix.sleep 600. >>= fun () -> Lwt_unix.sleep 600. >>= fun () ->
stats_loop () 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 _ = let jump _ =
Sys.(set_signal sigpipe Signal_ignore) ; Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run Lwt_main.run
(server_socket Vmm_core.tmpdir "vmmd" >>= fun ss -> (server_socket `Vmmd >>= fun ss ->
(create_mbox "cons" >|= function (create_mbox `Console >|= function
| None -> invalid_arg "cannot connect to console socket" | None -> invalid_arg "cannot connect to console socket"
| Some c -> c) >>= fun (c, c_fd) -> | Some c -> c) >>= fun (c, c_fd) ->
create_mbox "stat" >>= fun s -> create_mbox `Stats >>= fun s ->
(create_mbox "log" >|= function (create_mbox `Log >|= function
| None -> invalid_arg "cannot connect to log socket" | None -> invalid_arg "cannot connect to log socket"
| Some l -> l) >>= fun (l, _l_fd) -> | Some l -> l) >>= fun (l, _l_fd) ->
let state = ref (Vmm_engine.init ()) in let state = ref (Vmm_engine.init ()) in

2
pkg/pkg.ml
View file

@ -12,7 +12,7 @@ let () =
(* Pkg.bin "app/vmm_client" ; *) (* Pkg.bin "app/vmm_client" ; *)
(* Pkg.bin "app/vmm_tls_endpoint" ; *) (* Pkg.bin "app/vmm_tls_endpoint" ; *)
Pkg.bin "app/vmmc" ; 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_delegation" ;
Pkg.bin "provision/vmm_req_vm" ; Pkg.bin "provision/vmm_req_vm" ;
Pkg.bin "provision/vmm_sign" ; Pkg.bin "provision/vmm_sign" ;

2
provision/vmm_provision.ml
View file

@ -1,6 +1,6 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *) (* (c) 2017 Hannes Mehnert, all rights reserved *)
let asn_version = `AV0 let asn_version = `AV1
let setup_log style_renderer level = let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer (); Fmt_tty.setup_std_outputs ?style_renderer ();

62
provision/vmm_req_command.ml Normal file
View file

@ -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

46
provision/vmm_req_permissions.ml
View file

@ -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

4
provision/vmm_req_vm.ml
View file

@ -16,7 +16,7 @@ let vm_csr key name image cpu mem args block net force compression =
and net = match net with and net = match net with
| [] -> [] | [] -> []
| xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ] | 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 in
let image = match compression with let image = match compression with
| 0 -> image_to_cstruct (`Ukvm_amd64, image) | 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.cpuid, int_to_cstruct cpu)) ;
(false, `Unsupported (Oid.memory, int_to_cstruct mem)) ; (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ;
(false, `Unsupported (Oid.vmimage, image)) ; (false, `Unsupported (Oid.vmimage, image)) ;
(false, `Unsupported (Oid.permissions, permissions_to_cstruct [ cmd ])) ; (false, `Unsupported (Oid.command, command_to_cstruct cmd)) ;
] @ block @ arg @ net ] @ block @ arg @ net
and name = [ `CN name ] and name = [ `CN name ]
in in

2
provision/vmm_revoke.ml
View file

@ -45,7 +45,7 @@ let jump _ db cacert cakey crl cn serial =
priv_key None name >>= fun key -> priv_key None name >>= fun key ->
let csr = X509.CA.request [ `CN name ] key in let csr = X509.CA.request [ `CN name ] key in
let extensions = [ (false, `Unsupported (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct asn_version)) ; 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 (false, `Unsupported (Vmm_asn.Oid.crl, crl_cs)) ] @ l_exts
in in
sign ~dbname:(Fpath.v db) extensions issuer cakey csr (Duration.of_hour 1) sign ~dbname:(Fpath.v db) extensions issuer cakey csr (Duration.of_hour 1)

41
provision/vmm_sign.ml
View file

@ -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 (match has Vmm_asn.Oid.vmimage req_exts, has Vmm_asn.Oid.vms req_exts with
| true, false -> Ok `Vm | true, false -> Ok `Vm
| false, true -> Ok `Delegation | false, true -> Ok `Delegation
| false, false -> Ok `Permission | false, false -> Ok `Command
| _ -> Error (`Msg "cannot categorise signing request")) >>= (function | _ -> Error (`Msg "cannot categorise signing request")) >>= (function
| `Vm -> | `Vm ->
Logs.app (fun m -> m "categorised as a virtual machine request") ; 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 | None -> s_exts
| Some a -> (Vmm_asn.Oid.argv, Vmm_asn.strings_to_cstruct a) :: s_exts | Some a -> (Vmm_asn.Oid.argv, Vmm_asn.strings_to_cstruct a) :: s_exts
in in
opt Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms -> req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command ->
Logs.app (fun m -> m "using permission %a" Logs.app (fun m -> m "using command %a" Vmm_core.pp_command command) ;
Fmt.(option ~none:(unit "none") let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: s_exts in
(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
let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
Ok (exts @ l_exts) Ok (exts @ l_exts)
| `Delegation -> | `Delegation ->
@ -254,11 +243,23 @@ let sign dbname cacert key csr days =
| Some (Some x) when x >= succ len -> Ok () | Some (Some x) when x >= succ len -> Ok ()
| Some _ -> Error (`Msg "cannot delegate that deep")) >>= fun () -> | Some _ -> Error (`Msg "cannot delegate that deep")) >>= fun () ->
Ok (exts @ d_exts ~len ()) Ok (exts @ d_exts ~len ())
| `Permission -> | `Command ->
req Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms -> req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command ->
Logs.app (fun m -> m "an interactive certificate with permissions %a" Logs.app (fun m -> m "a leaf certificate with command %a"
Fmt.(list ~sep:(unit ", ") Vmm_core.pp_permission) perms) ; Vmm_core.pp_command command) ;
let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perms) :: s_exts in 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 let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
Ok (exts @ l_exts)) >>= fun extensions -> Ok (exts @ l_exts)) >>= fun extensions ->
sign ~dbname extensions issuer key csr (Duration.of_day days) sign ~dbname extensions issuer key csr (Duration.of_day days)

48
src/vmm_asn.ml
View file

@ -19,7 +19,7 @@ module Oid = struct
let cpuids = m <| 4 let cpuids = m <| 4
(* TODO: embed host URL (well, or use common name / SubjectAlternativeName with IP, and static port?) *) (* 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 let memory = m <| 5
(* used only in VM certs *) (* used only in VM certs *)
@ -29,26 +29,29 @@ module Oid = struct
let vmimage = m <| 9 let vmimage = m <| 9
let argv = m <| 10 let argv = m <| 10
(* used in VM certs and other leaf certs *) (* used in leaf certs *)
let permissions = m <| 42 let command = m <| 42
(* used in CRL certs *) (* used in CRL certs *)
let crl = m <| 43 let crl = m <| 43
end end
let perms : permission list Asn.t = let command : command Asn.t =
Asn.S.bit_string_flags [ let alist = [
0, `All ; (* no *) 0, `Info ;
1, `Info ; 1, `Create_vm ;
2, `Create ; 2, `Force_create_vm ;
3, `Block ; (* create [name] [size] ; destroy [name] *) 3, `Destroy_vm ;
4, `Statistics ; 4, `Statistics ;
5, `Console ; 5, `Console ;
6, `Log ; 6, `Log ;
7, `Crl ; 7, `Crl ;
9, `Force_create ; 8, `Create_block ;
(* 10, `Destroy ; (* [name] *) *) 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 open Rresult.R.Infix
@ -118,7 +121,7 @@ let image =
let image_of_cstruct, image_to_cstruct = projections_of 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 = let req label cert oid f =
match X509.Extension.unsupported cert oid with match X509.Extension.unsupported cert oid with
@ -130,23 +133,28 @@ let opt cert oid f =
| None -> Ok None | None -> Ok None
| Some (_, data) -> f data >>| fun s -> Some s | Some (_, data) -> f data >>| fun s -> Some s
type version = [ `AV0 ] type version = [ `AV0 | `AV1 ]
let version_of_int = function let version_of_int = function
| 0 -> Ok `AV0 | 0 -> Ok `AV0
| 1 -> Ok `AV1
| _ -> Error (`Msg "couldn't parse version") | _ -> Error (`Msg "couldn't parse version")
let version_to_int = function let version_to_int = function
| `AV0 -> 0 | `AV0 -> 0
| `AV1 -> 1
let pp_version ppf v = let pp_version ppf v =
Fmt.int ppf Fmt.int ppf
(match v with (match v with
| `AV0 -> 0) | `AV0 -> 0
| `AV1 -> 1)
let version_eq a b = let version_eq a b =
match a, b with match a, b with
| `AV0, `AV0 -> true | `AV0, `AV0 -> true
| `AV1, `AV1 -> true
| _ -> false
let version_to_cstruct v = int_to_cstruct (version_to_int v) 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 let network = match network with None -> [] | Some x -> x in
Ok { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } 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 () -> 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

28
src/vmm_asn.mli
View file

@ -62,10 +62,8 @@ module Oid : sig
(** {2 OID used in administrative certificates} *) (** {2 OID used in administrative certificates} *)
(** [permissions] is a [BIT_STRING] denoting the permissions this certificate (** [command] is a [BIT_STRING] denoting the command this certificate. *)
has: 0 for All, 1 for Info, 2 for Image, 3 for Block, 4 for Statistics, 5 val command : Asn.OID.t
for Console, 6 for Log. *)
val permissions : Asn.OID.t
(** [crl] is a [OCTET_STRING] denoting the revocation list of the intermediate (** [crl] is a [OCTET_STRING] denoting the revocation list of the intermediate
@ -76,7 +74,7 @@ end
(** {1 Encoding and decoding functions} *) (** {1 Encoding and decoding functions} *)
(** The type of versions of the ASN.1 grammar defined above. *) (** 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. *) (** [version_eq a b] is true if [a] and [b] are equal. *)
val version_eq : version -> version -> bool val version_eq : version -> version -> bool
@ -91,12 +89,12 @@ val version_to_cstruct : version -> Cstruct.t
encoding [buffer] or an error. *) encoding [buffer] or an error. *)
val version_of_cstruct : Cstruct.t -> (version, [> `Msg of string ]) result val version_of_cstruct : Cstruct.t -> (version, [> `Msg of string ]) result
(** [permissions_to_cstruct perms] is the DER encoded permission list. *) (** [command_to_cstruct perms] is the DER encoded command. *)
val permissions_to_cstruct : Vmm_core.permission list -> Cstruct.t val command_to_cstruct : Vmm_core.command -> Cstruct.t
(** [permissions_of_cstruct buffer] is either a decoded permissions list of (** [command_of_cstruct buffer] is either a decoded command of the DER encoded
the DER encoded [buffer] or an error. *) [buffer] or an error. *)
val permissions_of_cstruct : Cstruct.t -> (Vmm_core.permission list, [> `Msg of string ]) result val command_of_cstruct : Cstruct.t -> (Vmm_core.command, [> `Msg of string ]) result
(** [bridges_to_cstruct bridges] is the DER encoded bridges. *) (** [bridges_to_cstruct bridges] is the DER encoded bridges. *)
val bridges_to_cstruct : Vmm_core.bridge list -> Cstruct.t 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. *) (** [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 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. *) (** [command_of_cert version cert] is either the decoded command, or an error. *)
val permissions_of_cert : version -> X509.t -> (Vmm_core.permission list, [> `Msg of string ]) result 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

97
src/vmm_core.ml
View file

@ -7,6 +7,19 @@ open Rresult.R.Infix
let tmpdir = Fpath.(v "/var" / "run" / "albatross") let tmpdir = Fpath.(v "/var" / "run" / "albatross")
let dbdir = Fpath.(v "/var" / "db" / "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 module I = struct
type t = int type t = int
let compare : int -> int -> int = compare let compare : int -> int -> int = compare
@ -16,77 +29,37 @@ module IS = Set.Make(I)
module IM = Map.Make(I) module IM = Map.Make(I)
module IM64 = Map.Make(Int64) module IM64 = Map.Make(Int64)
type permission = type command =
[ `All | `Info | `Create | `Block | `Statistics | `Console | `Log | `Crl | `Force_create] [ `Info | `Create_vm | `Force_create_vm | `Destroy_vm
| `Statistics | `Console | `Log | `Crl
| `Create_block | `Destroy_block ]
let pp_permission ppf = function let pp_command ppf cmd =
| `All -> Fmt.pf ppf "all" Fmt.string ppf @@ match cmd with
| `Info -> Fmt.pf ppf "info" | `Info -> "info"
| `Create -> Fmt.pf ppf "create" | `Create_vm -> "create-vm"
| `Block -> Fmt.pf ppf "block" | `Force_create_vm -> "force-create-vm"
| `Statistics -> Fmt.pf ppf "statistics" | `Destroy_vm -> "destroy-vm"
| `Console -> Fmt.pf ppf "console" | `Statistics -> "statistics"
| `Log -> Fmt.pf ppf "log" | `Console -> "console"
| `Crl -> Fmt.pf ppf "crl" | `Log -> "log"
| `Force_create -> Fmt.pf ppf "force-create" | `Crl -> "crl"
| `Create_block -> "create-block"
| `Destroy_block -> "destroy-block"
let permission_of_string = function let command_of_string = function
| x when x = "all" -> Some `All
| x when x = "info" -> Some `Info | x when x = "info" -> Some `Info
| x when x = "create" -> Some `Create | x when x = "create-vm" -> Some `Create_vm
| x when x = "block" -> Some `Block | 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 = "statistics" -> Some `Statistics
| x when x = "console" -> Some `Console | x when x = "console" -> Some `Console
| x when x = "log" -> Some `Log | x when x = "log" -> Some `Log
| x when x = "crl" -> Some `Crl | 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 | _ -> 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 ] type vmtype = [ `Ukvm_amd64 | `Ukvm_arm64 | `Ukvm_amd64_compressed ]
let vmtype_to_int = function let vmtype_to_int = function

18
src/vmm_ring.ml
View file

@ -19,6 +19,24 @@ let write t v =
let dec t n = (pred n + t.size) mod t.size 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 = let earlier ts than =
if ts = Ptime.min then true if ts = Ptime.min then true
else Ptime.is_earlier ts ~than else Ptime.is_earlier ts ~than

22
src/vmm_wire.ml
View file

@ -227,23 +227,17 @@ module Console = struct
type op = type op =
| Add_console | Add_console
| Attach_console | Attach_console
| Detach_console
| History
| Data (* is a reply, never acked *) | Data (* is a reply, never acked *)
let op_to_int = function let op_to_int = function
| Add_console -> 0x0100l | Add_console -> 0x0100l
| Attach_console -> 0x0101l | Attach_console -> 0x0101l
| Detach_console -> 0x0102l | Data -> 0x0102l
| History -> 0x0103l
| Data -> 0x0104l
let int_to_op = function let int_to_op = function
| 0x0100l -> Some Add_console | 0x0100l -> Some Add_console
| 0x0101l -> Some Attach_console | 0x0101l -> Some Attach_console
| 0x0102l -> Some Detach_console | 0x0102l -> Some Data
| 0x0103l -> Some History
| 0x0104l -> Some Data
| _ -> None | _ -> None
let data version name ts msg = let data version name ts msg =
@ -255,15 +249,11 @@ module Console = struct
in in
encode version ~name ~body 0L (op_to_int Data) 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 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)
end end
module Stats = struct module Stats = struct

2
src/vmm_x509.ml
View file

@ -1,5 +1,5 @@
let asn_version = `AV0 let asn_version = `AV1
let handle_single_revocation t prefix serial = let handle_single_revocation t prefix serial =
let id = identifier serial in let id = identifier serial in

2
stats/vmm_stats_lwt.ml
View file

@ -84,7 +84,7 @@ let setup_log =
let socket = let socket =
let doc = "Socket to listen on" in 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) Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let interval = let interval =