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

remove naming struggle in vm_config and Log.hdr

This commit is contained in:
Hannes Mehnert 2018-10-12 19:45:46 +02:00
parent 7275073d6b
commit e413b8c99a
7 changed files with 35 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
app/vmm_log.ml
View File

@ -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

8
app/vmmc.ml
View File

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

4
src/vmm_asn.ml
View File

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

22
src/vmm_core.ml
View File

@ -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

22
src/vmm_engine.ml
View File

@ -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 ])

4
src/vmm_unix.ml
View File

@ -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

23
src/vmm_wire.ml
View File

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