vmmd_tls needs looping behaviour after adding a policy to start vm

app/vmm_provision.ml

@@ -39,8 +39,7 @@ let sign ?dbname ?certname extensions issuer key csr delta =
    | Some x -> Ok x
    | None ->
      (try Ok (List.find (function `CN _ -> true | _ -> false) (X509.CA.info csr).X509.CA.subject)
-      with Not_found -> Error (`Msg "unable to discover certificate name")) >>= fun nam ->
+      with Not_found -> Error (`Msg "unable to discover certificate name")) >>= function
-     match nam with
      | `CN name -> Ok name
      | _ -> Error (`Msg "cannot happen")) >>= fun certname ->
   timestamps delta >>= fun (valid_from, valid_until) ->

app/vmmd.ml

@@ -72,8 +72,9 @@ let handle out fd addr =
       Logs.err (fun m -> m "error in process %s: %s" txt msg) ;
       Error ()
   in
-  Logs.debug (fun m -> m "now reading") ;
+  let rec loop () =
-  (Vmm_lwt.read_wire fd >>= function
+    Logs.debug (fun m -> m "now reading") ;
+    Vmm_lwt.read_wire fd >>= function
     | Error _ ->
       Logs.err (fun m -> m "error while reading") ;
       Lwt.return_unit
@@ -84,23 +85,22 @@ let handle out fd addr =
       process "handle_command" data >>= function
       | Error () -> Lwt.return_unit
       | Ok () -> match next with
+        | `Loop -> loop ()
         | `End -> Lwt.return_unit
+        | `Create cont -> create process cont
         | `Wait (task, out) ->
           task >>= fun () ->
-          process "wait" [ out ] >|= fun _ ->
+          process "wait" [ out ] >|= ignore
-          ()
+        | `Wait_and_create (task, next) ->
-      | `Wait_and_create (task, next) ->
+          task >>= fun () ->
-        task >>= fun () ->
+          let state', data, n = next !state in
-        let state', data, n = next !state in
+          state := state' ;
-        state := state' ;
+          process "wait and create" data >>= fun _ ->
-        process "wait and create" data >>= fun _ ->
+          match n with
-        (match n with
+          | `End -> Lwt.return_unit
-         | `End -> Lwt.return_unit
+          | `Create cont -> create process cont >|= ignore
-         | `Create cont -> create process cont)
+  in
-      | `Create cont ->
+  loop () >>= fun () ->
-        create process cont
-        (* data contained a write to console, we need to wait for its reply first *)
-  ) >>= fun () ->
   Vmm_lwt.safe_close fd
 
 let init_sock sock =

src/vmm_vmmd.ml

@@ -119,7 +119,7 @@ let handle_command t (header, payload) =
             Ok (t, [ reply (`String "no modification of policy") ], `End)
           else
             Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
-            Ok ({ t with resources }, [ reply (`String "added policy") ], `End)
+            Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop)
         | `Policy_info ->
           begin
             Logs.debug (fun m -> m "policy %a" pp_id id) ;

src/vmm_vmmd.mli

@@ -18,6 +18,7 @@ val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm ->
 val handle_command : 'a t -> Vmm_commands.wire ->
   'a t * out list *
   [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> `Msg of string ]) result
+  | `Loop
   | `End
   | `Wait of 'a * out
   | `Wait_and_create of 'a * ('a t -> 'a t * out list *