diff --git a/_tags b/_tags index fe13147..45dcadd 100644 --- a/_tags +++ b/_tags @@ -10,7 +10,7 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring : package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress) : package(nocrypto tls.lwt nocrypto.lwt) -: package(tls.lwt) +: package(tls.lwt) : package(nocrypto tls.lwt nocrypto.lwt) : package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt decompress) diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index af82442..909c27a 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -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)) ; diff --git a/app/vmmc.ml b/app/vmmc.ml index 2452939..45bd79f 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -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) diff --git a/pkg/pkg.ml b/pkg/pkg.ml index c97fff5..a8823a6 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -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" ; diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index e4bf64b..fb8f7f3 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -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) 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") diff --git a/src/vmm_core.ml b/src/vmm_core.ml index ae04661..c4d2ae4 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -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 -> diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index b1f5445..0f19478 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -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 *) + *)