From 7c34c61d43075e4c76191bd4aafca34ba69a4d98 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Wed, 31 Oct 2018 22:40:09 +0100
Subject: [PATCH] vmmd_tls needs looping behaviour after adding a policy to
 start vm

---
 app/vmm_provision.ml |  3 +--
 app/vmmd.ml          | 32 ++++++++++++++++----------------
 src/vmm_vmmd.ml      |  2 +-
 src/vmm_vmmd.mli     |  1 +
 4 files changed, 19 insertions(+), 19 deletions(-)

diff --git a/app/vmm_provision.ml b/app/vmm_provision.ml
index 48b1580..8ff2615 100644
--- a/app/vmm_provision.ml
+++ b/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 ->
-     match nam with
+      with Not_found -> Error (`Msg "unable to discover certificate name")) >>= function
      | `CN name -> Ok name
      | _ -> Error (`Msg "cannot happen")) >>= fun certname ->
   timestamps delta >>= fun (valid_from, valid_until) ->
diff --git a/app/vmmd.ml b/app/vmmd.ml
index 6f264b9..ae074e8 100644
--- a/app/vmmd.ml
+++ b/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") ;
-  (Vmm_lwt.read_wire fd >>= function
+  let rec loop () =
+    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 _ ->
-          ()
-      | `Wait_and_create (task, next) ->
-        task >>= fun () ->
-        let state', data, n = next !state in
-        state := state' ;
-        process "wait and create" data >>= fun _ ->
-        (match n with
-         | `End -> Lwt.return_unit
-         | `Create cont -> create process cont)
-      | `Create cont ->
-        create process cont
-        (* data contained a write to console, we need to wait for its reply first *)
-  ) >>= fun () ->
+          process "wait" [ out ] >|= ignore
+        | `Wait_and_create (task, next) ->
+          task >>= fun () ->
+          let state', data, n = next !state in
+          state := state' ;
+          process "wait and create" data >>= fun _ ->
+          match n with
+          | `End -> Lwt.return_unit
+          | `Create cont -> create process cont >|= ignore
+  in
+  loop () >>= fun () ->
   Vmm_lwt.safe_close fd
 
 let init_sock sock =
diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml
index 585435d..7b32720 100644
--- a/src/vmm_vmmd.ml
+++ b/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) ;
diff --git a/src/vmm_vmmd.mli b/src/vmm_vmmd.mli
index 1c42cbe..53bc257 100644
--- a/src/vmm_vmmd.mli
+++ b/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 *