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

move stuff into vmm_commands

Browse source
This commit is contained in:
Hannes Mehnert 2018-10-24 00:03:36 +02:00
parent 6f18f1bfff
commit d513269453
19 changed files with 496 additions and 465 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
app/vmm_client.ml
View file

@ -6,7 +6,7 @@ let rec read_tls_write_cons t =
Vmm_tls.read_tls t >>= function Vmm_tls.read_tls t >>= function
| Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit
| Ok wire -> | Ok wire ->
Logs.app (fun m -> m "%a" Vmm_asn.pp_wire wire) ; Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) ;
read_tls_write_cons t read_tls_write_cons t
let client cas host port cert priv_key = let client cas host port cert priv_key =

12
app/vmm_console.ml
View file

@ -31,7 +31,7 @@ let read_console name ring channel () =
(match String.Map.find name !active with (match String.Map.find name !active with
| None -> Lwt.return_unit | None -> Lwt.return_unit
| Some fd -> | Some fd ->
let header = Vmm_asn.{ version = my_version ; sequence = 0L ; id } in let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function
| Error _ -> | Error _ ->
Vmm_lwt.safe_close fd >|= fun () -> Vmm_lwt.safe_close fd >|= fun () ->
@ -91,7 +91,7 @@ let subscribe s id =
let entries = Vmm_ring.read r 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) ->
let header = Vmm_asn.{ version = my_version ; sequence = 0L ; id } in let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >|= fun _ -> ()) Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >|= fun _ -> ())
entries >>= fun () -> entries >>= fun () ->
(match String.Map.find name !active with (match String.Map.find name !active with
@ -109,12 +109,12 @@ let handle s addr () =
Lwt.return_unit Lwt.return_unit
| Ok (header, `Command (`Console_cmd cmd)) -> | Ok (header, `Command (`Console_cmd cmd)) ->
begin begin
(if not (Vmm_asn.version_eq header.Vmm_asn.version my_version) then (if not (Vmm_commands.version_eq header.Vmm_commands.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 cmd with match cmd with
| `Console_add -> add_fifo header.Vmm_asn.id | `Console_add -> add_fifo header.Vmm_commands.id
| `Console_subscribe -> subscribe s header.Vmm_asn.id) >>= (function | `Console_subscribe -> subscribe s header.Vmm_commands.id) >>= (function
| Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg))
| 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) ;
@ -125,7 +125,7 @@ let handle s addr () =
Lwt.return_unit Lwt.return_unit
end end
| Ok wire -> | Ok wire ->
Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
loop () loop ()
in in
loop () >>= fun () -> loop () >>= fun () ->

9
app/vmm_influxdb_stats.ml
View file

@ -5,6 +5,7 @@ open Lwt.Infix
open Astring open Astring
open Vmm_core open Vmm_core
open Vmm_core.Stats
(* (*
@ -191,13 +192,13 @@ let rec read_sock_write_tcp c ?fd addr addrtype =
true true
| Ok (hdr, `Data (`Stats_data (ru, vmm, ifs))) -> | Ok (hdr, `Data (`Stats_data (ru, vmm, ifs))) ->
begin begin
if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.err (fun m -> m "unknown wire protocol version") ; Logs.err (fun m -> m "unknown wire protocol version") ;
safe_close fd >>= fun () -> safe_close fd >>= fun () ->
safe_close c >|= fun () -> safe_close c >|= fun () ->
false false
end else end else
let name = string_of_id hdr.Vmm_asn.id in let name = string_of_id hdr.Vmm_commands.id in
let ru = P.encode_ru name ru in let ru = P.encode_ru name ru in
let vmm = match vmm with None -> [] | Some xs -> [ P.encode_vmm name xs ] in let vmm = match vmm with None -> [] | Some xs -> [ P.encode_vmm name xs ] in
let taps = List.map (P.encode_if name) ifs in let taps = List.map (P.encode_if name) ifs in
@ -214,12 +215,12 @@ let rec read_sock_write_tcp c ?fd addr addrtype =
false false
end end
| Ok wire -> | Ok wire ->
Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
Lwt.return (Some fd) >>= fun fd -> Lwt.return (Some fd) >>= fun fd ->
read_sock_write_tcp c ?fd addr addrtype read_sock_write_tcp c ?fd addr addrtype
let query_sock vm c = let query_sock vm c =
let header = Vmm_asn.{ version = my_version ; sequence = !command ; id = vm } in let header = Vmm_commands.{ version = my_version ; sequence = !command ; id = vm } in
command := Int64.succ !command ; command := Int64.succ !command ;
Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id vm) ; Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id vm) ;
Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe)) Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe))

32
app/vmm_log.ml
View file

@ -55,25 +55,26 @@ let write_to_file file =
let tree = ref Vmm_trie.empty let tree = ref Vmm_trie.empty
let bcast = ref 0L
let send_history s ring id = let send_history s ring id =
let elements = Vmm_ring.read ring in let elements = Vmm_ring.read ring in
let res = let res =
List.fold_left (fun acc (_, x) -> List.fold_left (fun acc (_, x) ->
let cs = Cstruct.of_string x in let cs = Cstruct.of_string x in
match Vmm_asn.log_entry_of_cstruct cs with match Vmm_asn.log_entry_of_cstruct cs with
| Ok (header, ts, event) -> | Ok (ts, event) ->
if Vmm_core.is_sub_id ~super:id ~sub:header.Vmm_asn.id let sub = Vmm_core.Log.name event in
then (header, ts, event) :: acc if Vmm_core.is_sub_id ~super:id ~sub
then (ts, event) :: acc
else acc else acc
| _ -> acc) | _ -> acc)
[] elements [] elements
in in
(* just need a wrapper in tag = Log.Data, id = reqid *) (* just need a wrapper in tag = Log.Data, id = reqid *)
Lwt_list.fold_left_s (fun r (header, ts, event) -> Lwt_list.fold_left_s (fun r (ts, event) ->
match r with match r with
| Ok () -> Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event))) | Ok () ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event)))
| Error e -> Lwt.return (Error e)) | Error e -> Lwt.return (Error e))
(Ok ()) res (Ok ()) res
@ -90,30 +91,29 @@ let handle mvar ring s addr () =
Logs.err (fun m -> m "exception while reading") ; Logs.err (fun m -> m "exception while reading") ;
Lwt.return_unit Lwt.return_unit
| Ok (hdr, `Data (`Log_data (ts, event))) -> | Ok (hdr, `Data (`Log_data (ts, event))) ->
if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.warn (fun m -> m "unsupported version") ; Logs.warn (fun m -> m "unsupported version") ;
Lwt.return_unit Lwt.return_unit
end else begin end else begin
let data = Vmm_asn.log_entry_to_cstruct (hdr, ts, event) in let data = Vmm_asn.log_entry_to_cstruct (ts, event) in
Vmm_ring.write ring (ts, Cstruct.to_string data) ; Vmm_ring.write ring (ts, Cstruct.to_string data) ;
Lwt_mvar.put mvar data >>= fun () -> Lwt_mvar.put mvar data >>= fun () ->
let data' = let data' =
let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = hdr.Vmm_asn.id } in let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = hdr.Vmm_commands.id } in
(header, `Data (`Log_data (ts, event))) (header, `Data (`Log_data (ts, event)))
in in
bcast := Int64.succ !bcast ; broadcast hdr.Vmm_commands.id data' !tree >>= fun tree' ->
broadcast hdr.Vmm_asn.id data' !tree >>= fun tree' ->
tree := tree' ; tree := tree' ;
loop () loop ()
end end
| Ok (hdr, `Command (`Log_cmd lc)) -> | Ok (hdr, `Command (`Log_cmd lc)) ->
if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.warn (fun m -> m "unsupported version") ; Logs.warn (fun m -> m "unsupported version") ;
Lwt.return_unit Lwt.return_unit
end else begin end else begin
match lc with match lc with
| `Log_subscribe -> | `Log_subscribe ->
let tree', ret = Vmm_trie.insert hdr.Vmm_asn.id s !tree in let tree', ret = Vmm_trie.insert hdr.Vmm_commands.id s !tree in
tree := tree' ; tree := tree' ;
(match ret with (match ret with
| None -> Lwt.return_unit | None -> Lwt.return_unit
@ -124,14 +124,14 @@ let handle mvar ring s addr () =
Logs.err (fun m -> m "error while sending reply for subscribe") ; Logs.err (fun m -> m "error while sending reply for subscribe") ;
Lwt.return_unit Lwt.return_unit
| Ok () -> | Ok () ->
send_history s ring hdr.Vmm_asn.id >>= function send_history s ring hdr.Vmm_commands.id >>= function
| Error _ -> | Error _ ->
Logs.err (fun m -> m "error while sending history") ; Logs.err (fun m -> m "error while sending history") ;
Lwt.return_unit Lwt.return_unit
| Ok () -> loop () (* TODO no need to loop ;) *) | Ok () -> loop () (* TODO no need to loop ;) *)
end end
| Ok wire -> | Ok wire ->
Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
loop () loop ()
in in
loop () >>= fun () -> loop () >>= fun () ->

8
app/vmm_tls_endpoint.ml
View file

@ -44,7 +44,7 @@ let read fd tls =
Vmm_lwt.read_wire fd >>= function Vmm_lwt.read_wire fd >>= function
| Error _ -> Lwt.return (Error (`Msg "exception while reading")) | Error _ -> Lwt.return (Error (`Msg "exception while reading"))
| Ok wire -> | Ok wire ->
Logs.debug (fun m -> m "read proxying %a" Vmm_asn.pp_wire wire) ; Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire wire) ;
Vmm_tls.write_tls tls wire >>= function Vmm_tls.write_tls tls wire >>= function
| Ok () -> loop () | Ok () -> loop ()
| Error `Exception -> Lwt.return (Error (`Msg "exception")) | Error `Exception -> Lwt.return (Error (`Msg "exception"))
@ -55,7 +55,7 @@ let process fd tls =
Vmm_lwt.read_wire fd >>= function Vmm_lwt.read_wire fd >>= function
| Error _ -> Lwt.return (Error (`Msg "read error")) | Error _ -> Lwt.return (Error (`Msg "read error"))
| Ok wire -> | Ok wire ->
Logs.debug (fun m -> m "proxying %a" Vmm_asn.pp_wire wire) ; Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ;
Vmm_tls.write_tls tls wire >|= function Vmm_tls.write_tls tls wire >|= function
| Ok () -> Ok () | Ok () -> Ok ()
| Error `Exception -> Error (`Msg "exception on write") | Error `Exception -> Error (`Msg "exception on write")
@ -65,10 +65,10 @@ let handle ca (tls, addr) =
match Vmm_x509.handle addr chain with match Vmm_x509.handle addr chain with
| Error (`Msg m) -> Lwt.fail_with m | Error (`Msg m) -> Lwt.fail_with m
| Ok (name, cmd) -> | Ok (name, cmd) ->
let sock, next = Vmm_commands.handle cmd in let sock, next = Vmm_commands.endpoint cmd in
connect (Vmm_core.socket_path sock) >>= fun fd -> connect (Vmm_core.socket_path sock) >>= fun fd ->
let wire = let wire =
let header = Vmm_asn.{version = my_version ; sequence = !command ; id = name } in let header = Vmm_commands.{version = my_version ; sequence = !command ; id = name } in
command := Int64.succ !command ; command := Int64.succ !command ;
(header, `Command cmd) (header, `Command cmd)
in in

10
app/vmmc.ml
View file

@ -13,8 +13,8 @@ let process fd =
| Error _ -> | Error _ ->
Error (`Msg "read or parse error") Error (`Msg "read or parse error")
| Ok (header, reply) -> | Ok (header, reply) ->
if Vmm_asn.version_eq header.Vmm_asn.version version then begin if Vmm_commands.version_eq header.Vmm_commands.version version then begin
Logs.app (fun m -> m "%a" Vmm_asn.pp_wire (header, reply)) ; Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ;
Ok () Ok ()
end else begin end else begin
Logs.err (fun m -> m "version not equal") ; Logs.err (fun m -> m "version not equal") ;
@ -40,10 +40,10 @@ let read fd =
in in
loop () loop ()
let handle opt_socket id (cmd : Vmm_asn.wire_command) = let handle opt_socket id (cmd : Vmm_commands.t) =
let sock, next = Vmm_commands.handle cmd in let sock, next = Vmm_commands.endpoint cmd in
connect (socket sock opt_socket) >>= fun fd -> connect (socket sock opt_socket) >>= fun fd ->
let header = Vmm_asn.{ version ; sequence = 0L ; id } in let header = Vmm_commands.{ version ; sequence = 0L ; id } in
Vmm_lwt.write_wire fd (header, `Command cmd) >>= function Vmm_lwt.write_wire fd (header, `Command cmd) >>= function
| Error `Exception -> Lwt.return (Error (`Msg "couldn't write")) | Error `Exception -> Lwt.return (Error (`Msg "couldn't write"))
| Ok () -> | Ok () ->

2
app/vmmd.ml
View file

@ -29,7 +29,7 @@ let create c_fd process cont =
Logs.err (fun m -> m "error while reading from console") ; Logs.err (fun m -> m "error while reading from console") ;
Lwt.return_unit Lwt.return_unit
| Ok (header, wire) -> | Ok (header, wire) ->
if not (Vmm_asn.version_eq version header.Vmm_asn.version) then begin if not (Vmm_commands.version_eq version header.Vmm_commands.version) then begin
Logs.err (fun m -> m "invalid version while reading from console") ; Logs.err (fun m -> m "invalid version while reading from console") ;
Lwt.return_unit Lwt.return_unit
end else end else

4
provision/vmm_sign.ml
View file

@ -29,12 +29,12 @@ let sign dbname cacert key csr days =
with with
| [ (_, `Unsupported (_, v)) as ext ] -> | [ (_, `Unsupported (_, v)) as ext ] ->
Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) ->
(if Vmm_asn.version_eq version asn_version then (if Vmm_commands.version_eq version asn_version then
Ok () Ok ()
else else
Error (`Msg "unknown version in request")) >>= fun () -> Error (`Msg "unknown version in request")) >>= fun () ->
(* TODO l_exts / d_exts trouble *) (* TODO l_exts / d_exts trouble *)
Logs.app (fun m -> m "signing %a" Vmm_asn.pp_wire_command cmd) ; Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ;
Ok (ext :: l_exts) >>= fun extensions -> Ok (ext :: l_exts) >>= fun extensions ->
sign ~dbname extensions issuer key csr (Duration.of_day days) sign ~dbname extensions issuer key csr (Duration.of_day days)
| _ -> Error (`Msg "none or multiple albatross extensions found") | _ -> Error (`Msg "none or multiple albatross extensions found")

185
src/vmm_asn.ml
View file

@ -1,6 +1,7 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *) (* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_core open Vmm_core
open Vmm_commands
open Rresult open Rresult
open Astring open Astring
@ -86,32 +87,6 @@ let image =
(explicit 1 octet_string) (explicit 1 octet_string)
(explicit 2 octet_string)) (explicit 2 octet_string))
type version = [ `AV0 | `AV1 | `AV2 ]
let pp_version ppf v =
Fmt.int ppf
(match v with
| `AV0 -> 0
| `AV1 -> 1
| `AV2 -> 2)
let version_eq a b =
match a, b with
| `AV0, `AV0 -> true
| `AV1, `AV1 -> true
| `AV2, `AV2 -> true
| _ -> false
(* communication protocol *)
type console_cmd = [
| `Console_add
| `Console_subscribe
]
let pp_console_cmd ppf = function
| `Console_add -> Fmt.string ppf "console add"
| `Console_subscribe -> Fmt.string ppf "console subscribe"
let console_cmd = let console_cmd =
let f = function let f = function
| `C1 () -> `Console_add | `C1 () -> `Console_add
@ -141,6 +116,7 @@ let timeval =
(required ~label:"microseconds" int)) (required ~label:"microseconds" int))
let ru = let ru =
let open Stats in
let f (utime, (stime, (maxrss, (ixrss, (idrss, (isrss, (minflt, (majflt, (nswap, (inblock, (outblock, (msgsnd, (msgrcv, (nsignals, (nvcsw, nivcsw))))))))))))))) = let f (utime, (stime, (maxrss, (ixrss, (idrss, (isrss, (minflt, (majflt, (nswap, (inblock, (outblock, (msgsnd, (msgrcv, (nsignals, (nvcsw, nivcsw))))))))))))))) =
{ utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ; nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw } { utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ; nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw }
and g ru = and g ru =
@ -173,6 +149,7 @@ let int32 =
Asn.S.map f g Asn.S.int Asn.S.map f g Asn.S.int
let ifdata = let ifdata =
let open Stats in
let f (name, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) = let f (name, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) =
{ name; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped } { name; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped }
and g i = and g i =
@ -199,17 +176,6 @@ let ifdata =
@ (required ~label:"input_dropped" int64) @ (required ~label:"input_dropped" int64)
-@ (required ~label:"output_dropped" int64)) -@ (required ~label:"output_dropped" int64))
type stats_cmd = [
| `Stats_add of int * string list
| `Stats_remove
| `Stats_subscribe
]
let pp_stats_cmd ppf = function
| `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps
| `Stats_remove -> Fmt.string ppf "stat remove"
| `Stats_subscribe -> Fmt.string ppf "stat subscribe"
let stats_cmd = let stats_cmd =
let f = function let f = function
| `C1 (pid, taps) -> `Stats_add (pid, taps) | `C1 (pid, taps) -> `Stats_add (pid, taps)
@ -228,60 +194,56 @@ let stats_cmd =
(explicit 1 null) (explicit 1 null)
(explicit 2 null)) (explicit 2 null))
let addr =
Asn.S.(sequence2
(required ~label:"ip" ipv4)
(required ~label:"port" int))
let log_event = let log_event =
let f = function let f = function
| `C1 () -> `Startup | `C1 () -> `Startup
| `C2 (ip, port) -> `Login (ip, port) | `C2 (name, ip, port) -> `Login (name, ip, port)
| `C3 (ip, port) -> `Logout (ip, port) | `C3 (name, ip, port) -> `Logout (name, ip, port)
| `C4 (pid, taps, block) -> `VM_start (pid, taps, block) | `C4 (name, pid, taps, block) -> `Vm_start (name, pid, taps, block)
| `C5 (pid, status) -> | `C5 (name, pid, status) ->
let status' = match status with let status' = match status with
| `C1 n -> `Exit n | `C1 n -> `Exit n
| `C2 n -> `Signal n | `C2 n -> `Signal n
| `C3 n -> `Stop n | `C3 n -> `Stop n
in in
`VM_stop (pid, status') `Vm_stop (name, pid, status')
and g = function and g = function
| `Startup -> `C1 () | `Startup -> `C1 ()
| `Login (ip, port) -> `C2 (ip, port) | `Login (name, ip, port) -> `C2 (name, ip, port)
| `Logout (ip, port) -> `C3 (ip, port) | `Logout (name, ip, port) -> `C3 (name, ip, port)
| `VM_start (pid, taps, block) -> `C4 (pid, taps, block) | `Vm_start (name, pid, taps, block) -> `C4 (name, pid, taps, block)
| `VM_stop (pid, status) -> | `Vm_stop (name, pid, status) ->
let status' = match status with let status' = match status with
| `Exit n -> `C1 n | `Exit n -> `C1 n
| `Signal n -> `C2 n | `Signal n -> `C2 n
| `Stop n -> `C3 n | `Stop n -> `C3 n
in in
`C5 (pid, status') `C5 (name, pid, status')
in
let endp =
Asn.S.(sequence3
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"ip" ipv4)
(required ~label:"port" int))
in in
Asn.S.map f g @@ Asn.S.map f g @@
Asn.S.(choice5 Asn.S.(choice5
(explicit 0 null) (explicit 0 null)
(explicit 1 addr) (explicit 1 endp)
(explicit 2 addr) (explicit 2 endp)
(explicit 3 (sequence3 (explicit 3 (sequence4
(required ~label:"pid" int) (required ~label:"name" (sequence_of utf8_string))
(required ~label:"taps" (sequence_of utf8_string)) (required ~label:"pid" int)
(optional ~label:"block" utf8_string))) (required ~label:"taps" (sequence_of utf8_string))
(explicit 4 (sequence2 (optional ~label:"block" utf8_string)))
(explicit 4 (sequence3
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"pid" int) (required ~label:"pid" int)
(required ~label:"status" (choice3 (required ~label:"status" (choice3
(explicit 0 int) (explicit 0 int)
(explicit 1 int) (explicit 1 int)
(explicit 2 int)))))) (explicit 2 int))))))
type log_cmd = [
| `Log_subscribe
]
let pp_log_cmd ppf = function
| `Log_subscribe -> Fmt.string ppf "log subscribe"
let log_cmd = let log_cmd =
let f = function let f = function
| () -> `Log_subscribe | () -> `Log_subscribe
@ -291,19 +253,6 @@ let log_cmd =
Asn.S.map f g @@ Asn.S.map f g @@
Asn.S.null Asn.S.null
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_destroy
]
let pp_vm_cmd ppf = function
| `Vm_info -> Fmt.string ppf "vm info"
| `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config
| `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config
| `Vm_destroy -> Fmt.string ppf "vm destroy"
let vm_config = let vm_config =
let f (cpuid, requested_memory, block_device, network, vmimage, argv) = let f (cpuid, requested_memory, block_device, network, vmimage, argv) =
let network = match network with None -> [] | Some xs -> xs in let network = match network with None -> [] | Some xs -> xs in
@ -340,17 +289,6 @@ let vm_cmd =
(explicit 2 vm_config) (explicit 2 vm_config)
(explicit 3 null)) (explicit 3 null))
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_remove
]
let pp_policy_cmd ppf = function
| `Policy_info -> Fmt.string ppf "policy info"
| `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy
| `Policy_remove -> Fmt.string ppf "policy remove"
let policy_cmd = let policy_cmd =
let f = function let f = function
| `C1 () -> `Policy_info | `C1 () -> `Policy_info
@ -380,22 +318,7 @@ let version =
in in
Asn.S.map f g Asn.S.int Asn.S.map f g Asn.S.int
type wire_command = [ let wire_command =
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd
]
let pp_wire_command ppf = function
| `Console_cmd c -> pp_console_cmd ppf c
| `Stats_cmd s -> pp_stats_cmd ppf s
| `Log_cmd l -> pp_log_cmd ppf l
| `Vm_cmd v -> pp_vm_cmd ppf v
| `Policy_cmd p -> pp_policy_cmd ppf p
let wire_command : wire_command Asn.S.t =
let f = function let f = function
| `C1 console -> `Console_cmd console | `C1 console -> `Console_cmd console
| `C2 stats -> `Stats_cmd stats | `C2 stats -> `Stats_cmd stats
@ -417,18 +340,6 @@ let wire_command : wire_command Asn.S.t =
(explicit 3 vm_cmd) (explicit 3 vm_cmd)
(explicit 4 policy_cmd)) (explicit 4 policy_cmd))
type data = [
| `Console_data of Ptime.t * string
| `Stats_data of stats
| `Log_data of Ptime.t * Log.event
]
let pp_data ppf = function
| `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s"
(Ptime.pp_rfc3339 ()) ts line
| `Stats_data stats -> Fmt.pf ppf "stats data: %a" pp_stats stats
| `Log_data (ts, event) -> Fmt.pf ppf "log data: %a %a" (Ptime.pp_rfc3339 ()) ts Log.pp_event event
let data = let data =
let f = function let f = function
| `C1 (timestamp, data) -> `Console_data (timestamp, data) | `C1 (timestamp, data) -> `Console_data (timestamp, data)
@ -455,13 +366,6 @@ let data =
(required ~label:"timestamp" utc_time) (required ~label:"timestamp" utc_time)
(required ~label:"event" log_event)))) (required ~label:"event" log_event))))
type header = {
version : version ;
sequence : int64 ;
id : id ;
}
let header = let header =
let f (version, sequence, id) = { version ; sequence ; id } let f (version, sequence, id) = { version ; sequence ; id }
and g h = h.version, h.sequence, h.id and g h = h.version, h.sequence, h.id
@ -472,28 +376,6 @@ let header =
(required ~label:"sequence" int64) (required ~label:"sequence" int64)
(required ~label:"id" (sequence_of utf8_string))) (required ~label:"id" (sequence_of utf8_string)))
type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
let pp_success ppf = function
| `Empty -> Fmt.string ppf "success"
| `String data -> Fmt.pf ppf "success: %s" data
| `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
type wire = header * [
| `Command of wire_command
| `Success of success
| `Failure of string
| `Data of data ]
let pp_wire ppf (header, data) =
let id = header.id in
match data with
| `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp_wire_command c
| `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f
| `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s
| `Data d -> pp_data ppf d
let wire = let wire =
let f (header, payload) = let f (header, payload) =
header, header,
@ -544,19 +426,16 @@ let wire =
(explicit 2 utf8_string) (explicit 2 utf8_string)
(explicit 3 data)))) (explicit 3 data))))
let wire_of_cstruct, wire_to_cstruct = projections_of wire let wire_of_cstruct, (wire_to_cstruct : Vmm_commands.wire -> Cstruct.t) = projections_of wire
type log_entry = header * Ptime.t * Log.event
let log_entry = let log_entry =
Asn.S.(sequence3 Asn.S.(sequence2
(required ~label:"headet" header)
(required ~label:"timestamp" utc_time) (required ~label:"timestamp" utc_time)
(required ~label:"event" log_event)) (required ~label:"event" log_event))
let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry
type cert_extension = version * wire_command type cert_extension = version * t
let cert_extension = let cert_extension =
Asn.S.(sequence2 Asn.S.(sequence2

85
src/vmm_asn.mli
View file

@ -9,89 +9,18 @@ open Vmm_core
(** OID in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.43) *) (** OID in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.43) *)
val oid : Asn.OID.t val oid : Asn.OID.t
(** {1 Encoding and decoding functions} *) val wire_to_cstruct : Vmm_commands.wire -> Cstruct.t
(** The type of versions of the ASN.1 grammar defined above. *) val wire_of_cstruct : Cstruct.t -> (Vmm_commands.wire, [> `Msg of string ]) result
type version = [ `AV0 | `AV1 | `AV2 ]
(** [version_eq a b] is true if [a] and [b] are equal. *) val log_entry_to_cstruct : Log.t -> Cstruct.t
val version_eq : version -> version -> bool
(** [pp_version ppf version] pretty prints [version] onto [ppf]. *) val log_entry_of_cstruct : Cstruct.t -> (Log.t, [> `Msg of string ]) result
val pp_version : version Fmt.t
type console_cmd = [ type cert_extension = Vmm_commands.version * Vmm_commands.t
| `Console_add
| `Console_subscribe
]
type stats_cmd = [
| `Stats_add of int * string list
| `Stats_remove
| `Stats_subscribe
]
type log_cmd = [
| `Log_subscribe
]
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_destroy
]
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_remove
]
type wire_command = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd ]
val pp_wire_command : wire_command Fmt.t
type data = [
| `Console_data of Ptime.t * string
| `Stats_data of stats
| `Log_data of Ptime.t * Log.event
]
val pp_data : data Fmt.t
type header = {
version : version ;
sequence : int64 ;
id : id ;
}
type wire = header * [
| `Command of wire_command
| `Success of [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
| `Failure of string
| `Data of data ]
val pp_wire : wire Fmt.t
val wire_to_cstruct : wire -> Cstruct.t
val wire_of_cstruct : Cstruct.t -> (wire, [> `Msg of string ]) result
type log_entry = header * Ptime.t * Log.event
val log_entry_to_cstruct : log_entry -> Cstruct.t
val log_entry_of_cstruct : Cstruct.t -> (log_entry, [> `Msg of string ]) result
type cert_extension = version * wire_command
val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result
val cert_extension_to_cstruct : cert_extension -> Cstruct.t val cert_extension_to_cstruct : cert_extension -> Cstruct.t
val wire_command_of_cert : version -> X509.t -> (wire_command, [> `Msg of string ]) result val wire_command_of_cert : Vmm_commands.version -> X509.t ->
(Vmm_commands.t, [> `Msg of string ]) result

126
src/vmm_commands.ml
View file

@ -1,10 +1,134 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *) (* (c) 2018 Hannes Mehnert, all rights reserved *)
(* the wire protocol *)
open Vmm_core open Vmm_core
let handle = function type version = [ `AV0 | `AV1 | `AV2 ]
let pp_version ppf v =
Fmt.int ppf
(match v with
| `AV0 -> 0
| `AV1 -> 1
| `AV2 -> 2)
let version_eq a b =
match a, b with
| `AV0, `AV0 -> true
| `AV1, `AV1 -> true
| `AV2, `AV2 -> true
| _ -> false
type console_cmd = [
| `Console_add
| `Console_subscribe
]
let pp_console_cmd ppf = function
| `Console_add -> Fmt.string ppf "console add"
| `Console_subscribe -> Fmt.string ppf "console subscribe"
type stats_cmd = [
| `Stats_add of int * string list
| `Stats_remove
| `Stats_subscribe
]
let pp_stats_cmd ppf = function
| `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps
| `Stats_remove -> Fmt.string ppf "stat remove"
| `Stats_subscribe -> Fmt.string ppf "stat subscribe"
type log_cmd = [
| `Log_subscribe
]
let pp_log_cmd ppf = function
| `Log_subscribe -> Fmt.string ppf "log subscribe"
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_destroy
]
let pp_vm_cmd ppf = function
| `Vm_info -> Fmt.string ppf "vm info"
| `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config
| `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config
| `Vm_destroy -> Fmt.string ppf "vm destroy"
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_remove
]
let pp_policy_cmd ppf = function
| `Policy_info -> Fmt.string ppf "policy info"
| `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy
| `Policy_remove -> Fmt.string ppf "policy remove"
type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd
]
let pp ppf = function
| `Console_cmd c -> pp_console_cmd ppf c
| `Stats_cmd s -> pp_stats_cmd ppf s
| `Log_cmd l -> pp_log_cmd ppf l
| `Vm_cmd v -> pp_vm_cmd ppf v
| `Policy_cmd p -> pp_policy_cmd ppf p
type data = [
| `Console_data of Ptime.t * string
| `Stats_data of Stats.t
| `Log_data of Log.t
]
let pp_data ppf = function
| `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s"
(Ptime.pp_rfc3339 ()) ts line
| `Stats_data stats -> Fmt.pf ppf "stats data: %a" Stats.pp stats
| `Log_data log -> Fmt.pf ppf "log data: %a" Log.pp log
type header = {
version : version ;
sequence : int64 ;
id : id ;
}
type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
let pp_success ppf = function
| `Empty -> Fmt.string ppf "success"
| `String data -> Fmt.pf ppf "success: %s" data
| `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
type wire = header * [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data ]
let pp_wire ppf (header, data) =
let id = header.id in
match data with
| `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp c
| `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f
| `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s
| `Data d -> pp_data ppf d
let endpoint = function
| `Vm_cmd _ -> `Vmmd, `End | `Vm_cmd _ -> `Vmmd, `End
| `Policy_cmd _ -> `Vmmd, `End | `Policy_cmd _ -> `Vmmd, `End
| `Stats_cmd _ -> `Stats, `Read | `Stats_cmd _ -> `Stats, `Read
| `Console_cmd _ -> `Console, `Read | `Console_cmd _ -> `Console, `Read
| `Log_cmd _ -> `Log, `Read | `Log_cmd _ -> `Log, `Read

85
src/vmm_commands.mli
View file

@ -1,7 +1,78 @@
val handle : open Vmm_core
[< `Console_cmd of 'a
| `Log_cmd of 'b (** The type of versions of the grammar defined below. *)
| `Policy_cmd of 'c type version = [ `AV0 | `AV1 | `AV2 ]
| `Stats_cmd of 'd
| `Vm_cmd of 'e ] -> (** [version_eq a b] is true if [a] and [b] are equal. *)
[> `Console | `Log | `Stats | `Vmmd ] * [> `End | `Read ] val version_eq : version -> version -> bool
(** [pp_version ppf version] pretty prints [version] onto [ppf]. *)
val pp_version : version Fmt.t
type console_cmd = [
| `Console_add
| `Console_subscribe
]
type stats_cmd = [
| `Stats_add of int * string list
| `Stats_remove
| `Stats_subscribe
]
type log_cmd = [
| `Log_subscribe
]
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_destroy
]
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_remove
]
type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd ]
val pp : t Fmt.t
type data = [
| `Console_data of Ptime.t * string
| `Stats_data of Stats.t
| `Log_data of Log.t
]
val pp_data : data Fmt.t
type header = {
version : version ;
sequence : int64 ;
id : id ;
}
type success = [
| `Empty
| `String of string
| `Policies of (id * policy) list
| `Vms of (id * vm_config) list
]
type wire = header * [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data ]
val pp_wire : wire Fmt.t
val endpoint : t -> service * [ `End | `Read ]

166
src/vmm_core.ml
View file

@ -7,6 +7,8 @@ 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")
type service = [ `Console | `Log | `Stats | `Vmmd ]
let socket_path t = let socket_path t =
let path name = Fpath.(tmpdir / "util" / name + "sock") in let path name = Fpath.(tmpdir / "util" / name + "sock") in
let path = match t with let path = match t with
@ -185,88 +187,104 @@ let separate_chain = function
| [ leaf ] -> Ok (leaf, []) | [ leaf ] -> Ok (leaf, [])
| leaf :: xs -> Ok (leaf, List.rev xs) | leaf :: xs -> Ok (leaf, List.rev xs)
type rusage = { module Stats = struct
utime : (int64 * int) ; type rusage = {
stime : (int64 * int) ; utime : (int64 * int) ;
maxrss : int64 ; stime : (int64 * int) ;
ixrss : int64 ; maxrss : int64 ;
idrss : int64 ; ixrss : int64 ;
isrss : int64 ; idrss : int64 ;
minflt : int64 ; isrss : int64 ;
majflt : int64 ; minflt : int64 ;
nswap : int64 ; majflt : int64 ;
inblock : int64 ; nswap : int64 ;
outblock : int64 ; inblock : int64 ;
msgsnd : int64 ; outblock : int64 ;
msgrcv : int64 ; msgsnd : int64 ;
nsignals : int64 ; msgrcv : int64 ;
nvcsw : int64 ; nsignals : int64 ;
nivcsw : int64 ; nvcsw : int64 ;
} nivcsw : int64 ;
}
let pp_rusage ppf r = let pp_rusage ppf r =
Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu" Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu"
(fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw (fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw
type vmm_stats = (string * int64) list type vmm = (string * int64) list
let pp_vmm_stats ppf vmm = let pp_vmm ppf vmm =
Fmt.(list ~sep:(unit "@,") (pair ~sep:(unit ": ") string int64)) ppf vmm Fmt.(list ~sep:(unit "@,") (pair ~sep:(unit ": ") string int64)) ppf vmm
type ifdata = { type ifdata = {
name : string ; name : string ;
flags : int32 ; flags : int32 ;
send_length : int32 ; send_length : int32 ;
max_send_length : int32 ; max_send_length : int32 ;
send_drops : int32 ; send_drops : int32 ;
mtu : int32 ; mtu : int32 ;
baudrate : int64 ; baudrate : int64 ;
input_packets : int64 ; input_packets : int64 ;
input_errors : int64 ; input_errors : int64 ;
output_packets : int64 ; output_packets : int64 ;
output_errors : int64 ; output_errors : int64 ;
collisions : int64 ; collisions : int64 ;
input_bytes : int64 ; input_bytes : int64 ;
output_bytes : int64 ; output_bytes : int64 ;
input_mcast : int64 ; input_mcast : int64 ;
output_mcast : int64 ; output_mcast : int64 ;
input_dropped : int64 ; input_dropped : int64 ;
output_dropped : int64 ; output_dropped : int64 ;
} }
let pp_ifdata ppf i = let pp_ifdata ppf i =
Fmt.pf ppf "name %s flags %lX send_length %lu max_send_length %lu send_drops %lu mtu %lu baudrate %Lu input_packets %Lu input_errors %Lu output_packets %Lu output_errors %Lu collisions %Lu input_bytes %Lu output_bytes %Lu input_mcast %Lu output_mcast %Lu input_dropped %Lu output_dropped %Lu" Fmt.pf ppf "name %s flags %lX send_length %lu max_send_length %lu send_drops %lu mtu %lu baudrate %Lu input_packets %Lu input_errors %Lu output_packets %Lu output_errors %Lu collisions %Lu input_bytes %Lu output_bytes %Lu input_mcast %Lu output_mcast %Lu input_dropped %Lu output_dropped %Lu"
i.name i.flags i.send_length i.max_send_length i.send_drops i.mtu i.baudrate i.input_packets i.input_errors i.output_packets i.output_errors i.collisions i.input_bytes i.output_bytes i.input_mcast i.output_mcast i.input_dropped i.output_dropped i.name i.flags i.send_length i.max_send_length i.send_drops i.mtu i.baudrate i.input_packets i.input_errors i.output_packets i.output_errors i.collisions i.input_bytes i.output_bytes i.input_mcast i.output_mcast i.input_dropped i.output_dropped
type stats = rusage * vmm_stats option * ifdata list type t = rusage * vmm option * ifdata list
let pp_stats ppf (ru, vmm, ifs) = let pp ppf (ru, vmm, ifs) =
Fmt.pf ppf "%a@.%a@.%a" Fmt.pf ppf "%a@.%a@.%a"
pp_rusage ru pp_rusage ru
Fmt.(option ~none:(unit "no vmm stats") pp_vmm_stats) vmm Fmt.(option ~none:(unit "no vmm stats") pp_vmm) vmm
Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs
end
type process_exit = [ `Exit of int | `Signal of int | `Stop of int ]
let pp_process_exit ppf = function
| `Exit n -> Fmt.pf ppf "exit %a (%d)" Fmt.Dump.signal n n
| `Signal n -> Fmt.pf ppf "signal %a (%d)" Fmt.Dump.signal n n
| `Stop n -> Fmt.pf ppf "stop %a (%d)" Fmt.Dump.signal n n
module Log = struct module Log = struct
type event = type log_event = [
[ `Startup | `Login of id * Ipaddr.V4.t * int
| `Login of Ipaddr.V4.t * int | `Logout of id * Ipaddr.V4.t * int
| `Logout of Ipaddr.V4.t * int | `Startup
| `VM_start of int * string list * string option | `Vm_start of id * int * string list * string option
| `VM_stop of int * [ `Exit of int | `Signal of int | `Stop of int ] | `Vm_stop of id * int * process_exit
] ]
let pp_event ppf = function let name = function
| `Startup -> Fmt.(pf ppf "STARTUP") | `Startup -> []
| `Login (ip, port) -> Fmt.pf ppf "LOGIN %a:%d" Ipaddr.V4.pp_hum ip port | `Login (name, _, _) -> name
| `Logout (ip, port) -> Fmt.pf ppf "LOGOUT %a:%d" Ipaddr.V4.pp_hum ip port | `Logout (name, _, _) -> name
| `VM_start (pid, taps, block) -> | `Vm_start (name, _, _ ,_) -> name
Fmt.pf ppf "STARTED %d (tap %a, block %a)" | `Vm_stop (name, _, _) -> name
pid Fmt.(list ~sep:(unit "; ") string) taps
let pp_log_event ppf = function
| `Startup -> Fmt.(pf ppf "startup")
| `Login (name, ip, port) -> Fmt.pf ppf "%a login %a:%d" pp_id name Ipaddr.V4.pp_hum ip port
| `Logout (name, ip, port) -> Fmt.pf ppf "%a logout %a:%d" pp_id name Ipaddr.V4.pp_hum ip port
| `Vm_start (name, pid, taps, block) ->
Fmt.pf ppf "%a started %d (tap %a, block %a)"
pp_id name pid Fmt.(list ~sep:(unit "; ") string) taps
Fmt.(option ~none:(unit "no") string) block Fmt.(option ~none:(unit "no") string) block
| `VM_stop (pid, code) -> | `Vm_stop (name, pid, code) ->
let s, c = match code with Fmt.pf ppf "%a stopped %d with %a" pp_id name pid pp_process_exit code
| `Exit n -> "exit", n
| `Signal n -> "signal", n type t = Ptime.t * log_event
| `Stop n -> "stop", n
in let pp ppf (ts, ev) =
Fmt.pf ppf "STOPPED %d with %s %a" pid s Fmt.Dump.signal c Fmt.pf ppf "%a: %a" (Ptime.pp_rfc3339 ()) ts pp_log_event ev
end end

142
src/vmm_core.mli
View file

@ -1,8 +1,11 @@
val tmpdir : Fpath.t val tmpdir : Fpath.t
val dbdir : Fpath.t val dbdir : Fpath.t
val socket_path : [< `Console | `Log | `Stats | `Vmmd ] -> string
val pp_socket : type service = [ `Console | `Log | `Stats | `Vmmd ]
Format.formatter -> [< `Console | `Log | `Stats | `Vmmd ] -> unit
val socket_path : service -> string
val pp_socket : service Fmt.t
module I : sig type t = int val compare : int -> int -> int end module I : sig type t = int val compare : int -> int -> int end
module IS : sig module IS : sig
@ -14,9 +17,6 @@ module IM : sig
include Map.S with type key = I.t include Map.S with type key = I.t
end end
type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
val pp_vmtype : vmtype Fmt.t
type id = string list type id = string list
val string_of_id : string list -> string val string_of_id : string list -> string
val id_of_string : string -> string list val id_of_string : string -> string list
@ -45,6 +45,9 @@ val sub_block : 'a option -> 'a option -> bool
val sub_cpu : IS.t -> IS.t -> bool val sub_cpu : IS.t -> IS.t -> bool
val is_sub : super:policy -> sub:policy -> bool val is_sub : super:policy -> sub:policy -> bool
type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
val pp_vmtype : vmtype Fmt.t
type vm_config = { type vm_config = {
cpuid : int; cpuid : int;
requested_memory : int; requested_memory : int;
@ -79,68 +82,73 @@ val name : X509.t -> string
val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result
type rusage = { module Stats : sig
utime : int64 * int; type rusage = {
stime : int64 * int; utime : int64 * int;
maxrss : int64; stime : int64 * int;
ixrss : int64; maxrss : int64;
idrss : int64; ixrss : int64;
isrss : int64; idrss : int64;
minflt : int64; isrss : int64;
majflt : int64; minflt : int64;
nswap : int64; majflt : int64;
inblock : int64; nswap : int64;
outblock : int64; inblock : int64;
msgsnd : int64; outblock : int64;
msgrcv : int64; msgsnd : int64;
nsignals : int64; msgrcv : int64;
nvcsw : int64; nsignals : int64;
nivcsw : int64; nvcsw : int64;
} nivcsw : int64;
val pp_rusage : rusage Fmt.t }
val pp_rusage : rusage Fmt.t
type vmm_stats = (string * int64) list type vmm = (string * int64) list
val pp_vmm_stats : vmm_stats Fmt.t val pp_vmm : vmm Fmt.t
type ifdata = { type ifdata = {
name : string; name : string;
flags : int32; flags : int32;
send_length : int32; send_length : int32;
max_send_length : int32; max_send_length : int32;
send_drops : int32; send_drops : int32;
mtu : int32; mtu : int32;
baudrate : int64; baudrate : int64;
input_packets : int64; input_packets : int64;
input_errors : int64; input_errors : int64;
output_packets : int64; output_packets : int64;
output_errors : int64; output_errors : int64;
collisions : int64; collisions : int64;
input_bytes : int64; input_bytes : int64;
output_bytes : int64; output_bytes : int64;
input_mcast : int64; input_mcast : int64;
output_mcast : int64; output_mcast : int64;
input_dropped : int64; input_dropped : int64;
output_dropped : int64; output_dropped : int64;
} }
val pp_ifdata : ifdata Fmt.t val pp_ifdata : ifdata Fmt.t
type stats = rusage * vmm_stats option * ifdata list type t = rusage * vmm option * ifdata list
val pp_stats : stats Fmt.t val pp : t Fmt.t
end
module Log : type process_exit = [ `Exit of int | `Signal of int | `Stop of int ]
sig
type event = val pp_process_exit : process_exit Fmt.t
[ `Login of Ipaddr.V4.t * int
| `Logout of Ipaddr.V4.t * int module Log : sig
| `Startup type log_event = [
| `VM_start of int * string list * string option | `Login of id * Ipaddr.V4.t * int
| `VM_stop of int * [ `Exit of int | `Signal of int | `Stop of int ] ] | `Logout of id * Ipaddr.V4.t * int
val pp_event : | `Startup
Format.formatter -> | `Vm_start of id * int * string list * string option
[< `Login of Ipaddr.V4.t * int | `Vm_stop of id * int * process_exit ]
| `Logout of Ipaddr.V4.t * int
| `Startup val name : log_event -> id
| `VM_start of int * string list * string option
| `VM_stop of int * [< `Exit of int | `Signal of int | `Stop of int ] ] -> val pp_log_event : log_event Fmt.t
unit
end type t = Ptime.t * log_event
val pp : t Fmt.t
end

36
src/vmm_engine.ml
View file

@ -8,7 +8,7 @@ open Rresult
open R.Infix open R.Infix
type 'a t = { type 'a t = {
wire_version : Vmm_asn.version ; wire_version : Vmm_commands.version ;
console_counter : int64 ; console_counter : int64 ;
stats_counter : int64 ; stats_counter : int64 ;
log_counter : int64 ; log_counter : int64 ;
@ -26,22 +26,22 @@ let init wire_version = {
} }
type service_out = [ type service_out = [
| `Stat of Vmm_asn.wire | `Stat of Vmm_commands.wire
| `Log of Vmm_asn.wire | `Log of Vmm_commands.wire
| `Cons of Vmm_asn.wire | `Cons of Vmm_commands.wire
] ]
type out = [ service_out | `Data of Vmm_asn.wire ] type out = [ service_out | `Data of Vmm_commands.wire ]
let log t id event = let log t id event =
let data = `Log_data (Ptime_clock.now (), event) in let data = (Ptime_clock.now (), event) in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.log_counter ; id } in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; id } in
let log_counter = Int64.succ t.log_counter in let log_counter = Int64.succ t.log_counter in
Logs.debug (fun m -> m "LOG %a" Log.pp_event event) ; Logs.debug (fun m -> m "log %a" Log.pp data) ;
({ t with log_counter }, `Log (header, `Data data)) ({ t with log_counter }, `Log (header, `Data (`Log_data data)))
let handle_create t hdr vm_config = let handle_create t hdr vm_config =
let name = hdr.Vmm_asn.id in let name = hdr.Vmm_commands.id in
(match Vmm_resources.find_vm t.resources name with (match Vmm_resources.find_vm t.resources name with
| Some _ -> Error (`Msg "VM with same name is already running") | Some _ -> Error (`Msg "VM with same name is already running")
| None -> Ok ()) >>= fun () -> | None -> Ok ()) >>= fun () ->
@ -54,7 +54,7 @@ let handle_create t hdr vm_config =
Vmm_unix.prepare name vm_config >>= fun taps -> Vmm_unix.prepare name vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
let cons_out = let cons_out =
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in
(header, `Command (`Console_cmd `Console_add)) (header, `Command (`Console_cmd `Console_add))
in in
Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons_out ], Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons_out ],
@ -65,13 +65,13 @@ let handle_create t hdr vm_config =
Vmm_resources.insert_vm t.resources name vm >>= fun resources -> Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
let tasks = String.Map.add (string_of_id name) task t.tasks in let tasks = String.Map.add (string_of_id name) task t.tasks in
let t = { t with resources ; tasks } in let t = { t with resources ; tasks } in
let t, out = log t name (`VM_start (vm.pid, vm.taps, None)) in let t, out = log t name (`Vm_start (name, vm.pid, vm.taps, None)) in
let data = `Success (`String "created VM") in let data = `Success (`String "created VM") in
Ok (t, [ `Data (hdr, data) ; out ], name, vm))) Ok (t, [ `Data (hdr, data) ; out ], name, vm)))
let setup_stats t name vm = let setup_stats t name vm =
let stat_out = `Stats_add (vm.pid, vm.taps) in let stat_out = `Stats_add (vm.pid, vm.taps) in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
let t = { t with stats_counter = Int64.succ t.stats_counter } in let t = { t with stats_counter = Int64.succ t.stats_counter } in
t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ] t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ]
@ -80,10 +80,10 @@ let handle_shutdown t name vm r =
| Ok () -> () | Ok () -> ()
| Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
let resources = Vmm_resources.remove t.resources name in let resources = Vmm_resources.remove t.resources name in
let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
let tasks = String.Map.remove (string_of_id name) t.tasks in let tasks = String.Map.remove (string_of_id name) t.tasks in
let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in
let t, logout = log t name (`VM_stop (vm.pid, r)) let t, logout = log t name (`Vm_stop (name, vm.pid, r))
in in
(t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ]) (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ])
@ -96,12 +96,12 @@ let handle_command t (header, payload) =
(t, [ `Data (header, out) ], `End) (t, [ `Data (header, out) ], `End)
in in
msg_to_err ( msg_to_err (
let id = header.Vmm_asn.id in let id = header.Vmm_commands.id in
match payload with match payload with
| `Command (`Policy_cmd pc) -> | `Command (`Policy_cmd pc) ->
begin match pc with begin match pc with
| `Policy_remove -> | `Policy_remove ->
Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_asn.id) ; Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ;
let resources = Vmm_resources.remove t.resources id in let resources = Vmm_resources.remove t.resources id in
Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End) Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End)
| `Policy_add policy -> | `Policy_add policy ->
@ -179,5 +179,5 @@ let handle_command t (header, payload) =
end end
end end
| _ -> | _ ->
Logs.err (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, payload)) ; Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;
Error (`Msg "unknown command")) Error (`Msg "unknown command"))

12
src/vmm_engine.mli
View file

@ -1,20 +1,20 @@
type 'a t type 'a t
val init : Vmm_asn.version -> 'a t val init : Vmm_commands.version -> 'a t
type service_out = [ type service_out = [
| `Stat of Vmm_asn.wire | `Stat of Vmm_commands.wire
| `Log of Vmm_asn.wire | `Log of Vmm_commands.wire
| `Cons of Vmm_asn.wire | `Cons of Vmm_commands.wire
] ]
type out = [ service_out | `Data of Vmm_asn.wire ] type out = [ service_out | `Data of Vmm_commands.wire ]
val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm -> val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm ->
[ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list
val handle_command : 'a t -> Vmm_asn.wire -> val handle_command : 'a t -> Vmm_commands.wire ->
'a t * out list * 'a t * out list *
[ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result
| `End | `End

22
src/vmm_lwt.mli
View file

@ -1,16 +1,20 @@
val pp_sockaddr : Format.formatter -> Lwt_unix.sockaddr -> unit val pp_sockaddr : Format.formatter -> Lwt_unix.sockaddr -> unit
val pp_process_status : Format.formatter -> Unix.process_status -> unit val pp_process_status : Format.formatter -> Unix.process_status -> unit
val ret :
Unix.process_status -> [> `Exit of int | `Signal of int | `Stop of int ] val ret : Unix.process_status -> Vmm_core.process_exit
val waitpid : int -> (int * Lwt_unix.process_status, unit) result Lwt.t val waitpid : int -> (int * Lwt_unix.process_status, unit) result Lwt.t
val wait_and_clear :
int -> val wait_and_clear : int -> Unix.file_descr -> Vmm_core.process_exit Lwt.t
Unix.file_descr -> [> `Exit of int | `Signal of int | `Stop of int ] Lwt.t
val read_wire : val read_wire : Lwt_unix.file_descr ->
Lwt_unix.file_descr -> (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t
(Vmm_asn.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t
val write_raw : val write_raw :
Lwt_unix.file_descr -> bytes -> (unit, [> `Exception ]) result Lwt.t Lwt_unix.file_descr -> bytes -> (unit, [> `Exception ]) result Lwt.t
val write_wire : val write_wire :
Lwt_unix.file_descr -> Vmm_asn.wire -> (unit, [> `Exception ]) result Lwt.t Lwt_unix.file_descr -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t
val safe_close : Lwt_unix.file_descr -> unit Lwt.t val safe_close : Lwt_unix.file_descr -> unit Lwt.t

8
src/vmm_tls.mli
View file

@ -1,5 +1,5 @@
val read_tls : val read_tls : Tls_lwt.Unix.t ->
Tls_lwt.Unix.t -> (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t
(Vmm_asn.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t
val write_tls : val write_tls :
Tls_lwt.Unix.t -> Vmm_asn.wire -> (unit, [> `Exception ]) result Lwt.t Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t

15
stats/vmm_stats.ml
View file

@ -5,9 +5,9 @@ open Rresult.R.Infix
open Vmm_core open Vmm_core
external sysctl_rusage : int -> rusage = "vmmanage_sysctl_rusage" external sysctl_rusage : int -> Stats.rusage = "vmmanage_sysctl_rusage"
external sysctl_ifcount : unit -> int = "vmmanage_sysctl_ifcount" external sysctl_ifcount : unit -> int = "vmmanage_sysctl_ifcount"
external sysctl_ifdata : int -> ifdata = "vmmanage_sysctl_ifdata" external sysctl_ifdata : int -> Stats.ifdata = "vmmanage_sysctl_ifdata"
type vmctx type vmctx
@ -18,8 +18,6 @@ external vmmapi_stats : vmctx -> int64 list = "vmmanage_vmmapi_stats"
let my_version = `AV2 let my_version = `AV2
let bcast = ref 0L
let descr = ref [] let descr = ref []
type 'a t = { type 'a t = {
@ -119,8 +117,7 @@ let tick t =
match Vmm_core.drop_super ~super:id ~sub:vmid with match Vmm_core.drop_super ~super:id ~sub:vmid with
| None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out | None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out
| Some real_id -> | Some real_id ->
let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = real_id } in let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = real_id } in
bcast := Int64.succ !bcast ;
((socket, vmid, (header, `Data (`Stats_data stats))) :: out)) ((socket, vmid, (header, `Data (`Stats_data stats))) :: out))
out xs) out xs)
[] (Vmm_trie.all t'.vmid_pid) [] (Vmm_trie.all t'.vmid_pid)
@ -174,13 +171,13 @@ let remove_vmids t vmids =
let handle t socket (header, wire) = let handle t socket (header, wire) =
let r = let r =
if not (Vmm_asn.version_eq my_version header.Vmm_asn.version) then if not (Vmm_commands.version_eq my_version header.Vmm_commands.version) then
Error (`Msg "cannot handle version") Error (`Msg "cannot handle version")
else else
match wire with match wire with
| `Command (`Stats_cmd cmd) -> | `Command (`Stats_cmd cmd) ->
begin begin
let id = header.Vmm_asn.id in let id = header.Vmm_commands.id in
match cmd with match cmd with
| `Stats_add (pid, taps) -> | `Stats_add (pid, taps) ->
add_pid t id pid taps >>= fun t -> add_pid t id pid taps >>= fun t ->
@ -193,7 +190,7 @@ let handle t socket (header, wire) =
Ok ({ t with name_sockets }, `None, close, Some "subscribed") Ok ({ t with name_sockets }, `None, close, Some "subscribed")
end end
| _ -> | _ ->
Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, wire)) ; Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, wire)) ;
Ok (t, `None, None, None) Ok (t, `None, None, None)
in in
match r with match r with