adjustments

app/vmmc.ml

@@ -167,7 +167,7 @@ let remove_policy_cmd =
      `P "Removes a policy."]
   in
   Term.(ret (const remove_policy $ setup_log $ socket $ opt_vmname)),
-  Term.info "remove" ~doc ~man
+  Term.info "remove_policy" ~doc ~man
 
 let info_cmd =
   let doc = "information about VMs" in

src/vmm_asn.ml

@@ -628,13 +628,13 @@ let header =
            (required ~label:"sequence" int64)
            (required ~label:"id" (sequence_of utf8_string)))
 
-type success = [ `Empty | `String of string | `Policies of policy list | `Vms of vm_config list ]
+type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
 
 let pp_success ppf = function
   | `Empty -> Fmt.string ppf "success"
   | `String data -> Fmt.pf ppf "success: %s" data
-  | `Policies ps -> Fmt.(list ~sep:(unit "@.") pp_policy) ppf ps
+  | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps
-  | `Vms vms -> Fmt.(list ~sep:(unit "@.") pp_vm_config) ppf vms
+  | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
 
 type wire = header * [
     | `Command of wire_command
@@ -685,8 +685,14 @@ let wire =
                  (explicit 1 (choice4
                                 (explicit 0 null)
                                 (explicit 1 utf8_string)
-                                (explicit 2 (sequence_of policy_obj))
+                                (explicit 2 (sequence_of
-                                (explicit 3 (sequence_of vm_config))))
+                                               (sequence2
+                                                  (required ~label:"name" (sequence_of utf8_string))
+                                                  (required ~label:"policy" policy_obj))))
+                                (explicit 3 (sequence_of
+                                               (sequence2
+                                                  (required ~label:"name" (sequence_of utf8_string))
+                                                  (required ~label:"vm_config" vm_config))))))
                  (explicit 2 utf8_string))))
 
 let wire_of_cstruct, wire_to_cstruct = projections_of wire

src/vmm_asn.mli

@@ -219,7 +219,7 @@ type header = {
 
 type wire = header * [
     | `Command of wire_command
-    | `Success of [ `Empty | `String of string | `Policies of policy list | `Vms of vm_config list ]
+    | `Success of [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
     | `Failure of string ]
 
 val pp_wire : wire Fmt.t

src/vmm_engine.ml

@@ -122,26 +122,22 @@ let handle_command t (header, payload) =
   msg_to_err (
     let id = header.Vmm_asn.id in
     match payload with
-    | `Failure f ->
+    | `Command (`Policy_cmd pc) ->
-      Logs.warn (fun m -> m "ignoring failure %s" f) ;
+      begin match pc with
-      Ok (t, [], `End)
+        | `Policy_remove ->
-    | `Success _ ->
-      Logs.warn (fun m -> m "ignoring success") ;
-      Ok (t, [], `End)
-    | `Command (`Policy_cmd `Policy_remove) ->
           Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_asn.id) ;
           let resources = Vmm_resources.remove t.resources id in
           Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End)
-    | `Command (`Policy_cmd (`Policy_add policy)) ->
+        | `Policy_add policy ->
           Logs.debug (fun m -> m "insert policy %a" pp_id id) ;
           Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
           Ok ({ t with resources }, [ `Data (header, `Success (`String "added policy")) ], `End)
-    | `Command (`Policy_cmd `Policy_info) ->
+        | `Policy_info ->
           begin
             Logs.debug (fun m -> m "policy %a" pp_id id) ;
             let policies =
               Vmm_resources.fold t.resources id
-            (fun _ policies -> policies)
+                (fun _ _ policies -> policies)
                 (fun prefix policy policies-> (prefix, policy) :: policies)
                 []
             in
@@ -152,26 +148,27 @@ let handle_command t (header, payload) =
             | _ ->
               Ok (t, [ `Data (header, `Success (`Policies policies)) ], `End)
           end
-    | `Command (`Vm_cmd `Vm_info) ->
+      end
-        begin
+    | `Command (`Vm_cmd vc) ->
+      begin match vc with
+        | `Vm_info ->
           Logs.debug (fun m -> m "info %a" pp_id id) ;
           let vms =
             Vmm_resources.fold t.resources id
-              (fun vm vms -> vm :: vms)
+              (fun id vm vms -> (id, vm.config) :: vms)
               (fun _ _ vms-> vms)
               []
           in
-          match vms with
+          begin match vms with
             | [] ->
               Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ;
               Error (`Msg "info: not found")
             | _ ->
-            let vm_configs = List.map (fun vm -> vm.config) vms in
+              Ok (t, [ `Data (header, `Success (`Vms vms)) ], `End)
-            Ok (t, [ `Data (header, `Success (`Vms vm_configs)) ], `End)
           end
-    | `Command (`Vm_cmd (`Vm_create vm_config)) ->
+        | `Vm_create vm_config ->
           handle_create t header vm_config
-    | `Command (`Vm_cmd (`Vm_force_create vm_config)) ->
+        | `Vm_force_create vm_config ->
           let resources = Vmm_resources.remove t.resources id in
           if Vmm_resources.check_vm_policy resources id vm_config then
             begin match Vmm_resources.find_vm t.resources id with
@@ -189,7 +186,7 @@ let handle_command t (header, payload) =
             end
           else
             Error (`Msg "wouldn't match policy")
-    | `Command (`Vm_cmd `Vm_destroy) ->
+        | `Vm_destroy ->
           begin match Vmm_resources.find_vm t.resources id with
             | Some vm ->
               Vmm_unix.destroy vm ;
@@ -204,4 +201,7 @@ let handle_command t (header, payload) =
               Ok ({ t with tasks }, out, next)
             | None -> Error (`Msg "destroy: not found")
           end
-    | _ -> Error (`Msg "unknown command"))
+      end
+    | _ ->
+      Logs.err (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, payload)) ;
+      Error (`Msg "unknown command"))

src/vmm_resources.ml

@@ -33,7 +33,7 @@ let remove t name = Vmm_trie.remove name t
 let fold t name f g acc =
   Vmm_trie.fold name t (fun prefix entry acc ->
       match entry with
-      | Vm vm -> f vm acc
+      | Vm vm -> f prefix vm acc
       | Policy p -> g prefix p acc) acc
 
 (* we should hide this type and confirm the following invariant:

src/vmm_resources.mli

@@ -36,5 +36,6 @@ val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string
 val remove : t -> Vmm_core.id -> t
 
 (** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *)
-val fold : t -> Vmm_core.id -> (Vmm_core.vm -> 'a -> 'a) ->
+val fold : t -> Vmm_core.id ->
+  (Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) ->
   (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a