From 2239aafdb722cd332dc6ba6a1254deea49dc7e07 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 14 Oct 2018 02:18:33 +0200 Subject: [PATCH] revive vmm_client --- app/vmm_client.ml | 101 +++----------------- app/vmm_tls_endpoint.ml | 43 ++++++++- app/vmmc.ml | 112 ++++++---------------- pkg/pkg.ml | 2 +- src/vmm_commands.ml | 59 +++++++++++- src/vmm_tls.ml | 6 +- src/vmm_x509.ml | 206 +++++++--------------------------------- 7 files changed, 176 insertions(+), 353 deletions(-) diff --git a/app/vmm_client.ml b/app/vmm_client.ml index 46b5485..4599ad6 100644 --- a/app/vmm_client.ml +++ b/app/vmm_client.ml @@ -4,85 +4,20 @@ open Lwt.Infix open Vmm_core -let my_version = `WV2 -let command = ref 1 - -let process db hdr data = - let open Vmm_wire in - let open Rresult.R.Infix in - if not (version_eq hdr.version my_version) then - Logs.err (fun m -> m "unknown wire protocol version") - else - let r = - match hdr.tag with - | x when x = Client.stat_msg_tag -> - Client.decode_stat data >>= fun (ru, vmm, ifd) -> - Logs.app (fun m -> m "statistics: %a %a %a" - pp_rusage ru - Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm - Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ; - Ok () - | x when x = Client.log_msg_tag -> - Client.decode_log data >>= fun log -> - Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ; - Ok () - | x when x = Client.console_msg_tag -> - Client.decode_console data >>= fun (name, ts, msg) -> - Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ; - Ok () - | x when x = Client.info_msg_tag -> - Client.decode_info data >>= fun vms -> - List.iter (fun (name, cmd, pid, taps) -> - Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name) - cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) - vms ; - Ok () - | x when x = fail_tag -> - decode_str data >>= fun (msg, _) -> - Logs.err (fun m -> m "failed %s" msg) ; - Ok () - | x when x = success_tag -> - decode_str data >>= fun (msg, _) -> - Logs.app (fun m -> m "success %s" msg) ; - Ok () - | x -> Rresult.R.error_msgf "unknown header tag %02X" x - in - match r with - | Ok () -> () - | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg) - -let rec read_tls_write_cons db t = +let rec read_tls_write_cons t = Vmm_tls.read_tls t >>= function | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; - read_tls_write_cons db t + read_tls_write_cons t | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, data) -> - process db hdr data ; - read_tls_write_cons db t + | Ok data -> + match Vmm_commands.log_pp_reply data with + | Ok () -> read_tls_write_cons t + | Error (`Msg msg) -> + Logs.warn (fun m -> m "error %s while logging message" msg) ; + read_tls_write_cons t -let rec read_cons_write_tls db t = - Lwt.catch (fun () -> - Lwt_io.read_line Lwt_io.stdin >>= fun line -> - let cmd, arg = match Astring.String.cut ~sep:" " line with - | None -> line, None - | Some (a, b) -> a, Some (translate_name db b) - in - match Vmm_core.cmd_of_string cmd with - | None -> Logs.err (fun m -> m "unknown command") ; read_cons_write_tls db t - | Some cmd -> - let out = Vmm_wire.Client.cmd ?arg cmd !command my_version in - command := succ !command ; - Vmm_tls.write_tls t out >>= function - | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit - | Ok () -> - Logs.debug (fun m -> m "wrote %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ; - read_cons_write_tls db t) - (fun e -> - Logs.err (fun m -> m "exception %s in read_cons_write_tls" (Printexc.to_string e)) ; - Lwt.return_unit) - -let client cas host port cert priv_key db = +let client cas host port cert priv_key = Nocrypto_entropy_lwt.initialize () >>= fun () -> let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in X509_lwt.authenticator auth >>= fun authenticator -> @@ -99,12 +34,7 @@ let client cas host port cert priv_key db = let certificates = `Single cert in let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t -> - - if Vmm_asn.contains_vm leaf || Vmm_asn.contains_crl leaf then - read_tls_write_cons db t - else - (Logs.debug (fun m -> m "read/write games!") ; - Lwt.join [ read_tls_write_cons db t ; read_cons_write_tls db t ])) + read_tls_write_cons t) (fun exn -> Logs.err (fun m -> m "failed to establish TLS connection: %s" (Printexc.to_string exn)) ; @@ -116,16 +46,7 @@ let run_client _ cas cert key (host, port) db = | Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f) | _ -> None) ; Sys.(set_signal sigpipe Signal_ignore) ; - let db = - let open Rresult.R.Infix in - match db with - | None -> [] - | Some db -> - match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with - | Ok db -> db - | Error (`Msg m) -> Logs.warn (fun f -> f "couldn't parse database %s" m) ; [] - in - Lwt_main.run (client cas host port cert key db) + Lwt_main.run (client cas host port cert key) let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 909c27a..087f3e2 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -34,10 +34,45 @@ let client_auth ca tls addr = Tls_lwt.Unix.close tls >>= fun () -> Lwt.fail_with "error while getting epoch") +let read fd tls = + (* 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) -> + let full = Cstruct.append (Vmm_wire.encode_header hdr) data in + Vmm_tls.write_tls tls full >>= function + | Ok () -> loop () + | Error `Exception -> Lwt.return (Error (`Msg "exception")) + in + loop () + +let process fd tls = + Vmm_lwt.read_wire fd >>= function + | Error (`Msg m) -> Lwt.return (Error (`Msg m)) + | Error _ -> Lwt.return (Error (`Msg "read error")) + | Ok (hdr, data) -> + let full = Cstruct.append (Vmm_wire.encode_header hdr) data in + Vmm_tls.write_tls tls full >|= function + | Ok () -> Ok () + | Error `Exception -> Error (`Msg "exception on write") + 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 + match Vmm_x509.handle addr chain with + | Error (`Msg m) -> Lwt.fail_with m + | Ok cmd -> + let sock, next, cmd = Vmm_commands.handle cmd in + connect (Vmm_core.socket_path sock) >>= 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 tls + | `End -> process fd tls) >>= fun res -> + Vmm_lwt.safe_close fd >|= fun () -> + res let server_socket port = let open Lwt_unix in @@ -72,7 +107,9 @@ let jump _ cacert cert priv_key port = Lwt.fail exn) >>= fun t -> Lwt.async (fun () -> Lwt.catch - (fun () -> handle ca t) + (fun () -> handle ca t >|= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg) + | Ok () -> ()) (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 45bd79f..1ce632c 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -22,76 +22,56 @@ let connect socket_path = Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> c -let read fd f = +let read fd = (* 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)) + | Ok data -> match Vmm_commands.handle_reply data with + | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) + | Ok (hdr, data) -> + 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 Vmm_commands.log_pp_reply (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 handle opt_socket (cmd : Vmm_commands.t) = 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 + | `Read -> read fd | `End -> process fd >|= function | Error e -> Error e - | Ok data -> f data) >>= fun res -> + | Ok data -> Vmm_commands.log_pp_reply data) >>= fun res -> Vmm_lwt.safe_close fd >|= fun () -> res -let jump opt_socket cmd f = +let jump opt_socket cmd = match - Lwt_main.run (handle opt_socket cmd f) + Lwt_main.run (handle opt_socket cmd) with | Ok () -> `Ok () | Error (`Msg m) -> `Error (false, m) -let info_ _ opt_socket name = - 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 info_ _ opt_socket name = jump opt_socket (`Info name) -let policy _ opt_socket name = - 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 policy _ opt_socket name = jump opt_socket (`Policy name) -let remove_policy _ opt_socket name = - jump opt_socket (`Remove_policy name) (fun _ -> - Ok (Logs.app (fun m -> m "removed policy"))) +let remove_policy _ opt_socket name = jump opt_socket (`Remove_policy name) let add_policy _ opt_socket name vms memory cpus block bridges = let bridges = match bridges with @@ -104,12 +84,10 @@ let add_policy _ opt_socket name vms memory cpus block bridges = 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"))) + jump opt_socket (`Add_policy (name, policy)) let destroy _ opt_socket name = - jump opt_socket (`Destroy_vm name) (fun _ -> - Ok (Logs.app (fun m -> m "destroyed VM"))) + jump opt_socket (`Destroy_vm name) 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 @@ -132,45 +110,13 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc else `Create_vm vm_config in - let succ _ = Ok (Logs.app (fun m -> m "successfully started VM")) in - jump opt_socket cmd succ + jump opt_socket cmd -let console _ opt_socket name = - 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 console _ opt_socket name = jump opt_socket (`Console name) -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 stats _ opt_socket name = jump opt_socket (`Statistics name) -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 event_log _ opt_socket name = jump opt_socket (`Log name) let help _ _ man_format cmds = function | None -> `Help (`Pager, None) diff --git a/pkg/pkg.ml b/pkg/pkg.ml index a8823a6..0b280e7 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -9,7 +9,7 @@ let () = Pkg.bin "app/vmmd" ; Pkg.bin "app/vmm_console" ; Pkg.bin "app/vmm_log" ; - (* Pkg.bin "app/vmm_client" ; *) + Pkg.bin "app/vmm_client" ; Pkg.bin "app/vmm_tls_endpoint" ; Pkg.bin "app/vmmc" ; Pkg.bin "provision/vmm_req_command" ; diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index fb8f7f3..31ab71d 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -16,6 +16,9 @@ type t = [ | `Statistics of id | `Console of id | `Log of id + | `Crl (* TODO *) + | `Create_block of id * int + | `Destroy_block of id ] let handle = function @@ -49,11 +52,9 @@ let handle = function | `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 *) + | `Crl -> assert false | `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 @@ -69,3 +70,55 @@ let handle_reply (hdr, data) = Ok (hdr, data) else Error (`Msg "received unexpected data") + +let log_pp_reply (hdr, data) = + let open Vmm_wire in + let tag' = Int32.logxor reply_tag hdr.tag in + let open Rresult.R.Infix in + match Vm.int_to_op tag' with + | Some Vm.Info -> + 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 + | Some Vm.Policy -> + 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 + | Some Vm.Insert_policy -> + Ok (Logs.app (fun m -> m "added policy")) + | Some Vm.Remove_policy -> + Ok (Logs.app (fun m -> m "removed policy")) + | Some Vm.Destroy -> + Ok (Logs.app (fun m -> m "destroyed VM")) + | Some Vm.Create -> + Ok (Logs.app (fun m -> m "successfully started VM")) + | Some Vm.Force_create -> + Ok (Logs.app (fun m -> m "successfully forcefully started VM")) + | None -> match Console.int_to_op tag' with + | Some Console.Data -> + decode_id_ts data >>= fun ((name, ts), off) -> + decode_string (Cstruct.shift data off) >>| fun (msg, _) -> + Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts pp_id name msg) + | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) + | None -> match Stats.int_to_op tag' with + | Some Stats.Data -> + decode_strings data >>= fun (name', off) -> + Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) -> + Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@." + pp_id name' pp_rusage ru + Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm + Fmt.(list ~sep:(unit "@.") pp_ifdata) ifs) + | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) + | None -> match Log.int_to_op tag' with + | Some Log.Broadcast -> + Log.decode_log_hdr data >>= fun (loghdr, logdata) -> + Log.decode_event logdata >>| fun event -> + Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event)) + | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) + | None -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) + + + diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index b41d40a..e532841 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -42,14 +42,14 @@ let read_tls t = (* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a" hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag Cstruct.hexdump_pp b) ; *) - Ok (hdr, Cstruct.to_string b) + Ok (hdr, b) else - Lwt.return (Ok (hdr, "")) + Lwt.return (Ok (hdr, Cstruct.empty)) let write_tls s buf = (* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *) Lwt.catch - (fun () -> Tls_lwt.Unix.write s (Cstruct.of_string buf) >|= fun () -> Ok ()) + (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ()) (function | Tls_lwt.Tls_failure a -> Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ; diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index 0f19478..ea65bb1 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -5,142 +5,7 @@ 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 - | None -> () - | Some e -> Vmm_resources.iter Vmm_unix.destroy e) ; - (* also revoke all active sessions!? *) - (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *) - let log_attached, kill = - let pid = string_of_id prefix in - match String.Map.find pid t.log_attached with - | None -> t.log_attached, [] - | Some xs -> - (* those where snd v = serial: drop *) - let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in - String.Map.add pid keep t.log_attached, drop - in - (* two things: - 1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above] - 2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *) - let log_attached, kill = - String.Map.fold (fun k' v (l, k) -> - if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then - (l, v @ k) - else - (String.Map.add k' v l, k)) - log_attached - (String.Map.empty, kill) - in - let state, out = - List.fold_left (fun (s, out) (t, _) -> - let s', out' = handle_disconnect s t in - s', out @ out') - ({ t with log_attached }, []) - kill - in - (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))! *) - let issuer = match chain with - | subca::_ -> subca - | [] -> ca - in - let time = Ptime_clock.now () in - (if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () -> - (* the this_update must be > now, next_update < now, this_update > .this_update, number > .number *) - (* TODO: can we have something better for uniqueness of CRL? *) - let local = try Some (List.find (fun crl -> X509.CRL.verify crl issuer) t.crls) with Not_found -> None in - (match local with - | None -> Ok () - | Some local -> match X509.CRL.crl_number local, X509.CRL.crl_number crl with - | None, _ -> Ok () - | Some _, None -> Error (`Msg "CRL number not present") - | Some x, Some y -> if y > x then Ok () else Error (`Msg "CRL number not increased")) >>= fun () -> - (* filename should be whatever_dir / crls / *) - let filename = Fpath.(dbdir / "crls" / string_of_id prefix) in - Bos.OS.File.delete filename >>= fun () -> - Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () -> - (* remove crl with same issuer from crls, and inject this one into state *) - let crls = - match local with - | None -> crl :: t.crls - | Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls - in - (* iterate over revoked serials, find active resources, and kill them *) - let newly_revoked = - let old = match local with - | Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x) - | None -> [] - in - let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in - List.filter (fun n -> not (List.mem n old)) new_rev - in - let t, out, close = - List.fold_left (fun (t, out, close) serial -> - let t', out', close' = handle_single_revocation t prefix serial in - (t', out @ out', close @ close')) - (t, [], []) newly_revoked - 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 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) - (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 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 -> - Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ; +(* let check_policy = (* get names and static resources *) List.fold_left (fun acc ca -> acc >>= fun acc -> @@ -151,37 +16,38 @@ let handle_initial s addr chain ca = (* check static policies *) Logs.debug (fun m -> m "now checking static policies") ; check_policies vm_config (List.map snd policies) >>= fun () -> - let t, task = - let force = List.mem `Force_create perms in - if force then - let fid = vm_id vm_config in - match String.Map.find fid t.tasks with - | None -> t, None - | Some task -> - let kill () = - match Vmm_resources.find_vm t.resources (fullname vm_config) with - | None -> - Logs.err (fun m -> m "found a task, but no vm for %a (%s)" - pp_id (fullname vm_config) fid) - | Some vm -> - Logs.debug (fun m -> m "killing %a now" pp_vm vm) ; - Vmm_unix.destroy vm - in - let tasks = String.Map.remove fid t.tasks in - ({ t with tasks }, Some (kill, task)) - else - t, None - in - let next t sleeper = - handle_create t vm_config policies >>= fun cont -> - let id = vm_id vm_config in - let cons = Vmm_wire.Console.add t.console_counter t.console_version id in - let tasks = String.Map.add id sleeper t.tasks in - Ok ({ t with console_counter = succ t.console_counter ; tasks }, - [ `Raw (t.console_socket, cons) ], - 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 *) - *) +*) + +let handle addr chain = + 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) + (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 login_hdr, login_ev = Log.hdr name, `Login addr in *) + Vmm_asn.command_of_cert asn_version leaf >>= function + | `Info -> Ok (`Info name) + | `Create_vm -> + (* TODO: update acl *) + Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config -> + `Create_vm vm_config + | `Force_create_vm -> + (* TODO: update acl *) + Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config -> + `Force_create_vm vm_config + | `Destroy_vm -> Ok (`Destroy_vm name) + | `Statistics -> Ok (`Statistics name) + | `Console -> Ok (`Console name) + | `Log -> Ok (`Log name) + | `Crl -> Ok `Crl + | `Create_block -> + Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name -> + Vmm_asn.block_size_of_cert asn_version leaf >>| fun block_size -> + `Create_block (block_name, block_size) + | `Destroy_block -> + Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name -> + `Destroy_block block_name