remove naming struggle in vm_config and Log.hdr

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

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
+  let argv = match boot_params with
-    | [ name ] -> [], name
-    | name::tl -> List.rev tl, name
-    | [] -> assert false
-  and 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 (

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 () ->

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 : id ;
-  vname : string ;
   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
+let location vm = match vm.vname with
-  | tld::rest -> tld, String.concat ~sep:"." (rest@[vm.vname])
+  | 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"
+  Fmt.pf ppf "%a cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
-    vm.vname vm.cpuid vm.requested_memory
+    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 : id ;
-    name : string ;
   }
 
   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

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 vm_config.vname then
-  (if Vmm_resources.exists t.resources full 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 ->
+          Vmm_resources.insert t.resources vm_config.vname vm >>= fun resources ->
-          let tasks = String.Map.add (string_of_id full) task t.tasks in
+          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 stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.config.vname in
-  let tasks = String.Map.remove (vm_id vm.config) t.tasks 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,
+  let t, logout = log t (Log.hdr vm.config.vname, `VM_stop (vm.pid, r))
-                         `VM_stop (vm.pid, r))
   in
   (t, [ `Stat stat_out ; logout ])
 

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 / (string_of_id vm.vname) + "img")),
-   (fun vm -> Fpath.(tmpdir / "fifo" / (vm_id vm))))
+   (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

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) ->
+    decode_id_ts cs >>= fun ((name, ts), off) ->
-    split_id id >>= fun (name, context) ->
+    Ok ({ Log.ts ; name }, Cstruct.shift cs off)
-    Ok ({ Log.ts ; context ; 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)
+    let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) in
-    and name = hdr.Log.context @ [ hdr.Log.name ]
+    encode ~name:hdr.name ~body version id (op_to_int Log)
-    in
-    encode ~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) ->
+    decode_strings buf >>= fun (vname, off) ->
-    Logs.debug (fun m -> m "vm_config id %a" pp_id id) ;
+    Logs.debug (fun m -> m "vm_config name %a" pp_id vname) ;
-    split_id id >>= fun (vname, prefix) ->
     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:vm.vname ~body version id (op_to_int Create)
-    encode ~name ~body version id (op_to_int Create)
 
   let destroy id version name =
     encode ~name version id (op_to_int Destroy)