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

refactor commands into vmm_commands

This commit is contained in:
Hannes Mehnert 2018-10-14 01:02:52 +02:00
parent efc043cd5c
commit bcb280aa00
7 changed files with 274 additions and 600 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
_tags
View File

@ -10,7 +10,7 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring
<app/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress)
<app/vmm_client.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
<app/vmmd.{ml,native,byte}>: package(tls.lwt)
<app/vmm_tls_endpoint.{ml,native,byte}>: package(tls.lwt)
<app/vmm_prometheus_stats.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
<provision/*>: package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt decompress)

117
app/vmm_tls_endpoint.ml
View File

@ -2,24 +2,42 @@
open Lwt.Infix
let write_tls state t data =
Vmm_tls.write_tls (fst t) data >>= function
| Ok () -> Lwt.return_unit
| Error `Exception ->
let state', out = Vmm_engine.handle_disconnect !state t in
state := state' ;
Lwt_list.iter_s (fun (s, data) -> write_raw s data) out >>= fun () ->
Tls_lwt.Unix.close (fst t)
let to_ipaddr (_, sa) = match sa with
| Lwt_unix.ADDR_UNIX _ -> invalid_arg "cannot convert unix address"
| Lwt_unix.ADDR_INET (addr, port) -> Ipaddr_unix.V4.of_inet_addr_exn addr, port
let pp_sockaddr ppf (_, sa) = match sa with
let pp_sockaddr ppf = function
| Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
| Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
(Unix.string_of_inet_addr addr) port
let connect socket_path =
let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec c ;
Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
c
let client_auth ca tls addr =
Logs.debug (fun m -> m "connection from %a" pp_sockaddr addr) ;
let authenticator =
let time = Ptime_clock.now () in
X509.Authenticator.chain_of_trust ~time (* ~crls:!state.Vmm_engine.crls *) [ca]
in
Lwt.catch
(fun () -> Tls_lwt.Unix.reneg ~authenticator tls)
(fun e ->
(match e with
| Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a))
| Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f))
| exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ;
Tls_lwt.Unix.close tls >>= fun () ->
Lwt.fail e) >>= fun () ->
(match Tls_lwt.Unix.epoch tls with
| `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
| `Error ->
Tls_lwt.Unix.close tls >>= fun () ->
Lwt.fail_with "error while getting epoch")
let handle ca (tls, addr) =
client_auth ca tls addr >>= fun chain ->
let _ = Vmm_x509.handle_initial tls addr chain ca in
Lwt.return_unit
let server_socket port =
let open Lwt_unix in
@ -30,69 +48,10 @@ let server_socket port =
listen s 10 ;
Lwt.return s
let rec read_log state s =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "reading log error %s" msg) ;
read_log state s
| Error _ ->
Logs.err (fun m -> m "exception while reading log") ;
invalid_arg "log socket communication issue"
| Ok (hdr, data) ->
let state', outs = Vmm_engine.handle_log !state hdr data in
state := state' ;
process state outs >>= fun () ->
read_log state s
let rec read_cons state s =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "reading console error %s" msg) ;
read_cons state s
| Error _ ->
Logs.err (fun m -> m "exception while reading console socket") ;
invalid_arg "console socket communication issue"
| Ok (hdr, data) ->
let state', outs = Vmm_engine.handle_cons !state hdr data in
state := state' ;
process state outs >>= fun () ->
read_cons state s
let rec read_stats state s =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "reading stats error %s" msg) ;
read_stats state s
| Error _ ->
Logs.err (fun m -> m "exception while reading stats") ;
Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
invalid_arg "stat socket communication issue"
| Ok (hdr, data) ->
let state', outs = Vmm_engine.handle_stat !state hdr data in
state := state' ;
process state outs >>= fun () ->
read_stats state s
let cmp_s (_, a) (_, b) =
let open Lwt_unix in
match a, b with
| ADDR_UNIX str, ADDR_UNIX str' -> String.compare str str' = 0
| ADDR_INET (addr, port), ADDR_INET (addr', port') ->
port = port' &&
String.compare (Unix.string_of_inet_addr addr) (Unix.string_of_inet_addr addr') = 0
| _ -> false
let jump _ cacert cert priv_key port =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run
(Nocrypto_entropy_lwt.initialize () >>= fun () ->
(init_sock Vmm_core.tmpdir "cons" >|= function
| None -> invalid_arg "cannot connect to console socket"
| Some c -> c) >>= fun c ->
init_sock Vmm_core.tmpdir "stat" >>= fun s ->
(init_sock Vmm_core.tmpdir "log" >|= function
| None -> invalid_arg "cannot connect to log socket"
| Some l -> l) >>= fun l ->
server_socket port >>= fun socket ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
X509_lwt.certs_of_pem cacert >>= (function
@ -102,16 +61,6 @@ let jump _ cacert cert priv_key port =
Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
~reneg:true ~certificates:(`Single cert) ())
in
(match Vmm_engine.init cmp_s c s l with
| Ok s -> Lwt.return s
| Error (`Msg m) -> Lwt.fail_with m) >>= fun t ->
let state = ref t in
Lwt.async (fun () -> read_cons state c) ;
(match s with
| None -> ()
| Some s -> Lwt.async (fun () -> read_stats state s)) ;
Lwt.async (fun () -> read_log state l) ;
Lwt.async stats_loop ;
let rec loop () =
Lwt.catch (fun () ->
Lwt_unix.accept socket >>= fun (fd, addr) ->
@ -123,7 +72,7 @@ let jump _ cacert cert priv_key port =
Lwt.fail exn) >>= fun t ->
Lwt.async (fun () ->
Lwt.catch
(fun () -> handle ca state t)
(fun () -> handle ca t)
(fun e ->
Logs.err (fun m -> m "error while handle() %s"
(Printexc.to_string e)) ;

395
app/vmmc.ml
View File

@ -6,31 +6,11 @@ open Astring
open Vmm_core
let my_version = `WV2
let my_command = 1L
let process fd =
Vmm_lwt.read_wire fd >|= function
| Error _ -> Error ()
| Ok (hdr, data) ->
if not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) then begin
Logs.err (fun m -> m "unknown wire protocol version") ;
Error ()
end else begin
if Vmm_wire.is_fail hdr then begin
let msg = match Vmm_wire.decode_string data with
| Ok (msg, _) -> Some msg
| Error _ -> None
in
Logs.err (fun m -> m "command failed %a" Fmt.(option ~none:(unit "") string) msg) ;
Error ()
end else if Vmm_wire.is_reply hdr && hdr.Vmm_wire.id = my_command then
Ok data
else begin
Logs.err (fun m -> m "received unexpected data") ;
Error ()
end
end
| Error (`Msg m) -> Error (`Msg m)
| Error _ -> Error (`Msg "read error")
| Ok data -> Vmm_commands.handle_reply data
let socket t = function
| Some x -> x
@ -42,97 +22,94 @@ let connect socket_path =
Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
c
let read fd f =
(* now we busy read and process 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 _ -> Lwt.return (Error (`Msg "exception while reading"))
| 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 _ -> ""
| Ok (m, _) -> m
in
Lwt.return (Error (`Msg ("operation failed " ^ msg)))
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
match f (hdr, data) with
| Ok () -> loop ()
| Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
in
loop ()
let handle opt_socket (cmd : Vmm_commands.t) f =
let sock, next, cmd = Vmm_commands.handle cmd in
connect (socket sock opt_socket) >>= fun fd ->
Vmm_lwt.write_wire fd cmd >>= function
| Error `Exception -> Lwt.return (Error (`Msg "couldn't write"))
| Ok () ->
(match next with
| `Read -> read fd f
| `End ->
process fd >|= function
| Error e -> Error e
| Ok data -> f data) >>= fun res ->
Vmm_lwt.safe_close fd >|= fun () ->
res
let jump opt_socket cmd f =
match
Lwt_main.run (handle opt_socket cmd f)
with
| Ok () -> `Ok ()
| Error (`Msg m) -> `Error (false, m)
let info_ _ opt_socket name =
Lwt_main.run (
connect (socket `Vmmd opt_socket) >>= fun fd ->
let info = Vmm_wire.Vm.info my_command my_version name in
(Vmm_lwt.write_wire fd info >>= function
| Ok () ->
(process fd >|= function
| Error () -> ()
| Ok data ->
match Vmm_wire.Vm.decode_vms data with
| Ok (vms, _) ->
List.iter (fun (id, memory, cmd, pid, taps) ->
Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a"
pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
vms
| Error (`Msg msg) ->
Logs.err (fun m -> m "error %s while decoding vms" msg))
| Error `Exception -> Lwt.return_unit) >>= fun () ->
Vmm_lwt.safe_close fd
) ;
`Ok ()
jump opt_socket (`Info name) (fun (_, data) ->
let open Rresult.R.Infix in
Vmm_wire.Vm.decode_vms data >>| fun (vms, _) ->
List.iter (fun (id, memory, cmd, pid, taps) ->
Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a"
pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
vms)
let policy _ opt_socket name =
Lwt_main.run (
connect (socket `Vmmd opt_socket) >>= fun fd ->
let policy = Vmm_wire.Vm.policy my_command my_version name in
(Vmm_lwt.write_wire fd policy >>= function
| Ok () ->
(process fd >|= function
| Error () -> ()
| Ok data ->
match Vmm_wire.Vm.decode_policies data with
| Ok (policies, _) ->
List.iter (fun (id, policy) ->
Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy))
policies
| Error (`Msg msg) ->
Logs.err (fun m -> m "error %s while decoding policies" msg))
| Error `Exception -> Lwt.return_unit) >>= fun () ->
Vmm_lwt.safe_close fd
) ;
`Ok ()
jump opt_socket (`Policy name) (fun (_, data) ->
let open Rresult.R.Infix in
Vmm_wire.Vm.decode_policies data >>| fun (policies, _) ->
List.iter (fun (id, policy) ->
Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy))
policies)
let remove_policy _ opt_socket name =
Lwt_main.run (
connect (socket `Vmmd opt_socket) >>= fun fd ->
let cmd = Vmm_wire.Vm.remove_policy my_command my_version name in
(Vmm_lwt.write_wire fd cmd >>= function
| Ok () ->
(process fd >|= function
| Error () -> ()
| Ok _ -> Logs.app (fun m -> m "removed policy"))
| Error `Exception -> Lwt.return_unit) >>= fun () ->
Vmm_lwt.safe_close fd) ;
`Ok ()
jump opt_socket (`Remove_policy name) (fun _ ->
Ok (Logs.app (fun m -> m "removed policy")))
let add_policy _ opt_socket name vms memory cpus block bridges =
Lwt_main.run (
connect (socket `Vmmd opt_socket) >>= fun fd ->
let bridges = match bridges with
| xs ->
let add m v =
let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
String.Map.add n v m
in
List.fold_left add String.Map.empty xs
and cpuids = IS.of_list cpus
in
let policy = { vms ; cpuids ; memory ; block ; bridges } in
let cmd = Vmm_wire.Vm.insert_policy my_command my_version name policy in
(Vmm_lwt.write_wire fd cmd >>= function
| Ok () ->
(process fd >|= function
| Error () -> ()
| Ok _ -> Logs.app (fun m -> m "added policy"))
| Error `Exception -> Lwt.return_unit) >>= fun () ->
Vmm_lwt.safe_close fd) ;
`Ok ()
let bridges = match bridges with
| xs ->
let add m v =
let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
String.Map.add n v m
in
List.fold_left add String.Map.empty xs
and cpuids = IS.of_list cpus
in
let policy = { vms ; cpuids ; memory ; block ; bridges } in
jump opt_socket (`Add_policy (name, policy)) (fun _ ->
Ok (Logs.app (fun m -> m "added policy")))
let destroy _ opt_socket name =
Lwt_main.run (
connect (socket `Vmmd opt_socket) >>= fun fd ->
let cmd = Vmm_wire.Vm.destroy my_command my_version name in
(Vmm_lwt.write_wire fd cmd >>= function
| Ok () ->
(process fd >|= function
| Error () -> ()
| Ok _ -> Logs.app (fun m -> m "destroyed VM"))
| Error `Exception -> Lwt.return_unit) >>= fun () ->
Vmm_lwt.safe_close fd) ;
`Ok ()
jump opt_socket (`Destroy_vm name) (fun _ ->
Ok (Logs.app (fun m -> m "destroyed VM")))
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
@ -149,177 +126,51 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc
vname = name ; cpuid ; requested_memory ; block_device ; network ;
vmimage ; argv
} in
Lwt_main.run (
connect (socket `Vmmd opt_socket) >>= fun fd ->
let vm =
if force then
Vmm_wire.Vm.force_create my_command my_version vm_config
else
Vmm_wire.Vm.create my_command my_version vm_config
in
(Vmm_lwt.write_wire fd vm >>= function
| Error `Exception -> Lwt.return_unit
| Ok () -> process fd >|= function
| Ok _ -> Logs.app (fun m -> m "successfully started VM")
| Error () -> ()) >>= fun () ->
Vmm_lwt.safe_close fd ) ;
`Ok ()
let cmd =
if force then
`Force_create_vm vm_config
else
`Create_vm vm_config
in
let succ _ = Ok (Logs.app (fun m -> m "successfully started VM")) in
jump opt_socket cmd succ
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 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 Vmm_wire.Console.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 ()
jump opt_socket (`Console name) (fun (hdr, data) ->
let open Rresult.R.Infix in
match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with
| Some Vmm_wire.Console.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)))
let stats _ opt_socket vm =
Lwt_main.run (
connect (socket `Stats opt_socket) >>= fun fd ->
let cmd = Vmm_wire.Stats.subscribe my_command my_version vm in
(Vmm_lwt.write_wire fd cmd >>= function
| Error `Exception -> Lwt.fail_with "write error"
| Ok () -> Lwt.return_unit) >>= fun () ->
(* now we busy read and process stat 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) ->
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.Stats.int_to_op hdr.Vmm_wire.tag with
| Some Vmm_wire.Stats.Data ->
Vmm_wire.decode_strings data >>= fun (id, off) ->
Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun stats ->
(Astring.String.concat ~sep:"." id, stats)
| _ ->
Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag))
in
match r with
| Ok (name, (ru, vmm, ifs)) ->
Logs.app (fun m -> m "stats %s@.%a@.%a@.%a@."
name Vmm_core.pp_rusage ru
Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm
Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ;
loop ()
| Error (`Msg msg) ->
Logs.err (fun m -> m "%s" msg) ;
Lwt.return_unit
in
loop () >>= fun () ->
Vmm_lwt.safe_close fd) ;
`Ok ()
let stats _ opt_socket name =
jump opt_socket (`Statistics name) (fun (hdr, data) ->
let open Rresult.R.Infix in
match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with
| Some Vmm_wire.Stats.Data ->
Vmm_wire.decode_strings data >>= fun (name', off) ->
Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) ->
Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@."
pp_id name' Vmm_core.pp_rusage ru
Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm
Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ;
| _ ->
Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)))
let event_log _ opt_socket vm =
Lwt_main.run (
connect (socket `Log opt_socket) >>= fun fd ->
let cmd = Vmm_wire.Log.subscribe my_command my_version vm in
(Vmm_lwt.write_wire fd cmd >>= function
| Error `Exception -> Lwt.fail_with "write error"
| Ok () -> Lwt.return_unit) >>= fun () ->
(* now we busy read and process stat 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) ->
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
begin
(match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with
| Some Vmm_wire.Log.Broadcast ->
begin match Vmm_wire.Log.decode_log_hdr data with
| Error (`Msg err) ->
Logs.warn (fun m -> m "ignoring error %s while decoding log" err) ;
| Ok (loghdr, logdata) ->
match Vmm_wire.Log.decode_event logdata with
| Error (`Msg err) ->
Logs.warn (fun m -> m "loghdr %a ignoring error %s while decoding logdata"
Vmm_core.Log.pp_hdr loghdr err)
| Ok event ->
Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event))
end
| _ ->
Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag)) ;
loop ()
end
in
loop () >>= fun () ->
Vmm_lwt.safe_close fd) ;
`Ok ()
let event_log _ opt_socket name =
jump opt_socket (`Log name) (fun (hdr, data) ->
let open Rresult.R.Infix in
match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with
| Some Vmm_wire.Log.Broadcast ->
Vmm_wire.Log.decode_log_hdr data >>= fun (loghdr, logdata) ->
Vmm_wire.Log.decode_event logdata >>| fun event ->
Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event))
| _ ->
Ok (Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag)))
let help _ _ man_format cmds = function
| None -> `Help (`Pager, None)

2
pkg/pkg.ml
View File

@ -10,7 +10,7 @@ let () =
Pkg.bin "app/vmm_console" ;
Pkg.bin "app/vmm_log" ;
(* Pkg.bin "app/vmm_client" ; *)
(* Pkg.bin "app/vmm_tls_endpoint" ; *)
Pkg.bin "app/vmm_tls_endpoint" ;
Pkg.bin "app/vmmc" ;
Pkg.bin "provision/vmm_req_command" ;
Pkg.bin "provision/vmm_req_delegation" ;

282
src/vmm_commands.ml
View File

@ -1,223 +1,71 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Astring
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Vmm_core
open Rresult
open R.Infix
let c = 0L
let ver = `WV2
let handle_command t s prefix perms hdr buf =
let res =
if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
Error (`Msg "unknown client version")
else match Vmm_wire.Client.cmd_of_int hdr.Vmm_wire.tag with
| None -> Error (`Msg "unknown command")
| Some x when cmd_allowed perms x ->
begin
Vmm_wire.decode_str buf >>= fun (buf, _l) ->
let arg = if String.length buf = 0 then prefix else prefix @ [buf] in
let vmid = string_of_id arg in
match x with
| Info ->
begin match Vmm_resources.find t.resources arg with
| None ->
Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ;
R.error_msgf "info: %s not found" buf
| Some x ->
let data =
Vmm_resources.fold (fun acc vm ->
acc ^ Vmm_wire.Client.encode_vm vm.config.vname vm)
"" x
in
let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in
Ok (t, [ `Tls (s, out) ])
end
| Destroy_vm ->
begin match Vmm_resources.find_vm t.resources arg with
| Some vm ->
Vmm_unix.destroy vm ;
let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
Ok (t, [ `Tls (s, out) ])
| _ ->
Error (`Msg ("destroy: not found " ^ buf))
end
| Attach ->
(* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *)
let on_success t =
let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in
let old = match String.Map.find vmid t.console_attached with
| None -> []
| Some s ->
let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
[ `Tls (s, out) ]
in
let console_attached = String.Map.add vmid s t.console_attached in
{ t with console_counter = succ t.console_counter ; console_attached },
`Raw (t.console_socket, cons) :: old
in
let cons = Vmm_wire.Console.attach t.console_counter t.console_version vmid in
let console_requests = IM.add t.console_counter on_success t.console_requests in
Ok ({ t with console_counter = succ t.console_counter ; console_requests },
[ `Raw (t.console_socket, cons) ])
| Detach ->
let cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in
(match String.Map.find vmid t.console_attached with
| None -> Error (`Msg "not attached")
| Some x when t.cmp x s -> Ok (String.Map.remove vmid t.console_attached)
| Some _ -> Error (`Msg "this socket is not attached")) >>= fun console_attached ->
let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
Ok ({ t with console_counter = succ t.console_counter ; console_attached },
[ `Raw (t.console_socket, cons) ; `Tls (s, out) ])
| Statistics ->
begin match t.stats_socket with
| None -> Error (`Msg "no statistics available")
| Some _ -> match Vmm_resources.find_vm t.resources arg with
| Some vm ->
let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vmid in
let d = (s, hdr.Vmm_wire.id, translate_tap vm) in
let stats_requests = IM.add t.stats_counter d t.stats_requests in
Ok ({ t with stats_counter = succ t.stats_counter ; stats_requests },
stat t stat_out)
| _ -> Error (`Msg ("statistics: not found " ^ buf))
end
| Log ->
begin
let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in
let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in
let log_counter = succ t.log_counter in
Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ])
end
| Create_block | Destroy_block -> Error (`Msg "NYI")
end
| Some _ -> Error (`Msg "unauthorised command")
in
match res with
| Ok r -> r
| Error (`Msg msg) ->
Logs.debug (fun m -> m "error while processing command: %s" msg) ;
let out = Vmm_wire.fail ~msg hdr.Vmm_wire.id t.client_version in
(t, [ `Tls (s, out) ])
type t = [
| `Info of id
| `Policy of id
| `Add_policy of id * policy
| `Remove_policy of id
| `Create_vm of vm_config
| `Force_create_vm of vm_config
| `Destroy_vm of id
| `Statistics of id
| `Console of id
| `Log of id
]
let handle_stat state hdr data =
let open Vmm_wire in
if not (version_eq hdr.version state.stats_version) then begin
Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
state, []
end else if hdr.tag = success_tag then
state, []
let handle = function
| `Info name ->
let cmd = Vmm_wire.Vm.info c ver name in
`Vmmd, `End, cmd
| `Policy name ->
let cmd = Vmm_wire.Vm.policy c ver name in
`Vmmd, `End, cmd
| `Remove_policy name ->
let cmd = Vmm_wire.Vm.remove_policy c ver name in
`Vmmd, `End, cmd
| `Add_policy (name, policy) ->
let cmd = Vmm_wire.Vm.insert_policy c ver name policy in
`Vmmd, `End, cmd
| `Create_vm vm ->
let cmd = Vmm_wire.Vm.create c ver vm in
`Vmmd, `End, cmd
| `Force_create_vm vm ->
let cmd = Vmm_wire.Vm.force_create c ver vm in
`Vmmd, `End, cmd
| `Destroy_vm name ->
let cmd = Vmm_wire.Vm.destroy c ver name in
`Vmmd, `End, cmd
| `Statistics name ->
let cmd = Vmm_wire.Stats.subscribe c ver name in
`Stats, `Read, cmd
| `Console name ->
let cmd = Vmm_wire.Console.attach c ver name in
`Console, `Read, cmd
| `Log name ->
let cmd = Vmm_wire.Log.subscribe c ver name in
`Log, `Read, cmd
(* | `Crl _ -> assert false
(* write_to_file_unless_serial_smaller ; potentially destroy vms *)
| `Create_block (name, size) -> assert false
| `Destroy_block name -> assert false
*)
let handle_reply (hdr, data) =
if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then
Error (`Msg "unknown wire protocol version")
else
match IM.find hdr.id state.stats_requests with
| exception Not_found ->
Logs.err (fun m -> m "couldn't find stat request") ;
state, []
| (s, req_id, f) ->
let stats_requests = IM.remove hdr.id state.stats_requests in
let state = { state with stats_requests } in
let out =
match Stats.int_to_op hdr.tag with
| Some Stats.Stat_reply ->
begin match Stats.decode_stats (Cstruct.of_string data) with
| Ok (ru, vmm, ifs) ->
let ifs =
List.map
(fun x ->
match f x.name with
| Some name -> { x with name }
| None -> x)
ifs
in
let data = Cstruct.to_string (Stats.encode_stats (ru, vmm, ifs)) in
let out = Client.stat data req_id state.client_version in
[ `Tls (s, out) ]
| Error (`Msg msg) ->
Logs.err (fun m -> m "error %s while decode statistics" msg) ;
let out = fail req_id state.client_version in
[ `Tls (s, out) ]
end
| None when hdr.tag = fail_tag ->
let out = fail ~msg:data req_id state.client_version in
[ `Tls (s, out) ]
| _ ->
Logs.err (fun m -> m "unexpected reply from stat") ;
[]
in
(state, out)
let handle_cons state hdr data =
let open Vmm_wire in
if not (version_eq hdr.version state.console_version) then begin
Logs.warn (fun m -> m "ignoring message with unknown console version") ;
state, []
end else match Console.int_to_op hdr.tag with
| Some Console.Data ->
begin match decode_str data with
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while decoding console message %s" msg) ;
(state, [])
| Ok (file, off) ->
(match String.Map.find file state.console_attached with
| Some s ->
let out = Client.console off file data state.client_version in
(state, [ `Tls (s, out) ])
| None ->
(* TODO: should detach? *)
Logs.err (fun m -> m "couldn't find attached console for %s" file) ;
(state, []))
end
| None when hdr.tag = success_tag ->
(match IM.find hdr.id state.console_requests with
| exception Not_found ->
(state, [])
| cont ->
let state', outs = cont state in
let console_requests = IM.remove hdr.id state.console_requests in
({ state' with console_requests }, outs))
| None when hdr.tag = fail_tag ->
(match IM.find hdr.id state.console_requests with
| exception Not_found ->
Logs.err (fun m -> m "fail couldn't find request id") ;
(state, [])
| _ ->
Logs.err (fun m -> m "failed while trying to do something on console") ;
let console_requests = IM.remove hdr.id state.console_requests in
({ state with console_requests }, []))
| _ ->
Logs.err (fun m -> m "unexpected message received from console socket") ;
(state, [])
let handle_log state hdr buf =
let open Vmm_wire in
let open Vmm_wire.Log in
if not (version_eq hdr.version state.log_version) then begin
Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
state, []
end else match IM.find hdr.id state.log_requests with
| exception Not_found ->
Logs.warn (fun m -> m "(ignored) coudn't find log request") ;
(state, [])
| (s, rid) ->
let r = match int_to_op hdr.tag with
| Some Data ->
decode_log_hdr (Cstruct.of_string buf) >>= fun (hdr, rest) ->
decode_event rest >>= fun event ->
let tls = Vmm_wire.Client.log hdr event state.client_version in
Ok (state, [ `Tls (s, tls) ])
| None when hdr.tag = success_tag ->
let log_requests = IM.remove hdr.id state.log_requests in
let tls = Vmm_wire.success rid state.client_version in
Ok ({ state with log_requests }, [ `Tls (s, tls) ])
| None when hdr.tag = fail_tag ->
let log_requests = IM.remove hdr.id state.log_requests in
let tls = Vmm_wire.fail rid state.client_version in
Ok ({ state with log_requests }, [ `Tls (s, tls) ])
| _ ->
Logs.err (fun m -> m "couldn't parse log reply") ;
let log_requests = IM.remove hdr.id state.log_requests in
Ok ({ state with log_requests }, [])
in
match r with
| Ok (s, out) -> s, out
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while processing log %s" msg) ;
state, []
if Vmm_wire.is_fail hdr then
let msg = match Vmm_wire.decode_string data with
| Ok (msg, _) -> msg
| Error _ -> ""
in
Error (`Msg ("command failed " ^ msg))
else if Vmm_wire.is_reply hdr && hdr.Vmm_wire.id = c then
Ok (hdr, data)
else
Error (`Msg "received unexpected data")

4
src/vmm_core.ml
View File

@ -229,10 +229,12 @@ let identifier serial =
match Hex.of_cstruct @@ Nocrypto.Hash.SHA256.digest @@
Nocrypto.Numeric.Z.to_cstruct_be @@ serial
with
| `Hex str -> fst (String.span ~max:6 str)
| `Hex str -> str
let id cert = identifier (X509.serial cert)
let name cert = X509.common_name_to_string cert
let parse_db lines =
List.fold_left (fun acc s ->
acc >>= fun datas ->

72
src/vmm_x509.ml
View File

@ -1,6 +1,11 @@
open Astring
open Rresult.R.Infix
open Vmm_core
let asn_version = `AV1
(*
let handle_single_revocation t prefix serial =
let id = identifier serial in
(match Vmm_resources.find t.resources (prefix @ [ id ]) with
@ -39,7 +44,9 @@ let handle_single_revocation t prefix serial =
(state,
List.map (fun x -> `Raw x) out,
List.map fst kill)
*)
(*
let handle_revocation t s leaf chain ca prefix =
Vmm_asn.crl_of_cert leaf >>= fun crl ->
(* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *)
@ -85,20 +92,51 @@ let handle_revocation t s leaf chain ca prefix =
in
let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in
Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close)
*)
let handle_initial t s addr chain ca =
let my_command = 1L
let my_version = `WV2
let handle_initial s addr chain ca =
separate_chain chain >>= fun (leaf, chain) ->
let prefix = List.map name chain in
let name = prefix @ [ name leaf ] in
Logs.debug (fun m -> m "leaf is %s, chain %a"
(X509.common_name_to_string leaf)
Fmt.(list ~sep:(unit "->") string)
Fmt.(list ~sep:(unit " -> ") string)
(List.map X509.common_name_to_string chain)) ;
(* TODO here: inspect top-level-cert of chain.
may need to create bridges and/or block device subdirectory (zfs create) *)
let prefix = List.map id chain in
let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in
let t, out = log t (login_hdr, login_ev) in
let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in
Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms ->
(* let login_hdr, login_ev = Log.hdr name, `Login addr in *)
Ok ()
(* Vmm_asn.command_of_cert asn_version leaf >>= function
| `Info ->
let cmd = Vmm_wire.Vm.info my_command my_version name in
Ok (`Vmmd, cmd)
| `Create_vm ->
Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
let cmd = Vmm_wire.Vm.create my_command my_version vm_config in
(* TODO: update acl *)
Ok (`Vmmd, cmd)
| `Force_create_vm ->
Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
let cmd = Vmm_wire.Vm.force_create my_command my_version vm_config in
(* TODO: update acl *)
Ok (`Vmmd, cmd)
| `Destroy_vm ->
let cmd = Vmm_wire.Vm.destroy my_command my_version name in
Ok (`Vmmd, cmd)
| `Statistics ->
let cmd = Vmm_wire.Stats.subscribe my_command my_version name in
Ok (`Stats, cmd)
| `Console -> `Cons, Vmm_wire.Console.attach ; read there and write to tls
| `Log -> `Log, Vmm_wire.Log.subscribe ; read there and write to tls
| `Crl -> write_to_file_unless_serial_smaller ; potentially destroy vms
| `Create_block -> ??
| `Destroy_block -> ??
(if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then
(* convert certificate to vm_config *)
Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
@ -144,20 +182,6 @@ let handle_initial t s addr chain ca =
cont)
in
Ok (t, [], `Create (task, next))
else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
handle_revocation t s leaf chain ca prefix
else
let log_attached =
if cmd_allowed perms Log then
let pre = string_of_id prefix in
let v = match String.Map.find pre t.log_attached with
| None -> []
| Some xs -> xs
in
String.Map.add pre ((s, id leaf) :: v) t.log_attached
else
t.log_attached
in
Ok ({ t with log_attached }, [], `Loop (prefix, perms))
) >>= fun (t, outs, res) ->
Ok (t, initial_out :: out @ outs, res)
(* else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
handle_revocation t s leaf chain ca prefix *)
*)