From e413b8c99acd3d3aad198fd7873100b501c3b683 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 12 Oct 2018 19:45:46 +0200 Subject: [PATCH] remove naming struggle in vm_config and Log.hdr --- app/vmm_log.ml | 4 ++-- app/vmmc.ml | 8 ++------ src/vmm_asn.ml | 4 ++-- src/vmm_core.ml | 22 ++++++++-------------- src/vmm_engine.ml | 22 ++++++++++------------ src/vmm_unix.ml | 4 ++-- src/vmm_wire.ml | 23 +++++++++-------------- 7 files changed, 35 insertions(+), 52 deletions(-) diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 0338ab8..649a548 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -73,7 +73,7 @@ let send_history s ring id cmd_id = let cs = Cstruct.of_string x in match Vmm_wire.Log.decode_log_hdr cs with | Ok (hdr, _) -> - begin match Vmm_core.drop_super ~super:id ~sub:hdr.Vmm_core.Log.context with + begin match Vmm_core.drop_super ~super:id ~sub:hdr.Vmm_core.Log.name with | Some [] -> cs :: acc | _ -> acc end @@ -118,7 +118,7 @@ let handle mvar ring s addr () = Lwt_mvar.put mvar data >>= fun () -> let data' = Vmm_wire.encode ~body:data my_version !bcast (Vmm_wire.Log.op_to_int Vmm_wire.Log.Broadcast) in bcast := Int64.succ !bcast ; - broadcast hdr.Vmm_core.Log.context data' !tree >>= fun tree' -> + broadcast hdr.Vmm_core.Log.name data' !tree >>= fun tree' -> tree := tree' ; loop () end diff --git a/app/vmmc.ml b/app/vmmc.ml index 4265b34..d7ad5fa 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -82,18 +82,14 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc | Ok data -> data | Error (`Msg s) -> invalid_arg s in - let prefix, vname = match List.rev name with - | [ name ] -> [], name - | name::tl -> List.rev tl, name - | [] -> assert false - and argv = match boot_params with + let argv = match boot_params with | [] -> None | xs -> Some xs (* TODO we could do the compression btw *) and vmimage = `Hvt_amd64, Cstruct.of_string image' in let vm_config = { - prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; + vname = name ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in Lwt_main.run ( diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 3a1bd24..d054e41 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -213,9 +213,9 @@ let vm_of_cert prefix cert = opt cert Oid.network strings_of_cstruct >>= fun network -> req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage -> opt cert Oid.argv strings_of_cstruct >>= fun argv -> - let vname = id cert in + let vname = prefix @ [ id cert ] in let network = match network with None -> [] | Some x -> x in - Ok { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + Ok { vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } let command_of_cert version cert = version_of_cert version cert >>= fun () -> diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 7e8e755..6b088e6 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -154,8 +154,7 @@ let is_sub ~super ~sub = sub_bridges super.bridges sub.bridges && sub_block super.block sub.block type vm_config = { - prefix : id ; - vname : string ; + vname : id ; cpuid : int ; requested_memory : int ; block_device : string option ; @@ -164,13 +163,9 @@ type vm_config = { argv : string list option ; } -let fullname vm = vm.prefix @ [ vm.vname ] - -let vm_id vm = string_of_id (fullname vm) - (* used for block devices *) -let location vm = match vm.prefix with - | tld::rest -> tld, String.concat ~sep:"." (rest@[vm.vname]) +let location vm = match vm.vname with + | tld::rest -> tld, String.concat ~sep:"." rest | [] -> invalid_arg "dunno how this happened" let pp_image ppf (typ, blob) = @@ -178,8 +173,8 @@ let pp_image ppf (typ, blob) = Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l let pp_vm_config ppf (vm : vm_config) = - Fmt.pf ppf "%s cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" - vm.vname vm.cpuid vm.requested_memory + Fmt.pf ppf "%a cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" + pp_id vm.vname vm.cpuid vm.requested_memory Fmt.(option ~none:(unit "no") string) vm.block_device Fmt.(list ~sep:(unit ", ") string) vm.network pp_image vm.vmimage @@ -319,14 +314,13 @@ let pp_ifdata ppf i = module Log = struct type hdr = { ts : Ptime.t ; - context : id ; - name : string ; + name : id ; } let pp_hdr ppf (hdr : hdr) = - Fmt.pf ppf "%a: %s" (Ptime.pp_human ()) hdr.ts hdr.name + Fmt.pf ppf "%a: %a" (Ptime.pp_rfc3339 ()) hdr.ts pp_id hdr.name - let hdr context name = { ts = Ptime_clock.now () ; context ; name } + let hdr name = { ts = Ptime_clock.now () ; name } type event = [ `Startup diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index c81aa22..7a4f0b9 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -40,8 +40,7 @@ let log state (hdr, event) = ({ state with log_counter }, `Log data) let handle_create t hdr vm_config (* policies *) = - let full = fullname vm_config in - (if Vmm_resources.exists t.resources full then + (if Vmm_resources.exists t.resources vm_config.vname then Error (`Msg "VM with same name is already running") else Ok ()) >>= fun () -> @@ -51,14 +50,14 @@ let handle_create t hdr vm_config (* policies *) = Vmm_unix.prepare vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; (* TODO should we pre-reserve sth in t? *) - let cons = Vmm_wire.Console.add t.console_counter t.console_version full in + let cons = Vmm_wire.Console.add t.console_counter t.console_version vm_config.vname in Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons ], `Create (fun t task -> (* actually execute the vm *) Vmm_unix.exec vm_config taps >>= fun vm -> Logs.debug (fun m -> m "exec()ed vm") ; - Vmm_resources.insert t.resources full vm >>= fun resources -> - let tasks = String.Map.add (string_of_id full) task t.tasks in + Vmm_resources.insert t.resources vm_config.vname vm >>= fun resources -> + let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in let used_bridges = List.fold_left2 (fun b br ta -> let old = match String.Map.find br b with @@ -69,12 +68,12 @@ let handle_create t hdr vm_config (* policies *) = t.used_bridges vm_config.network taps in let t = { t with resources ; tasks ; used_bridges } in - let t, out = log t (Log.hdr vm_config.prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in + let t, out = log t (Log.hdr vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in let data = Vmm_wire.success t.client_version hdr.Vmm_wire.id Vmm_wire.Vm.(op_to_int Create) in Ok (t, [ `Data data ; out ], vm))) let setup_stats t vm = - let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (fullname vm.config) vm.pid vm.taps in + let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version vm.config.vname vm.pid vm.taps in let t = { t with stats_counter = Int64.succ t.stats_counter } in Ok (t, [ `Stat stat_out ]) @@ -83,7 +82,7 @@ let handle_shutdown t vm r = | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; let resources = - match Vmm_resources.remove t.resources (fullname vm.config) vm with + match Vmm_resources.remove t.resources vm.config.vname vm with | Ok resources -> resources | Error (`Msg e) -> Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ; @@ -98,11 +97,10 @@ let handle_shutdown t vm r = String.Map.add br (String.Set.remove ta old) b) t.used_bridges vm.config.network vm.taps in - let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version (fullname vm.config) in - let tasks = String.Map.remove (vm_id vm.config) t.tasks in + let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.config.vname in + let tasks = String.Map.remove (string_of_id vm.config.vname) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in - let t, logout = log t (Log.hdr vm.config.prefix vm.config.vname, - `VM_stop (vm.pid, r)) + let t, logout = log t (Log.hdr vm.config.vname, `VM_stop (vm.pid, r)) in (t, [ `Stat stat_out ; logout ]) diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index b30eb65..3b17165 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -58,8 +58,8 @@ let rec mkfifo name = | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name let image_file, fifo_file = - ((fun vm -> Fpath.(tmpdir / (vm_id vm) + "img")), - (fun vm -> Fpath.(tmpdir / "fifo" / (vm_id vm)))) + ((fun vm -> Fpath.(tmpdir / (string_of_id vm.vname) + "img")), + (fun vm -> Fpath.(tmpdir / "fifo" / (string_of_id vm.vname)))) let rec fifo_exists file = try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 267b00a..e8356b5 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -458,9 +458,8 @@ module Log = struct encode ~name version id (op_to_int Subscribe) let decode_log_hdr cs = - decode_id_ts cs >>= fun ((id, ts), off) -> - split_id id >>= fun (name, context) -> - Ok ({ Log.ts ; context ; name }, Cstruct.shift cs off) + decode_id_ts cs >>= fun ((name, ts), off) -> + Ok ({ Log.ts ; name }, Cstruct.shift cs off) let encode_addr ip port = let cs = Cstruct.create 6 in @@ -538,10 +537,8 @@ module Log = struct | x -> R.error_msgf "couldn't parse event type %d" x let log id version hdr event = - let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) - and name = hdr.Log.context @ [ hdr.Log.name ] - in - encode ~name ~body version id (op_to_int Log) + let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) in + encode ~name:hdr.name ~body version id (op_to_int Log) end module Vm = struct @@ -566,7 +563,7 @@ module Vm = struct encode ~name version id (op_to_int Info) let encode_vm vm = - let name = encode_strings (vm.config.prefix @ [ vm.config.vname ]) + let name = encode_strings vm.config.vname and memory = encode_int vm.config.requested_memory and cs = encode_string (Bos.Cmd.to_string vm.cmd) and pid = encode_int vm.pid @@ -605,9 +602,8 @@ module Vm = struct Cstruct.concat [ cpu ; mem ; block ; network ; vmimage ; args ] let decode_vm_config buf = - decode_strings buf >>= fun (id, off) -> - Logs.debug (fun m -> m "vm_config id %a" pp_id id) ; - split_id id >>= fun (vname, prefix) -> + decode_strings buf >>= fun (vname, off) -> + Logs.debug (fun m -> m "vm_config name %a" pp_id vname) ; cs_shift buf off >>= fun buf' -> decode_int buf' >>= fun cpuid -> Logs.debug (fun m -> m "cpuid %d" cpuid) ; @@ -630,12 +626,11 @@ module Vm = struct cs_shift buf'''' (16 + size) >>= fun buf''''' -> decode_strings buf''''' >>= fun (argv, _) -> let argv = match argv with [] -> None | xs -> Some xs in - Ok { vname ; prefix ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + Ok { vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } let create id version vm = let body = encode_vm_config vm in - let name = vm.prefix @ [ vm.vname ] in - encode ~name ~body version id (op_to_int Create) + encode ~name:vm.vname ~body version id (op_to_int Create) let destroy id version name = encode ~name version id (op_to_int Destroy)