wip, vmmc and vmmd talk with each other!

.merlin

@@ -5,6 +5,6 @@ S provision
 
 B _build/**
 
-PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex cstruct.ppx duration
+PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex duration
 PKG ptime ptime.clock.os ipaddr.unix decompress
 PKG lwt.unix

_tags

@@ -4,7 +4,6 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring
 "src" : include
 
 <src/vmm_compress.ml>: package(decompress)
-<src/vmm_wire.{ml,mli}>: package(ppx_cstruct)
 <src/vmm_asn.{ml,mli}>: package(asn1-combinators)
 <src/vmm_lwt.{ml,mli}>: package(lwt lwt.unix)
 <src/vmm_tls.{ml,mli}>: package(lwt tls.lwt)

app/vmm_client.ml

@@ -4,7 +4,7 @@ open Lwt.Infix
 
 open Vmm_core
 
-let my_version = `WV0
+let my_version = `WV2
 let command = ref 1
 
 let process db hdr data =

app/vmm_console.ml

@@ -13,21 +13,14 @@ open Lwt.Infix
 
 open Astring
 
-open Vmm_wire
+let my_version = `WV2
-open Vmm_wire.Console
-
-let my_version = `WV0
-
-let pp_sockaddr ppf = function
-  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
-  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
-                                         (Unix.string_of_inet_addr addr) port
 
 let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
 
 let active = ref String.Map.empty
 
 let read_console name ring channel () =
+  let id = Vmm_core.id_of_string name in
   Lwt.catch (fun () ->
       let rec loop () =
         Lwt_io.read_line channel >>= fun line ->
@@ -37,8 +30,10 @@ let read_console name ring channel () =
         (match String.Map.find name !active with
          | None -> Lwt.return_unit
          | Some fd ->
-           Vmm_lwt.write_raw fd (data my_version name t line) >>= function
+           Vmm_lwt.write_wire fd (Vmm_wire.Console.data my_version id t line) >>= function
-           | Error _ -> Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)
+           | Error _ ->
+             Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >|= fun () ->
+             active := String.Map.remove name !active
            | Ok () -> Lwt.return_unit) >>=
         loop
       in
@@ -70,7 +65,8 @@ let open_fifo name =
 
 let t = ref String.Map.empty
 
-let add_fifo name =
+let add_fifo id =
+  let name = Vmm_core.string_of_id id in
   open_fifo name >|= function
   | Some f ->
     let ring = Vmm_ring.create () in
@@ -82,63 +78,68 @@ let add_fifo name =
   | None ->
     Error (`Msg "opening")
 
-let attach s name =
+let attach s id =
-  Logs.debug (fun m -> m "attempting to attach %s" name) ;
+  let name = Vmm_core.string_of_id id in
+  Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ;
   match String.Map.find name !t with
   | None -> Lwt.return (Error (`Msg "not found"))
   | Some _ ->
     active := String.Map.add name s !active ;
     Lwt.return (Ok "attached")
 
-let detach name =
+let detach id =
+  let name = Vmm_core.string_of_id id in
   active := String.Map.remove name !active ;
   Lwt.return (Ok "removed")
 
 let history s name since =
-  match String.Map.find name !t with
+  match String.Map.find (Vmm_core.string_of_id name) !t with
-  | None -> Lwt.return (Rresult.R.error_msgf "ring %s not found (%d): %a"
+  | None -> Lwt.return (Rresult.R.error_msgf "ring %a not found (%d): %a"
-                          name (String.Map.cardinal !t)
+                          Vmm_core.pp_id name (String.Map.cardinal !t)
                           Fmt.(list ~sep:(unit ";") string)
                           (List.map fst (String.Map.bindings !t)))
   | Some r ->
     let entries = Vmm_ring.read_history r since in
     Logs.debug (fun m -> m "found %d history" (List.length entries)) ;
     Lwt_list.iter_s (fun (i, v) ->
-        Vmm_lwt.write_raw s (data my_version name i v) >|= fun _ -> ())
+        Vmm_lwt.write_wire s (Vmm_wire.Console.data my_version name i v) >|= fun _ -> ())
       entries >|= fun () ->
     Ok "success"
 
 let handle s addr () =
-  Logs.info (fun m -> m "handling connection %a" pp_sockaddr addr) ;
+  Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr addr) ;
   let rec loop () =
-    Vmm_lwt.read_exactly s >>= function
+    Vmm_lwt.read_wire s >>= function
     | Error (`Msg msg) ->
       Logs.err (fun m -> m "error while reading %s" msg) ;
       loop ()
     | Error _ ->
       Logs.err (fun m -> m "exception while reading") ;
       Lwt.return_unit
+    | Ok (hdr, _) when Vmm_wire.is_reply hdr ->
+      Logs.err (fun m -> m "unexpected reply") ;
+      loop ()
     | Ok (hdr, data) ->
-      (if not (version_eq hdr.version my_version) then
+      (if not (Vmm_wire.version_eq hdr.version my_version) then
          Lwt.return (Error (`Msg "ignoring data with bad version"))
        else
-         match decode_str data with
+         match Vmm_wire.decode_strings data with
          | Error e -> Lwt.return (Error e)
-         | Ok (name, off) ->
+         | Ok (id, off) -> match Vmm_wire.Console.int_to_op hdr.tag with
-           match Console.int_to_op hdr.tag with
+           | Some Vmm_wire.Console.Add_console -> add_fifo id
-           | Some Add_console -> add_fifo name
+           | Some Vmm_wire.Console.Attach_console -> attach s id
-           | Some Attach_console -> attach s name
+           | Some Vmm_wire.Console.Detach_console -> detach id
-           | Some Detach_console -> detach name
+           | Some Vmm_wire.Console.History ->
-           | Some History ->
+             (match Vmm_wire.decode_ptime ~off data with
-             (match decode_ts ~off data with
               | Error e -> Lwt.return (Error e)
-              | Ok since -> history s name since)
+              | Ok since -> history s id since)
-           | _ ->
+           | Some Vmm_wire.Console.Data -> Lwt.return (Error (`Msg "unexpected Data"))
+           | None ->
              Lwt.return (Error (`Msg "unknown command"))) >>= (function
-          | Ok msg -> Vmm_lwt.write_raw s (success ~msg hdr.id my_version)
+          | Ok msg -> Vmm_lwt.write_wire s (Vmm_wire.success ~msg my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag)
           | Error (`Msg msg) ->
             Logs.err (fun m -> m "error while processing command: %s" msg) ;
-            Vmm_lwt.write_raw s (fail ~msg hdr.id my_version)) >>= function
+            Vmm_lwt.write_wire s (Vmm_wire.fail ~msg my_version hdr.Vmm_wire.id)) >>= function
       | Ok () -> loop ()
       | Error _ ->
         Logs.err (fun m -> m "exception while writing to socket") ;

app/vmm_influxdb_stats.ml

@@ -142,9 +142,9 @@ end
 
 let my_version = `WV1
 
-let command = ref 1
+let command = ref 1L
 
-let (req : string IM.t ref) = ref IM.empty
+let (req : string IM64.t ref) = ref IM64.empty
 
 let str_of_e = function
   | `Eof -> "end of file"
@@ -192,26 +192,28 @@ let rec read_sock_write_tcp closing db c ?fd addr addrtype =
     else begin
       let open Vmm_wire in
       Logs.debug (fun m -> m "reading from unix socket") ;
-      Vmm_lwt.read_exactly c >>= function
+      Vmm_lwt.read_wire c >>= function
       | Error e ->
         Logs.err (fun m -> m "error %s while reading vmm socket (return)"
                      (str_of_e e)) ;
         closing := true ;
         safe_close fd
       | Ok (hdr, data) ->
-        if not (version_eq hdr.version my_version) then begin
-          Logs.err (fun m -> m "unknown wire protocol version") ;
-          closing := true ;
-          safe_close fd
-        end else
         let name =
-            try IM.find hdr.id !req
+          try IM64.find hdr.id !req
           with Not_found -> "not found"
         in
-          req := IM.remove hdr.id !req ;
+        req := IM64.remove hdr.id !req ;
-          begin match Stats.int_to_op hdr.tag with
+        (if not (version_eq hdr.version my_version) then begin
-            | Some Stats.Stat_reply ->
+            Logs.err (fun m -> m "unknown wire protocol version") ;
-              begin match Vmm_wire.Stats.decode_stats (Cstruct.of_string data) with
+            closing := true ;
+            safe_close fd >|= fun () ->
+            None
+          end else if Vmm_wire.is_fail hdr then begin
+           Logs.err (fun m -> m "failed to retrieve statistics for %s" name) ;
+           Lwt.return (Some fd)
+         end else if Vmm_wire.is_reply hdr then
+           begin match Vmm_wire.Stats.decode_stats data with
              | Error (`Msg msg) ->
                Logs.warn (fun m -> m "error %s while decoding stats %s, ignoring"
                              msg name) ;
@@ -222,7 +224,7 @@ let rec read_sock_write_tcp closing db c ?fd addr addrtype =
                let taps = List.map (P.encode_if name) ifs in
                let out = (String.concat ~sep:"\n" (ru :: vmm :: taps)) ^ "\n" in
                Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ;
-                  Vmm_lwt.write_raw fd out >>= function
+               Vmm_lwt.write_wire fd (Cstruct.of_string out) >>= function
                | Ok () ->
                  Logs.debug (fun m -> m "wrote successfully") ;
                  Lwt.return (Some fd)
@@ -232,13 +234,10 @@ let rec read_sock_write_tcp closing db c ?fd addr addrtype =
                  safe_close fd >|= fun () ->
                  None
            end
-            | _ when hdr.tag = fail_tag ->
+         else begin
-              Logs.err (fun m -> m "failed to retrieve statistics for %s" name) ;
+           Logs.err (fun m -> m "unhandled tag %lu for %s" hdr.tag name) ;
            Lwt.return (Some fd)
-            | _ ->
+         end) >>= fun fd ->
-              Logs.err (fun m -> m "unhandled tag %d for %s" hdr.tag name) ;
-              Lwt.return (Some fd)
-          end >>= fun fd ->
         read_sock_write_tcp closing db c ?fd addr addrtype
     end
 
@@ -252,12 +251,12 @@ let rec query_sock closing prefix db c interval =
         | Error e -> Lwt.return (Error e)
         | Ok () ->
           let id = identifier id in
-          let id = match prefix with None -> id | Some p -> p ^ "." ^ id in
+          let id = match prefix with None -> [ id ] | Some p -> [ p ; id ] in
           let request = Vmm_wire.Stats.stat !command my_version id in
-          req := IM.add !command name !req ;
+          req := IM64.add !command name !req ;
-          incr command ;
+          command := Int64.succ !command  ;
-          Logs.debug (fun m -> m "%d requesting %s via socket" !command id) ;
+          Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id id) ;
-          Vmm_lwt.write_raw c request)
+          Vmm_lwt.write_wire c request)
       (Ok ()) db >>= function
     | Error e ->
       Logs.err (fun m -> m "error %s while writing to vmm socket" (str_of_e e)) ;

app/vmm_log.ml

@@ -14,14 +14,72 @@ open Lwt.Infix
 
 open Astring
 
-open Vmm_wire
+let my_version = `WV2
-open Vmm_wire.Log
 
-let my_version = `WV0
+type t = N of Lwt_unix.file_descr list * t String.Map.t
 
-let write_complete s str =
+let empty = N ([], String.Map.empty)
-  let l = String.length str in
+
-  let b = Bytes.unsafe_of_string str in
+let insert id fd t =
+  let rec go (N (fds, m)) = function
+    | [] -> N ((fd :: fds), m)
+    | x::xs ->
+      let n = match String.Map.find_opt x m with
+        | None -> empty
+        | Some n -> n
+      in
+      let entry = go n xs in
+      N (fds, String.Map.add x entry m)
+  in
+  go t id
+
+let remove id fd t =
+  let rec go (N (fds, m)) = function
+    | [] ->
+      begin match List.filter (fun fd' -> fd <> fd') fds with
+        | [] -> None
+        | fds' -> Some (N (fds', m))
+      end
+    | x::xs ->
+      let n' = match String.Map.find_opt x m with
+        | None -> None
+        | Some n -> go n xs
+      in
+      let m' = match n' with
+        | None -> String.Map.remove x m
+        | Some entry -> String.Map.add x entry m
+      in
+      if String.Map.is_empty m' && fds = [] then None else Some (N (fds, m'))
+  in
+  match go t id with
+  | None -> empty
+  | Some n -> n
+
+let collect id t =
+  let rec go acc prefix (N (fds, m)) =
+    let acc' =
+      let here = List.map (fun fd -> (prefix, fd)) fds in
+      here @ acc
+    in
+    function
+    | [] -> acc'
+    | x::xs ->
+      match String.Map.find_opt x m with
+      | None -> acc'
+      | Some n -> go acc' (prefix @ [ x ]) n xs
+  in
+  go [] [] t id
+
+let broadcast prefix data t =
+  Lwt_list.fold_left_s (fun t (id, s) ->
+      Vmm_lwt.write_wire s data >|= function
+      | Ok () -> t
+      | Error `Exception -> remove id s t)
+    t (collect prefix t)
+
+let write_complete s cs =
+  let l = Cstruct.len cs in
+  let b = Cstruct.to_bytes cs in
   let rec w off =
     let len = l - off in
     Lwt_unix.write s b off len >>= fun n ->
@@ -29,110 +87,141 @@ let write_complete s str =
   in
   w 0
 
-let pp_sockaddr ppf = function
+let write_to_file file =
-  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
+  let mvar = Lwt_mvar.create_empty () in
-  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
+  let rec write_loop ?(retry = true) ?data ?fd () =
-                                         (Unix.string_of_inet_addr addr) port
+    match fd with
+    | None when retry ->
+      Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd ->
+      write_loop ~retry:false ?data ~fd ()
+    | None ->
+      Logs.err (fun m -> m "retry is false, exiting") ;
+      Lwt.return_unit
+    | Some fd ->
+      (match data with
+       | None -> Lwt_mvar.take mvar
+       | Some d -> Lwt.return d) >>= fun data ->
+      Lwt.catch
+        (fun () -> write_complete fd data >|= fun () -> (true, None, Some fd))
+        (fun e ->
+           Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ;
+           Vmm_lwt.safe_close fd >|= fun () ->
+           (retry, Some data, None)) >>= fun (retry, data, fd) ->
+      write_loop ~retry ?data ?fd ()
+  in
+  mvar, write_loop
 
-let handle fd ring s addr () =
+(* TODO:
-  Logs.info (fun m -> m "handling connection from %a" pp_sockaddr addr) ;
+   - should there be an unsubscribe <prefix> command?
-  let str = Fmt.strf "%a: CONNECT\n" (Ptime.pp_human ~tz_offset_s:0 ()) (Ptime_clock.now ()) in
+   - should there be acks for history/datain?
-  write_complete fd str >>= fun () ->
+ *)
+
+let tree = ref empty
+
+let bcast = ref 0L
+
+let handle mvar ring s addr () =
+  Logs.info (fun m -> m "handling connection from %a" Vmm_lwt.pp_sockaddr addr) ;
+  let str = Fmt.strf "%a: CONNECT\n" (Ptime.pp_human ()) (Ptime_clock.now ()) in
+  Lwt_mvar.put mvar (Cstruct.of_string str) >>= fun () ->
   let rec loop () =
-    Vmm_lwt.read_exactly s >>= function
+    Vmm_lwt.read_wire s >>= function
     | Error (`Msg e) ->
       Logs.err (fun m -> m "error while reading %s" e) ;
       loop ()
     | Error _ ->
       Logs.err (fun m -> m "exception while reading") ;
       Lwt.return_unit
-    | Ok (hdr, data) ->
+    | Ok (hdr, _) when Vmm_wire.is_reply hdr ->
-      let out =
+      Logs.warn (fun m -> m "ignoring reply") ;
-        (if not (version_eq hdr.version my_version) then
+      loop ()
-           Error (`Msg "unknown version")
+    | Ok (hdr, _) when not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) ->
-         else match int_to_op hdr.tag with
+      Logs.warn (fun m -> m "unsupported version") ;
-           | Some Data ->
+      Lwt.return_unit
-             (match decode_ts data with
+    | Ok (hdr, data) -> match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with
-              | Ok ts -> Vmm_ring.write ring (ts, data)
+      | Some Vmm_wire.Log.Log ->
-              | Error _ ->
+        begin match Vmm_wire.Log.decode_log_hdr data with
-                Logs.warn (fun m -> m "ignoring error while decoding timestamp %s" data)) ;
+          | Error (`Msg err) ->
-             Ok (`Data data)
+            Logs.warn (fun m -> m "ignoring error %s while decoding log" err) ;
-           | Some History ->
+            loop ()
-             begin match decode_str data with
-               | Error e -> Error e
-               | Ok (str, off) -> match decode_ts ~off data with
-                 | Error e -> Error e
-                 | Ok ts ->
-                   let elements = Vmm_ring.read_history ring ts in
-                   let res = List.fold_left (fun acc (_, x) ->
-                       match Vmm_wire.Log.decode_log_hdr (Cstruct.of_string x) with
           | Ok (hdr, _) ->
-                         Logs.debug (fun m -> m "found an entry: %a" (Vmm_core.Log.pp_hdr []) hdr) ;
+            Vmm_ring.write ring (hdr.Vmm_core.Log.ts, Cstruct.to_string data) ;
-                         if String.equal str (Vmm_core.string_of_id hdr.Vmm_core.Log.context) then
+            Lwt_mvar.put mvar data >>= fun () ->
-                           x :: acc
+            let data' = Vmm_wire.encode ~body:data my_version !bcast (Vmm_wire.Log.op_to_int Vmm_wire.Log.Broadcast) in
-                         else
+            bcast := Int64.succ !bcast ;
-                           acc
+            broadcast hdr.Vmm_core.Log.context data' !tree >>= fun tree' ->
+            tree := tree' ;
+            loop ()
+        end
+      | Some Vmm_wire.Log.History ->
+        begin match Vmm_wire.decode_id_ts data with
+          | Error (`Msg err) ->
+            Logs.warn (fun m -> m "ignoring error %s while decoding history" err) ;
+            loop ()
+          | Ok ((sub, ts), _) ->
+            let elements = Vmm_ring.read_history ring ts in
+            let res =
+              List.fold_left (fun acc (_, x) ->
+                  let cs = Cstruct.of_string x in
+                  match Vmm_wire.Log.decode_log_hdr cs with
+                  | Ok (hdr, _) when Vmm_core.is_sub_id ~super:hdr.Vmm_core.Log.context ~sub ->
+                    cs :: acc
                   | _ -> acc)
                 [] elements
             in
             (* just need a wrapper in tag = Log.Data, id = reqid *)
-                   let out =
+            Lwt_list.fold_left_s (fun r body ->
-                     List.fold_left (fun acc x ->
+                match r with
-                         let length = String.length x in
-                         let hdr = Vmm_wire.create_header { length ; id = hdr.id ; tag = op_to_int Data ; version = my_version } in
-                         (Cstruct.to_string hdr ^ x) :: acc)
-                       [] (List.rev res)
-                   in
-                   Ok (`Out out)
-             end
-           | _ -> Error (`Msg "unknown command"))
-      in
-      match out with
-      | Error (`Msg msg) ->
-        begin
-          Logs.err (fun m -> m "error while processing: %s" msg) ;
-          Vmm_lwt.write_raw s (fail ~msg hdr.id my_version) >>= function
-          | Error _ -> Logs.err (fun m -> m "error0 while writing") ; Lwt.return_unit
-          | Ok () -> loop ()
-        end
-      | Ok (`Data data) ->
-        begin
-          write_complete fd data >>= fun () ->
-          Vmm_lwt.write_raw s (success hdr.id my_version) >>= function
-          | Error _ -> Logs.err (fun m -> m "error1 while writing") ; Lwt.return_unit
-          | Ok () -> loop ()
-        end
-      | Ok (`Out datas) ->
-        Lwt_list.fold_left_s (fun r x -> match r with
-            | Error e -> Lwt.return (Error e)
-            | Ok () -> Vmm_lwt.write_raw s x)
-          (Ok ()) datas >>= function
-        | Error _ -> Logs.err (fun m -> m "error2 while writing") ; Lwt.return_unit
                 | Ok () ->
-          Vmm_lwt.write_raw s (success hdr.id my_version) >>= function
+                  let data = Vmm_wire.encode ~body my_version hdr.Vmm_wire.id (Vmm_wire.Log.op_to_int Vmm_wire.Log.Log) in
-          | Error _ -> Logs.err (fun m -> m "error3 while writing") ; Lwt.return_unit
+                  Vmm_lwt.write_wire s data
+                | Error e -> Lwt.return (Error e))
+              (Ok ()) res >>= function
             | Ok () -> loop ()
+            | Error _ ->
+              Logs.err (fun m -> m "error while sending data in history") ;
+              Lwt.return_unit
+        end
+      | Some Vmm_wire.Log.Subscribe ->
+        begin match Vmm_wire.decode_strings data with
+          | Error (`Msg err) ->
+            Logs.warn (fun m -> m "ignoring error %s while decoding subscribe" err) ;
+            loop ()
+          | Ok (id, _) ->
+            tree := insert id s !tree ;
+            let out = Vmm_wire.success my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in
+            Vmm_lwt.write_wire s out >>= function
+            | Ok () -> loop ()
+            | Error _ ->
+              Logs.err (fun m -> m "error while sending reply for subscribe") ;
+              Lwt.return_unit
+        end
+      | _ ->
+        Logs.err (fun m -> m "unknown command") ;
+        loop ()
   in
   loop () >>= fun () ->
-  Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit)
+  Vmm_lwt.safe_close s
+  (* should remove all the s from the tree above *)
 
 let jump _ file sock =
   Sys.(set_signal sigpipe Signal_ignore) ;
   Lwt_main.run
-    (Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd ->
+    ((Lwt_unix.file_exists sock >>= function
-     (Lwt_unix.file_exists sock >>= function
        | true -> Lwt_unix.unlink sock
        | false -> Lwt.return_unit) >>= fun () ->
      let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
      Lwt_unix.(bind s (ADDR_UNIX sock)) >>= fun () ->
      Lwt_unix.listen s 1 ;
      let ring = Vmm_ring.create () in
+     let mvar, writer = write_to_file file in
      let rec loop () =
        Lwt_unix.accept s >>= fun (cs, addr) ->
-       Lwt.async (handle fd ring cs addr) ;
+       Lwt.async (handle mvar ring cs addr) ;
        loop ()
      in
-     loop ())
+     Lwt.pick [ loop () ; writer () ]) ;
+  `Ok ()
 
 let setup_log style_renderer level =
   Fmt_tty.setup_std_outputs ?style_renderer ();

app/vmm_tls_endpoint.ml

@@ -0,0 +1,172 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+let write_tls state t data =
+  Vmm_tls.write_tls (fst t) data >>= function
+  | Ok () -> Lwt.return_unit
+  | Error `Exception ->
+    let state', out = Vmm_engine.handle_disconnect !state t in
+    state := state' ;
+    Lwt_list.iter_s (fun (s, data) -> write_raw s data) out >>= fun () ->
+    Tls_lwt.Unix.close (fst t)
+
+let to_ipaddr (_, sa) = match sa with
+  | Lwt_unix.ADDR_UNIX _ -> invalid_arg "cannot convert unix address"
+  | Lwt_unix.ADDR_INET (addr, port) -> Ipaddr_unix.V4.of_inet_addr_exn addr, port
+
+let pp_sockaddr ppf (_, sa) = match sa with
+  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
+  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
+                                         (Unix.string_of_inet_addr addr) port
+
+
+let server_socket port =
+  let open Lwt_unix in
+  let s = socket PF_INET SOCK_STREAM 0 in
+  set_close_on_exec s ;
+  setsockopt s SO_REUSEADDR true ;
+  bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () ->
+  listen s 10 ;
+  Lwt.return s
+
+let rec read_log state s =
+  Vmm_lwt.read_exactly s >>= function
+  | Error (`Msg msg) ->
+    Logs.err (fun m -> m "reading log error %s" msg) ;
+    read_log state s
+  | Error _ ->
+    Logs.err (fun m -> m "exception while reading log") ;
+    invalid_arg "log socket communication issue"
+  | Ok (hdr, data) ->
+    let state', outs = Vmm_engine.handle_log !state hdr data in
+    state := state' ;
+    process state outs >>= fun () ->
+    read_log state s
+
+let rec read_cons state s =
+  Vmm_lwt.read_exactly s >>= function
+  | Error (`Msg msg) ->
+    Logs.err (fun m -> m "reading console error %s" msg) ;
+    read_cons state s
+  | Error _ ->
+    Logs.err (fun m -> m "exception while reading console socket") ;
+    invalid_arg "console socket communication issue"
+  | Ok (hdr, data) ->
+    let state', outs = Vmm_engine.handle_cons !state hdr data in
+    state := state' ;
+    process state outs >>= fun () ->
+    read_cons state s
+
+let rec read_stats state s =
+  Vmm_lwt.read_exactly s >>= function
+  | Error (`Msg msg) ->
+    Logs.err (fun m -> m "reading stats error %s" msg) ;
+    read_stats state s
+  | Error _ ->
+    Logs.err (fun m -> m "exception while reading stats") ;
+    Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
+    invalid_arg "stat socket communication issue"
+  | Ok (hdr, data) ->
+    let state', outs = Vmm_engine.handle_stat !state hdr data in
+    state := state' ;
+    process state outs >>= fun () ->
+    read_stats state s
+
+let cmp_s (_, a) (_, b) =
+  let open Lwt_unix in
+  match a, b with
+  | ADDR_UNIX str, ADDR_UNIX str' -> String.compare str str' = 0
+  | ADDR_INET (addr, port), ADDR_INET (addr', port') ->
+    port = port' &&
+    String.compare (Unix.string_of_inet_addr addr) (Unix.string_of_inet_addr addr') = 0
+  | _ -> false
+
+let jump _ cacert cert priv_key port =
+  Sys.(set_signal sigpipe Signal_ignore) ;
+  Lwt_main.run
+    (Nocrypto_entropy_lwt.initialize () >>= fun () ->
+     (init_sock Vmm_core.tmpdir "cons" >|= function
+       | None -> invalid_arg "cannot connect to console socket"
+       | Some c -> c) >>= fun c ->
+     init_sock Vmm_core.tmpdir "stat" >>= fun s ->
+     (init_sock Vmm_core.tmpdir "log" >|= function
+       | None -> invalid_arg "cannot connect to log socket"
+       | Some l -> l) >>= fun l ->
+     server_socket port >>= fun socket ->
+     X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
+     X509_lwt.certs_of_pem cacert >>= (function
+         | [ ca ] -> Lwt.return ca
+         | _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca ->
+     let config =
+       Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
+              ~reneg:true ~certificates:(`Single cert) ())
+     in
+     (match Vmm_engine.init cmp_s c s l with
+      | Ok s -> Lwt.return s
+      | Error (`Msg m) -> Lwt.fail_with m) >>= fun t ->
+     let state = ref t in
+     Lwt.async (fun () -> read_cons state c) ;
+     (match s with
+      | None -> ()
+      | Some s -> Lwt.async (fun () -> read_stats state s)) ;
+     Lwt.async (fun () -> read_log state l) ;
+     Lwt.async stats_loop ;
+     let rec loop () =
+       Lwt.catch (fun () ->
+           Lwt_unix.accept socket >>= fun (fd, addr) ->
+           Lwt_unix.set_close_on_exec fd ;
+           Lwt.catch
+             (fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr))
+             (fun exn ->
+                Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () ->
+                Lwt.fail exn) >>= fun t ->
+           Lwt.async (fun () ->
+               Lwt.catch
+                 (fun () -> handle ca state t)
+                 (fun e ->
+                    Logs.err (fun m -> m "error while handle() %s"
+                                 (Printexc.to_string e)) ;
+                    Lwt.return_unit)) ;
+           loop ())
+         (function
+           | Unix.Unix_error (e, f, _) ->
+             Logs.err (fun m -> m "Unix error %s in %s" (Unix.error_message e) f) ;
+             loop ()
+           | Tls_lwt.Tls_failure a ->
+             Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
+             loop ()
+           | exn ->
+             Logs.err (fun m -> m "exception %s" (Printexc.to_string exn)) ;
+             loop ())
+     in
+     loop ())
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
+
+open Cmdliner
+
+let setup_log =
+  Term.(const setup_log
+        $ Fmt_cli.style_renderer ()
+        $ Logs_cli.level ())
+
+let cacert =
+  let doc = "CA certificate" in
+  Arg.(required & pos 0 (some file) None & info [] ~doc)
+
+let cert =
+  let doc = "Certificate" in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let key =
+  let doc = "Private key" in
+  Arg.(required & pos 2 (some file) None & info [] ~doc)
+
+let port =
+  let doc = "TCP listen port" in
+  Arg.(value & opt int 1025 & info [ "port" ] ~doc)
+

app/vmmc.ml

@@ -0,0 +1,264 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+open Vmm_core
+
+let my_version = `WV2
+let my_command = 1L
+
+(*
+let process db hdr data =
+  let open Vmm_wire in
+  let open Rresult.R.Infix in
+  if not (version_eq hdr.version my_version) then
+    Logs.err (fun m -> m "unknown wire protocol version")
+  else
+    let r =
+      match hdr.tag with
+      | x when x = Client.stat_msg_tag ->
+        Client.decode_stat data >>= fun (ru, vmm, ifd) ->
+        Logs.app (fun m -> m "statistics: %a %a %a"
+                     pp_rusage ru
+                     Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm
+                     Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ;
+        Ok ()
+      | x when x = Client.log_msg_tag ->
+        Client.decode_log data >>= fun log ->
+        Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ;
+        Ok ()
+      | x when x = Client.console_msg_tag ->
+        Client.decode_console data >>= fun (name, ts, msg) ->
+        Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ;
+        Ok ()
+      | x when x = Client.info_msg_tag ->
+        Client.decode_info data >>= fun vms ->
+        List.iter (fun (name, cmd, pid, taps) ->
+            Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name)
+                         cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
+          vms ;
+        Ok ()
+      | x when x = fail_tag ->
+        decode_str data >>= fun (msg, _) ->
+        Logs.err (fun m -> m "failed %s" msg) ;
+        Ok ()
+      | x when x = success_tag ->
+        decode_str data >>= fun (msg, _) ->
+        Logs.app (fun m -> m "success %s" msg) ;
+        Ok ()
+      | x -> Rresult.R.error_msgf "unknown header tag %02X" x
+    in
+    match r with
+    | Ok () -> ()
+    | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg)
+*)
+
+let process fd =
+  Vmm_lwt.read_wire fd >|= function
+  | Error _ -> Error ()
+  | Ok (hdr, data) ->
+    if not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) then begin
+      Logs.err (fun m -> m "unknown wire protocol version") ;
+      Error ()
+    end else begin
+      if Vmm_wire.is_fail hdr then begin
+        let msg = match Vmm_wire.decode_string data with
+          | Ok (msg, _) -> Some msg
+          | Error _ -> None
+        in
+        Logs.err (fun m -> m "command failed %a" Fmt.(option ~none:(unit "") string) msg) ;
+        Error ()
+      end else if Vmm_wire.is_reply hdr && hdr.Vmm_wire.id = my_command then
+        Ok data
+      else begin
+        Logs.err (fun m -> m "received unexpected data") ;
+        Error ()
+      end
+    end
+
+let connect socket =
+  let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+  Lwt_unix.set_close_on_exec c ;
+  Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket) >|= fun () ->
+  c
+
+let info_ _ socket name =
+  Lwt_main.run (
+    connect socket >>= fun fd ->
+    let name' = Astring.String.cuts ~empty:false ~sep:"." name in
+    let info = Vmm_wire.Vm.info my_command my_version name' in
+    (Vmm_lwt.write_wire fd info >>= function
+      | Ok () ->
+        (process fd >|= function
+          | Error () -> ()
+          | Ok data ->
+            match Vmm_wire.Vm.decode_vms data with
+            | Ok (vms, _) ->
+              List.iter (fun (id, memory, cmd, pid, taps) ->
+                  Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a"
+                               pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
+                vms
+            | Error (`Msg msg) ->
+              Logs.err (fun m -> m "error %s while decoding vms" msg))
+      | Error `Exception -> Lwt.return_unit) >>= fun () ->
+    Vmm_lwt.safe_close fd
+  ) ;
+  `Ok ()
+
+let really_destroy socket name =
+  connect socket >>= fun fd ->
+  let cmd = Vmm_wire.Vm.destroy my_command my_version (Astring.String.cuts ~empty:false ~sep:"." name) in
+  (Vmm_lwt.write_wire fd cmd >>= function
+    | Ok () ->
+      (process fd >|= function
+        | Error () -> ()
+        | Ok _ -> Logs.app (fun m -> m "destroyed VM"))
+    | Error `Exception -> Lwt.return_unit) >>= fun () ->
+  Vmm_lwt.safe_close fd
+
+let destroy _ socket name =
+  Lwt_main.run (really_destroy socket name) ;
+  `Ok ()
+
+let create _ socket force name image cpuid requested_memory boot_params block_device network =
+  let image' = match Bos.OS.File.read (Fpath.v image) with
+    | Ok data -> data
+    | Error (`Msg s) -> invalid_arg s
+  in
+  let prefix, vname = match List.rev (Astring.String.cuts ~empty:false ~sep:"." name) with
+    | [ name ] -> [], name
+    | name::tl -> List.rev tl, name
+    | [] -> assert false
+  and argv = match boot_params with
+    | [] -> None
+    | xs -> Some xs
+  and vmimage = `Ukvm_amd64, Cstruct.of_string image'
+  in
+  let vm_config = {
+    prefix ; vname ; cpuid ; requested_memory ; block_device ; network ;
+    vmimage ; argv
+  } in
+  Lwt_main.run (
+    (if force then
+       really_destroy socket name
+     else
+       Lwt.return_unit) >>= fun () ->
+    connect socket >>= fun fd ->
+    let vm = Vmm_wire.Vm.create my_command my_version vm_config in
+    (Vmm_lwt.write_wire fd vm >>= function
+      | Error `Exception -> Lwt.return_unit
+      | Ok () -> process fd >|= function
+        | Ok _ -> Logs.app (fun m -> m "successfully started VM")
+        | Error () -> ()) >>= fun () ->
+    Vmm_lwt.safe_close fd
+  ) ;
+  `Ok ()
+
+let help _ _ man_format cmds = function
+  | None -> `Help (`Pager, None)
+  | Some t when List.mem t cmds -> `Help (man_format, Some t)
+  | Some _ -> List.iter print_endline cmds; `Ok ()
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
+
+open Cmdliner
+
+let setup_log =
+  Term.(const setup_log
+        $ Fmt_cli.style_renderer ()
+        $ Logs_cli.level ())
+
+let socket =
+  let doc = "Socket to connect to" in
+  let sock = Fpath.(to_string (Vmm_core.tmpdir / "vmmd" + "sock")) in
+  Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
+
+let force =
+  let doc = "force VM creation." in
+  Arg.(value & flag & info [ "f" ; "force" ] ~doc)
+
+let image =
+  let doc = "File of virtual machine image." in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let vm_name =
+  let doc = "Name virtual machine config." in
+  Arg.(required & pos 0 (some string) None & info [] ~doc)
+
+let destroy_cmd =
+  let doc = "destroys a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Destroy a virtual machine."]
+  in
+  Term.(ret (const destroy $ setup_log $ socket $ vm_name)),
+  Term.info "destroy" ~doc ~man
+
+let info_cmd =
+  let doc = "information about VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about VMs."]
+  in
+  Term.(ret (const info_ $ setup_log $ socket $ vm_name)),
+  Term.info "info" ~doc ~man
+
+let cpu =
+  let doc = "CPUid" in
+  Arg.(value & opt int 0 & info [ "cpu" ] ~doc)
+
+let mem =
+  let doc = "Memory to provision" in
+  Arg.(value & opt int 512 & info [ "mem" ] ~doc)
+
+let args =
+  let doc = "Boot arguments" in
+  Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
+
+let block =
+  let doc = "Block device name" in
+  Arg.(value & opt (some string) None & info [ "block" ] ~doc)
+
+let net =
+  let doc = "Network device" in
+  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
+
+let create_cmd =
+  let doc = "creates a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Creates a virtual machine."]
+  in
+  Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)),
+  Term.info "create" ~doc ~man
+
+let help_cmd =
+  let topic =
+    let doc = "The topic to get help on. `topics' lists the topics." in
+    Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
+  in
+  let doc = "display help about vmmc" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Prints help about conex commands and subcommands"]
+  in
+  Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ topic)),
+  Term.info "help" ~doc ~man
+
+let default_cmd =
+  let doc = "VMM client" in
+  let man = [
+    `S "DESCRIPTION" ;
+    `P "$(tname) connects to vmmd via a local socket" ]
+  in
+  Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
+  Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man
+
+let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ]
+
+let () =
+  match Term.eval_choice default_cmd cmds
+  with `Ok () -> exit 0 | _ -> exit 1

app/vmmd.ml

@@ -16,136 +16,86 @@ let pp_stats ppf s =
 
 open Lwt.Infix
 
-let write_raw s data =
+type out = [
-  Vmm_lwt.write_raw s data >|= fun _ -> ()
+  | `Cons of Cstruct.t
+  | `Stat of Cstruct.t
+  | `Log of Cstruct.t
+]
 
-let write_tls state t data =
+let handle state out c_fd fd addr =
-  Vmm_tls.write_tls (fst t) data >>= function
+  (* out is for `Log | `Stat | `Cons (including reconnect semantics) *)
-  | Ok () -> Lwt.return_unit
+  (* need to handle data out (+ die on write failure) *)
-  | Error `Exception ->
+  Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
-    let state', out = Vmm_engine.handle_disconnect !state t in
+  (* now we need to read a packet and handle it
-    state := state' ;
+    (1)
-    Lwt_list.iter_s (fun (s, data) -> write_raw s data) out >>= fun () ->
+     (a) easy for info (look up name/prefix in resources)
-    Tls_lwt.Unix.close (fst t)
+     (b) destroy looks up vm in resources, executes kill (wait for pid will do the cleanup)
-
+         logs "destroy issued"
-let to_ipaddr (_, sa) = match sa with
+     (c) create initiates the vm startup procedure:
-  | Lwt_unix.ADDR_UNIX _ -> invalid_arg "cannot convert unix address"
+         write image file, create fifo, create tap(s), send fifo to console
-  | Lwt_unix.ADDR_INET (addr, port) -> Ipaddr_unix.V4.of_inet_addr_exn addr, port
+         -- Lwt effects happen (console) --
-
+         executes ukvm-bin + waiter, send stats pid and taps, inserts await into state, logs "created vm"
-let pp_sockaddr ppf (_, sa) = match sa with
+         -- Lwt effects happen (stats, logs, wait_and_clear) --
-  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
+    (2) goto (1)
-  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
+  *)
-                                         (Unix.string_of_inet_addr addr) port
+  let process xs =
-
+    Lwt_list.iter_p (function
-let process state xs =
+        | #out as o -> out o
-  Lwt_list.iter_s (function
+        | `Data cs ->
-      | `Raw (s, str) -> write_raw s str
+          (* rather: terminate connection *)
-      | `Tls (s, str) -> write_tls state s str)
+          Vmm_lwt.write_wire fd cs >|= fun _ -> ()) xs
-    xs
-
-let handle ca state t =
-  Logs.debug (fun m -> m "connection from %a" pp_sockaddr t) ;
-  let authenticator =
-    let time = Ptime_clock.now () in
-    X509.Authenticator.chain_of_trust ~time ~crls:!state.Vmm_engine.crls [ca]
   in
-  Lwt.catch
+  Logs.debug (fun m -> m "now reading") ;
-    (fun () -> Tls_lwt.Unix.reneg ~authenticator (fst t))
+  (Vmm_lwt.read_wire fd >>= function
-    (fun e ->
+    | Error _ ->
-       (match e with
+      Logs.err (fun m -> m "error while reading") ;
-        | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a))
+      Lwt.return_unit
-        | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f))
+    | Ok (hdr, buf) ->
-        | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ;
+      Logs.debug (fun m -> m "read sth") ;
-       Tls_lwt.Unix.close (fst t) >>= fun () ->
+      let state', data, next = Vmm_engine.handle_command !state hdr buf in
-       Lwt.fail e) >>= fun () ->
-  (match Tls_lwt.Unix.epoch (fst t) with
-   | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
-   | `Error ->
-     Tls_lwt.Unix.close (fst t) >>= fun () ->
-     Lwt.fail_with "error while getting epoch") >>= fun chain ->
-  match Vmm_engine.handle_initial !state t (to_ipaddr t) chain ca with
-  | Ok (state', outs, next) ->
       state := state' ;
-    process state outs >>= fun () ->
+      process data >>= fun () ->
-    begin match next with
+      match next with
-      | `Create (task, next) ->
+      | `End -> Lwt.return_unit
-        (match task with
+      | `Wait (task, out) -> task >>= fun () -> process out
-         | None -> Lwt.return_unit
+      | `Create cont ->
-         | Some (kill, wait) -> kill () ; wait) >>= fun () ->
+        (* data contained a write to console, we need to wait for its reply first *)
+        Vmm_lwt.read_wire c_fd >>= function
+        | Ok (_, data) when Vmm_wire.is_fail hdr ->
+          Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ;
+          Lwt.return_unit
+        | Ok (_, _) when Vmm_wire.is_reply hdr ->
+          (* assert hdr.id = id! *)
+          (* TODO slightly more tricky, since we need to "Vmm_lwt.wait_and_clear" in here *)
           let await, wakeme = Lwt.wait () in
-        begin match next !state await with
+          begin match cont !state await with
-          | Ok (state', outs, cont) ->
+            | Error (`Msg msg) ->
-            state := state' ;
+              Logs.err (fun m -> m "create continuation failed %s" msg) ;
-            process state outs >>= fun () ->
+              Lwt.return_unit
-            begin match cont !state t with
+            | Ok (state'', out, vm) ->
-              | Ok (state', outs, vm) ->
+              state := state'' ;
-                state := state' ;
               s := { !s with vm_created = succ !s.vm_created } ;
               Lwt.async (fun () ->
                   Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r ->
-                    let state', outs = Vmm_engine.handle_shutdown !state vm r in
+                  let state', out' = Vmm_engine.handle_shutdown !state vm r in
                   s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
                   state := state' ;
-                    process state outs >|= fun () ->
+                  process out' >|= fun () ->
                   Lwt.wakeup wakeme ()) ;
-                process state outs >>= fun () ->
+              process out >>= fun () ->
               begin match Vmm_engine.setup_stats !state vm with
-                  | Ok (state', outs) ->
+                | Ok (state', out) ->
                   state := state' ;
-                    process state outs
+                  process out (* TODO: need to read from stats socket! *)
                 | Error (`Msg e) ->
                   Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ;
                   Lwt.return_unit
               end
-              | Error (`Msg e) ->
-                Logs.err (fun m -> m "error while create %s" e) ;
-                let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
-                process state [ `Tls (t, err) ]
           end
-          | Error (`Msg e) ->
+        | _ ->
-            Logs.err (fun m -> m "error while cont %s" e) ;
+          Logs.err (fun m -> m "error while reading from console") ;
-            let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
+          Lwt.return_unit) >>= fun () ->
-            process state [ `Tls (t, err) ]
+  Vmm_lwt.safe_close fd
-        end >>= fun () ->
-        Tls_lwt.Unix.close (fst t)
-      | `Loop (prefix, perms) ->
-        let rec loop () =
-          Vmm_tls.read_tls (fst t) >>= function
-          | Error (`Msg msg) ->
-            Logs.err (fun m -> m "reading client %a error: %s" pp_sockaddr t msg) ;
-            loop ()
-          | Error _ ->
-            Logs.err (fun m -> m "disconnect from %a" pp_sockaddr t) ;
-            let state', cons = Vmm_engine.handle_disconnect !state t in
-            state := state' ;
-            Lwt_list.iter_s (fun (s, data) -> write_raw s data) cons >>= fun () ->
-            Tls_lwt.Unix.close (fst t)
-          | Ok (hdr, buf) ->
-            let state', out = Vmm_engine.handle_command !state t prefix perms hdr buf in
-            state := state' ;
-            process state out >>= fun () ->
-            loop ()
-        in
-        loop ()
-      | `Close socks ->
-        Logs.debug (fun m -> m "closing session with %d active ones" (List.length socks)) ;
-        Lwt_list.iter_s (fun (t, _) -> Tls_lwt.Unix.close t) socks >>= fun () ->
-        Tls_lwt.Unix.close (fst t)
-    end
-  | Error (`Msg e) ->
-    Logs.err (fun m -> m "VMM %a %s" pp_sockaddr t e) ;
-    let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
-    process state [`Tls (t, err)] >>= fun () ->
-    Tls_lwt.Unix.close (fst t)
-
-let server_socket port =
-  let open Lwt_unix in
-  let s = socket PF_INET SOCK_STREAM 0 in
-  set_close_on_exec s ;
-  setsockopt s SO_REUSEADDR true ;
-  bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () ->
-  listen s 10 ;
-  Lwt.return s
 
 let init_sock dir name =
   let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
@@ -159,120 +109,63 @@ let init_sock dir name =
        (Lwt.catch (fun () -> Lwt_unix.close c) (fun _ -> Lwt.return_unit)) >|= fun () ->
        None)
 
-let rec read_log state s =
+let create_mbox name =
-  Vmm_lwt.read_exactly s >>= function
+  init_sock Vmm_core.tmpdir name >|= function
-  | Error (`Msg msg) ->
+  | None -> None
-    Logs.err (fun m -> m "reading log error %s" msg) ;
+  | Some fd ->
-    read_log state s
+    let mvar = Lwt_mvar.create_empty () in
-  | Error _ ->
+    (* could be more elaborate:
-    Logs.err (fun m -> m "exception while reading log") ;
+       if <log> fails, we can reconnect and spit our more log messages to the new socket
-    invalid_arg "log socket communication issue"
+       if <console> fails, all running VMs terminate, so we can terminate as well ;)
-  | Ok (hdr, data) ->
+       if <stat> fails, we'd need to retransmit all VM info to stat (or stat has to ask at connect) *)
-    let state', outs = Vmm_engine.handle_log !state hdr data in
+    let rec loop () =
-    state := state' ;
+      Lwt_mvar.take mvar >>= fun data ->
-    process state outs >>= fun () ->
+      Vmm_lwt.write_wire fd data >>= function
-    read_log state s
+      | Ok () -> loop ()
+      | Error `Exception -> invalid_arg ("exception while writing to " ^ name) ;
+    in
+    Lwt.async loop ;
+    Some (mvar, fd)
 
-let rec read_cons state s =
+let server_socket dir name =
-  Vmm_lwt.read_exactly s >>= function
+  let file = Fpath.(dir / name + "sock") in
-  | Error (`Msg msg) ->
+  let sock = Fpath.to_string file in
-    Logs.err (fun m -> m "reading console error %s" msg) ;
+  (Lwt_unix.file_exists sock >>= function
-    read_cons state s
+    | true -> Lwt_unix.unlink sock
-  | Error _ ->
+    | false -> Lwt.return_unit) >>= fun () ->
-    Logs.err (fun m -> m "exception while reading console socket") ;
+  let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
-    invalid_arg "console socket communication issue"
+  Lwt_unix.(bind s (ADDR_UNIX sock)) >|= fun () ->
-  | Ok (hdr, data) ->
+  Lwt_unix.listen s 1 ;
-    let state', outs = Vmm_engine.handle_cons !state hdr data in
+  s
-    state := state' ;
-    process state outs >>= fun () ->
-    read_cons state s
-
-let rec read_stats state s =
-  Vmm_lwt.read_exactly s >>= function
-  | Error (`Msg msg) ->
-    Logs.err (fun m -> m "reading stats error %s" msg) ;
-    read_stats state s
-  | Error _ ->
-    Logs.err (fun m -> m "exception while reading stats") ;
-    Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
-    invalid_arg "stat socket communication issue"
-  | Ok (hdr, data) ->
-    let state', outs = Vmm_engine.handle_stat !state hdr data in
-    state := state' ;
-    process state outs >>= fun () ->
-    read_stats state s
-
-let cmp_s (_, a) (_, b) =
-  let open Lwt_unix in
-  match a, b with
-  | ADDR_UNIX str, ADDR_UNIX str' -> String.compare str str' = 0
-  | ADDR_INET (addr, port), ADDR_INET (addr', port') ->
-    port = port' &&
-    String.compare (Unix.string_of_inet_addr addr) (Unix.string_of_inet_addr addr') = 0
-  | _ -> false
 
 let rec stats_loop () =
   Logs.info (fun m -> m "%a" pp_stats !s) ;
   Lwt_unix.sleep 600. >>= fun () ->
   stats_loop ()
 
-let jump _ cacert cert priv_key port =
+let jump _ =
   Sys.(set_signal sigpipe Signal_ignore) ;
   Lwt_main.run
-    (Nocrypto_entropy_lwt.initialize () >>= fun () ->
+    (server_socket Vmm_core.tmpdir "vmmd" >>= fun ss ->
-     (init_sock Vmm_core.tmpdir "cons" >|= function
+     (create_mbox "cons" >|= function
        | None -> invalid_arg "cannot connect to console socket"
-       | Some c -> c) >>= fun c ->
+       | Some c -> c) >>= fun (c, c_fd) ->
-     init_sock Vmm_core.tmpdir "stat" >>= fun s ->
+     create_mbox "stat" >>= fun s ->
-     (init_sock Vmm_core.tmpdir "log" >|= function
+     (create_mbox "log" >|= function
        | None -> invalid_arg "cannot connect to log socket"
-       | Some l -> l) >>= fun l ->
+       | Some l -> l) >>= fun (l, _l_fd) ->
-     server_socket port >>= fun socket ->
+     let state = ref (Vmm_engine.init ()) in
-     X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
+     let out = function
-     X509_lwt.certs_of_pem cacert >>= (function
+       | `Stat data -> (match s with None -> Lwt.return_unit | Some (s, _s_fd) -> Lwt_mvar.put s data)
-         | [ ca ] -> Lwt.return ca
+       | `Log data -> Lwt_mvar.put l data
-         | _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca ->
+       | `Cons data -> Lwt_mvar.put c data
-     let config =
-       Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
-              ~reneg:true ~certificates:(`Single cert) ())
      in
-     (match Vmm_engine.init cmp_s c s l with
-      | Ok s -> Lwt.return s
-      | Error (`Msg m) -> Lwt.fail_with m) >>= fun t ->
-     let state = ref t in
-     Lwt.async (fun () -> read_cons state c) ;
-     (match s with
-      | None -> ()
-      | Some s -> Lwt.async (fun () -> read_stats state s)) ;
-     Lwt.async (fun () -> read_log state l) ;
      Lwt.async stats_loop ;
      let rec loop () =
-       Lwt.catch (fun () ->
+       Lwt_unix.accept ss >>= fun (fd, addr) ->
-           Lwt_unix.accept socket >>= fun (fd, addr) ->
        Lwt_unix.set_close_on_exec fd ;
-           Lwt.catch
+       Lwt.async (fun () -> handle state out c_fd fd addr) ;
-             (fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr))
-             (fun exn ->
-                Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () ->
-                Lwt.fail exn) >>= fun t ->
-           Lwt.async (fun () ->
-               Lwt.catch
-                 (fun () -> handle ca state t)
-                 (fun e ->
-                    Logs.err (fun m -> m "error while handle() %s"
-                                 (Printexc.to_string e)) ;
-                    Lwt.return_unit)) ;
-           loop ())
-         (function
-           | Unix.Unix_error (e, f, _) ->
-             Logs.err (fun m -> m "Unix error %s in %s" (Unix.error_message e) f) ;
        loop ()
-           | Tls_lwt.Tls_failure a ->
-             Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
-             loop ()
-           | exn ->
-             Logs.err (fun m -> m "exception %s" (Printexc.to_string exn)) ;
-             loop ())
      in
      loop ())
 
@@ -288,24 +181,8 @@ let setup_log =
         $ Fmt_cli.style_renderer ()
         $ Logs_cli.level ())
 
-let cacert =
-  let doc = "CA certificate" in
-  Arg.(required & pos 0 (some file) None & info [] ~doc)
-
-let cert =
-  let doc = "Certificate" in
-  Arg.(required & pos 1 (some file) None & info [] ~doc)
-
-let key =
-  let doc = "Private key" in
-  Arg.(required & pos 2 (some file) None & info [] ~doc)
-
-let port =
-  let doc = "TCP listen port" in
-  Arg.(value & opt int 1025 & info [ "port" ] ~doc)
-
 let cmd =
-  Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)),
+  Term.(ret (const jump $ setup_log)),
   Term.info "vmmd" ~version:"%%VERSION_NUM%%"
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

opam

@@ -14,7 +14,6 @@ depends: [
   "ipaddr" {>= "2.2.0"}
   "hex"
   "cstruct"
-  "ppx_cstruct" {build & >= "3.0.0"}
   "logs"
   "rresult"
   "bos"

pkg/pkg.ml

@@ -9,7 +9,9 @@ let () =
     Pkg.bin "app/vmmd" ;
     Pkg.bin "app/vmm_console" ;
     Pkg.bin "app/vmm_log" ;
-    Pkg.bin "app/vmm_client" ;
+    (* Pkg.bin "app/vmm_client" ; *)
+    (* Pkg.bin "app/vmm_tls_endpoint" ; *)
+    Pkg.bin "app/vmmc" ;
     Pkg.bin "provision/vmm_req_permissions" ;
     Pkg.bin "provision/vmm_req_delegation" ;
     Pkg.bin "provision/vmm_req_vm" ;
@@ -18,6 +20,6 @@ let () =
     Pkg.bin "provision/vmm_gen_ca" ;
     Pkg.clib "stats/libvmm_stats_stubs.clib" ;
     Pkg.bin "stats/vmm_stats_lwt" ;
-    Pkg.bin "app/vmm_prometheus_stats" ;
+    (* Pkg.bin "app/vmm_prometheus_stats" ; *)
     Pkg.bin "app/vmm_influxdb_stats" ;
   ]

src/vmm_asn.ml

@@ -38,15 +38,16 @@ end
 
 let perms : permission list Asn.t =
   Asn.S.bit_string_flags [
-    0, `All ;
+    0, `All ; (* no *)
     1, `Info ;
     2, `Create ;
-    3, `Block ;
+    3, `Block ; (* create [name] [size] ; destroy [name] *)
     4, `Statistics ;
     5, `Console ;
     6, `Log ;
     7, `Crl ;
     9, `Force_create ;
+    (* 10, `Destroy ; (* [name] *) *)
   ]
 
 open Rresult.R.Infix

src/vmm_commands.ml

@@ -0,0 +1,223 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Astring
+
+open Vmm_core
+
+open Rresult
+open R.Infix
+
+let handle_command t s prefix perms hdr buf =
+  let res =
+    if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
+      Error (`Msg "unknown client version")
+    else match Vmm_wire.Client.cmd_of_int hdr.Vmm_wire.tag with
+      | None -> Error (`Msg "unknown command")
+      | Some x when cmd_allowed perms x ->
+        begin
+          Vmm_wire.decode_str buf >>= fun (buf, _l) ->
+          let arg = if String.length buf = 0 then prefix else prefix @ [buf] in
+          let vmid = string_of_id arg in
+          match x with
+          | Info ->
+            begin match Vmm_resources.find t.resources arg with
+              | None ->
+                Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ;
+                R.error_msgf "info: %s not found" buf
+              | Some x ->
+                let data =
+                  Vmm_resources.fold (fun acc vm ->
+                      acc ^ Vmm_wire.Client.encode_vm vm.config.vname vm)
+                    "" x
+                in
+                let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in
+                Ok (t, [ `Tls (s, out) ])
+            end
+          | Destroy_vm ->
+            begin match Vmm_resources.find_vm t.resources arg with
+              | Some vm ->
+                Vmm_unix.destroy vm ;
+                let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
+                Ok (t, [ `Tls (s, out) ])
+              | _ ->
+                Error (`Msg ("destroy: not found " ^ buf))
+            end
+          | Attach ->
+            (* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *)
+            let on_success t =
+              let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in
+              let old = match String.Map.find vmid t.console_attached with
+                | None -> []
+                | Some s ->
+                  let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
+                  [ `Tls (s, out) ]
+              in
+              let console_attached = String.Map.add vmid s t.console_attached in
+              { t with console_counter = succ t.console_counter ; console_attached },
+              `Raw (t.console_socket, cons) :: old
+            in
+            let cons = Vmm_wire.Console.attach t.console_counter t.console_version vmid in
+            let console_requests = IM.add t.console_counter on_success t.console_requests in
+            Ok ({ t with console_counter = succ t.console_counter ; console_requests },
+                [ `Raw (t.console_socket, cons) ])
+          | Detach ->
+            let cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in
+            (match String.Map.find vmid t.console_attached with
+             | None -> Error (`Msg "not attached")
+             | Some x when t.cmp x s -> Ok (String.Map.remove vmid t.console_attached)
+             | Some _ -> Error (`Msg "this socket is not attached")) >>= fun console_attached ->
+            let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
+            Ok ({ t with console_counter = succ t.console_counter ; console_attached },
+                [ `Raw (t.console_socket, cons) ; `Tls (s, out) ])
+          | Statistics ->
+            begin match t.stats_socket with
+              | None -> Error (`Msg "no statistics available")
+              | Some _ -> match Vmm_resources.find_vm t.resources arg with
+                | Some vm ->
+                  let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vmid in
+                  let d = (s, hdr.Vmm_wire.id, translate_tap vm) in
+                  let stats_requests = IM.add t.stats_counter d t.stats_requests in
+                  Ok ({ t with stats_counter = succ t.stats_counter ; stats_requests },
+                      stat t stat_out)
+                | _ -> Error (`Msg ("statistics: not found " ^ buf))
+            end
+          | Log ->
+            begin
+              let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in
+              let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in
+              let log_counter = succ t.log_counter in
+              Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ])
+            end
+          | Create_block | Destroy_block -> Error (`Msg "NYI")
+        end
+      | Some _ -> Error (`Msg "unauthorised command")
+  in
+  match res with
+  | Ok r -> r
+  | Error (`Msg msg) ->
+    Logs.debug (fun m -> m "error while processing command: %s" msg) ;
+    let out = Vmm_wire.fail ~msg hdr.Vmm_wire.id t.client_version in
+    (t, [ `Tls (s, out) ])
+
+let handle_stat state hdr data =
+  let open Vmm_wire in
+  if not (version_eq hdr.version state.stats_version) then begin
+    Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
+    state, []
+  end else if hdr.tag = success_tag then
+    state, []
+  else
+    match IM.find hdr.id state.stats_requests with
+    | exception Not_found ->
+      Logs.err (fun m -> m "couldn't find stat request") ;
+      state, []
+    | (s, req_id, f) ->
+      let stats_requests = IM.remove hdr.id state.stats_requests in
+      let state = { state with stats_requests } in
+      let out =
+        match Stats.int_to_op hdr.tag with
+        | Some Stats.Stat_reply ->
+          begin match Stats.decode_stats (Cstruct.of_string data) with
+            | Ok (ru, vmm, ifs) ->
+              let ifs =
+                List.map
+                  (fun x ->
+                     match f x.name with
+                     | Some name -> { x with name }
+                     | None -> x)
+                  ifs
+              in
+              let data = Cstruct.to_string (Stats.encode_stats (ru, vmm, ifs)) in
+              let out = Client.stat data req_id state.client_version in
+              [ `Tls (s, out) ]
+            | Error (`Msg msg) ->
+              Logs.err (fun m -> m "error %s while decode statistics" msg) ;
+              let out = fail req_id state.client_version in
+              [ `Tls (s, out) ]
+          end
+        | None when hdr.tag = fail_tag ->
+          let out = fail ~msg:data req_id state.client_version in
+          [ `Tls (s, out) ]
+        | _ ->
+          Logs.err (fun m -> m "unexpected reply from stat") ;
+          []
+      in
+      (state, out)
+
+let handle_cons state hdr data =
+  let open Vmm_wire in
+  if not (version_eq hdr.version state.console_version) then begin
+    Logs.warn (fun m -> m "ignoring message with unknown console version") ;
+    state, []
+  end else match Console.int_to_op hdr.tag with
+    | Some Console.Data ->
+      begin match decode_str data with
+        | Error (`Msg msg) ->
+          Logs.err (fun m -> m "error while decoding console message %s" msg) ;
+          (state, [])
+        | Ok (file, off) ->
+        (match String.Map.find file state.console_attached with
+         | Some s ->
+           let out = Client.console off file data state.client_version in
+           (state, [ `Tls (s, out) ])
+         | None ->
+           (* TODO: should detach? *)
+           Logs.err (fun m -> m "couldn't find attached console for %s" file) ;
+           (state, []))
+    end
+  | None when hdr.tag = success_tag ->
+    (match IM.find hdr.id state.console_requests with
+     | exception Not_found ->
+       (state, [])
+     | cont ->
+       let state', outs = cont state in
+       let console_requests = IM.remove hdr.id state.console_requests in
+       ({ state' with console_requests }, outs))
+  | None when hdr.tag = fail_tag ->
+    (match IM.find hdr.id state.console_requests with
+     | exception Not_found ->
+       Logs.err (fun m -> m "fail couldn't find request id") ;
+       (state, [])
+     | _ ->
+       Logs.err (fun m -> m "failed while trying to do something on console") ;
+       let console_requests = IM.remove hdr.id state.console_requests in
+       ({ state with console_requests }, []))
+  | _ ->
+    Logs.err (fun m -> m "unexpected message received from console socket") ;
+    (state, [])
+
+let handle_log state hdr buf =
+  let open Vmm_wire in
+  let open Vmm_wire.Log in
+  if not (version_eq hdr.version state.log_version) then begin
+    Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
+    state, []
+  end else match IM.find hdr.id state.log_requests with
+    | exception Not_found ->
+      Logs.warn (fun m -> m "(ignored) coudn't find log request") ;
+      (state, [])
+    | (s, rid) ->
+      let r = match int_to_op hdr.tag with
+        | Some Data ->
+          decode_log_hdr (Cstruct.of_string buf) >>= fun (hdr, rest) ->
+          decode_event rest >>= fun event ->
+          let tls = Vmm_wire.Client.log hdr event state.client_version in
+          Ok (state, [ `Tls (s, tls) ])
+        | None when hdr.tag = success_tag ->
+          let log_requests = IM.remove hdr.id state.log_requests in
+          let tls = Vmm_wire.success rid state.client_version in
+          Ok ({ state with log_requests }, [ `Tls (s, tls) ])
+        | None when hdr.tag = fail_tag ->
+          let log_requests = IM.remove hdr.id state.log_requests in
+          let tls = Vmm_wire.fail rid state.client_version in
+          Ok ({ state with log_requests }, [ `Tls (s, tls) ])
+        | _ ->
+          Logs.err (fun m -> m "couldn't parse log reply") ;
+          let log_requests = IM.remove hdr.id state.log_requests in
+          Ok ({ state with log_requests }, [])
+      in
+      match r with
+      | Ok (s, out) -> s, out
+      | Error (`Msg msg) ->
+        Logs.err (fun m -> m "error while processing log %s" msg) ;
+        state, []

src/vmm_core.ml

@@ -14,6 +14,7 @@ end
 
 module IS = Set.Make(I)
 module IM = Map.Make(I)
+module IM64 = Map.Make(Int64)
 
 type permission =
   [ `All | `Info | `Create | `Block | `Statistics | `Console | `Log | `Crl | `Force_create]
@@ -88,6 +89,17 @@ let cmd_allowed permissions cmd =
 
 type vmtype = [ `Ukvm_amd64 | `Ukvm_arm64 | `Ukvm_amd64_compressed ]
 
+let vmtype_to_int = function
+  | `Ukvm_amd64 -> 0
+  | `Ukvm_arm64 -> 1
+  | `Ukvm_amd64_compressed -> 2
+
+let int_to_vmtype = function
+  | 0 -> Some `Ukvm_amd64
+  | 1 -> Some `Ukvm_arm64
+  | 2 -> Some `Ukvm_amd64_compressed
+  | _ -> None
+
 let pp_vmtype ppf = function
   | `Ukvm_amd64 -> Fmt.pf ppf "ukvm-amd64"
   | `Ukvm_amd64_compressed -> Fmt.pf ppf "ukvm-amd64-compressed"
@@ -340,7 +352,7 @@ module Log = struct
 
   let pp_hdr db ppf (hdr : hdr) =
     let name = translate_serial db hdr.name in
-    Fmt.pf ppf "%a: %s" (Ptime.pp_human ~tz_offset_s:0 ()) hdr.ts name
+    Fmt.pf ppf "%a: %s" (Ptime.pp_human ()) hdr.ts name
 
   let hdr context name = { ts = Ptime_clock.now () ; context ; name }
 
@@ -350,10 +362,6 @@ module Log = struct
     | `Logout of Ipaddr.V4.t * int
     | `VM_start of int * string list * string option
     | `VM_stop of int * [ `Exit of int | `Signal of int | `Stop of int ]
-    | `Block_create of string * int
-    | `Block_destroy of string
-    | `Delegate of string list * string option
-      (* | `CRL of string *)
     ]
 
   let pp_event ppf = function
@@ -371,14 +379,6 @@ module Log = struct
         | `Stop n -> "stop", n
       in
       Fmt.pf ppf "STOPPED %d with %s %a" pid s Fmt.Dump.signal c
-    | `Block_create (name, size) ->
-      Fmt.pf ppf "BLOCK_CREATE %s %d" name size
-    | `Block_destroy name -> Fmt.pf ppf "BLOCK_DESTROY %s" name
-    | `Delegate (bridges, block) ->
-      Fmt.pf ppf "DELEGATE %a, block %a"
-        Fmt.(list ~sep:(unit "; ") string) bridges
-        Fmt.(option ~none:(unit "no") string) block
-      (* | `CRL of string *)
 
   type msg = hdr * event
 

src/vmm_engine.ml

@@ -1,4 +1,4 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
 
 open Astring
 
@@ -7,21 +7,12 @@ open Vmm_core
 open Rresult
 open R.Infix
 
-type ('a, 'b, 'c) t = {
+type 'a t = {
-  cmp : 'b -> 'b -> bool ;
+  console_counter : int64 ;
-  console_socket : 'a ;
-  console_counter : int ;
-  console_requests : (('a, 'b, 'c) t -> ('a, 'b, 'c) t * [ `Raw of 'a * string | `Tls of 'b * string ] list) IM.t ;
-  console_attached : 'b String.Map.t ; (* vm_name -> socket *)
   console_version : Vmm_wire.version ;
-  stats_socket : 'a option ;
+  stats_counter : int64 ;
-  stats_counter : int ;
-  stats_requests : ('b * int * (string -> string option)) IM.t ;
   stats_version : Vmm_wire.version ;
-  log_socket : 'a ;
+  log_counter : int64 ;
-  log_counter : int ;
-  log_requests : ('b * int) IM.t ;
-  log_attached : ('b * string) list String.Map.t ;
   log_version : Vmm_wire.version ;
   client_version : Vmm_wire.version ;
   (* TODO: refine, maybe:
@@ -29,103 +20,45 @@ type ('a, 'b, 'c) t = {
   used_bridges : String.Set.t String.Map.t ;
   (* TODO: used block devices (since each may only be active once) *)
   resources : Vmm_resources.t ;
-  tasks : 'c String.Map.t ;
+  tasks : 'a String.Map.t ;
-  crls : X509.CRL.c list ;
 }
 
-let init cmp console_socket stats_socket log_socket =
+let init () = {
-  (* error hard on permission denied etc. *)
+  console_counter = 1L ; console_version = `WV2 ;
-  let crls = Fpath.(dbdir / "crls") in
+  stats_counter = 1L ; stats_version = `WV2 ;
-  (Bos.OS.Dir.exists crls >>= function
+  log_counter = 1L ; log_version = `WV2 ;
-    | true -> Ok true
+  client_version = `WV2 ;
-    | false -> Bos.OS.Dir.create crls) >>= fun _ ->
-  let err _ x = x in
-  Bos.OS.Dir.fold_contents ~elements:`Files ~traverse:`None ~err
-    (fun f acc ->
-       acc >>= fun acc ->
-       Bos.OS.File.read f >>= fun data ->
-       match X509.Encoding.crl_of_cstruct (Cstruct.of_string data) with
-       | None -> R.error_msgf "couldn't parse CRL %a" Fpath.pp f
-       | Some crl -> Ok (crl :: acc))
-    (Ok [])
-    crls >>= fun crls ->
-  crls >>= fun crls ->
-  Ok {
-    cmp ;
-    console_socket ; console_counter = 1 ; console_requests = IM.empty ;
-    console_attached = String.Map.empty ; console_version = `WV0 ;
-    stats_socket ; stats_counter = 1 ; stats_requests = IM.empty ;
-    stats_version = `WV1 ;
-    log_socket ; log_counter = 1 ; log_attached = String.Map.empty ;
-    log_version = `WV0 ; log_requests = IM.empty ;
-    client_version = `WV0 ;
   used_bridges = String.Map.empty ;
   resources = Vmm_resources.empty ;
   tasks = String.Map.empty ;
-    crls
 }
 
-let asn_version = `AV0
-
 let log state (hdr, event) =
-  let pre = string_of_id hdr.Log.context in
+  let data = Vmm_wire.Log.log state.log_counter state.log_version hdr event in
-  let out = match String.Map.find pre state.log_attached with
+  let log_counter = Int64.succ state.log_counter in
-    | None -> []
-    | Some x -> x
-  in
-  let data = Vmm_wire.Log.data state.log_counter state.log_version hdr event in
-  let tls = Vmm_wire.Client.log hdr event state.client_version in
-  let log_counter = succ state.log_counter in
   Logs.debug (fun m -> m "LOG %a" (Log.pp []) (hdr, event)) ;
-  ({ state with log_counter },
+  ({ state with log_counter }, `Log data)
-   `Raw (state.log_socket, data) :: List.map (fun (s, _) -> `Tls (s, tls)) out)
 
-let stat state str =
+let handle_create t hdr vm_config (* policies *) =
-  match state.stats_socket with
-  | None -> []
-  | Some s -> [ `Raw (s, str) ]
-
-let handle_disconnect state t =
-  Logs.err (fun m -> m "disconnect!!") ;
-  let rem, console_attached =
-    String.Map.partition (fun _ s -> state.cmp s t) state.console_attached
-  in
-  let out, console_counter =
-    List.fold_left (fun (acc, ctr) name ->
-        (acc ^ Vmm_wire.Console.detach ctr state.console_version name, succ ctr))
-      ("", state.console_counter)
-      (fst (List.split (String.Map.bindings rem)))
-  in
-  let log_attached = String.Map.fold (fun k v n ->
-      match List.filter (fun (e, _) -> not (state.cmp t e)) v with
-      | [] -> n
-      | xs -> String.Map.add k xs n)
-      state.log_attached String.Map.empty
-  in
-  let out =
-    if String.length out = 0 then
-      []
-    else
-      [ (state.console_socket, out) ]
-  in
-  { state with console_attached ; console_counter ; log_attached }, out
-
-let handle_create t vm_config policies =
   let full = fullname vm_config in
   (if Vmm_resources.exists t.resources full then
      Error (`Msg "VM with same name is already running")
    else
      Ok ()) >>= fun () ->
-  Logs.debug (fun m -> m "now checking dynamic policies") ;
+  (* Logs.debug (fun m -> m "now checking dynamic policies") ;
-  Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () ->
+     Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> *)
   (* prepare VM: save VM image to disk, create fifo, ... *)
   Vmm_unix.prepare vm_config >>= fun taps ->
   Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
-  Ok (fun t s ->
+  (* TODO should we pre-reserve sth in t? *)
+  let cons = Vmm_wire.Console.add t.console_counter t.console_version full 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
           let used_bridges =
             List.fold_left2 (fun b br ta ->
                 let old = match String.Map.find br b with
@@ -135,15 +68,15 @@ let handle_create t vm_config policies =
                 String.Map.add br (String.Set.add ta old) b)
               t.used_bridges vm_config.network taps
           in
-        let t = { t with resources ; used_bridges } 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 tls_out = Vmm_wire.success ~msg:"VM started" 0 t.client_version in
+          let data = Vmm_wire.success t.client_version hdr.Vmm_wire.id Vmm_wire.Vm.(op_to_int Create) in
-        Ok (t, `Tls (s, tls_out) :: out, vm))
+          Ok (t, [ `Data data ; out ], vm)))
 
 let setup_stats t vm =
-  let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (vm_id vm.config) vm.pid vm.taps in
+  let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (fullname vm.config) vm.pid vm.taps in
-  let t = { t with stats_counter = succ t.stats_counter } in
+  let t = { t with stats_counter = Int64.succ t.stats_counter } in
-  Ok (t, stat t stat_out)
+  Ok (t, [ `Stat stat_out ])
 
 let handle_shutdown t vm r =
   (match Vmm_unix.shutdown vm with
@@ -165,386 +98,59 @@ 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 (vm_id vm.config) 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 t = { t with stats_counter = succ t.stats_counter ; resources ; used_bridges ; tasks } in
+  let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in
-  let t, outs = log t (Log.hdr vm.config.prefix vm.config.vname,
+  let t, logout = log t (Log.hdr vm.config.prefix vm.config.vname,
                          `VM_stop (vm.pid, r))
   in
-  (t, stat t stat_out @ outs)
+  (t, [ `Stat stat_out ; logout ])
 
-let handle_command t s prefix perms hdr buf =
+let handle_command t hdr buf =
-  let res =
+  let msg_to_err = function
-    if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
+    | Ok x -> x
-      Error (`Msg "unknown client version")
-    else match Vmm_wire.Client.cmd_of_int hdr.Vmm_wire.tag with
-      | None -> Error (`Msg "unknown command")
-      | Some x when cmd_allowed perms x ->
-        begin
-          Vmm_wire.decode_str buf >>= fun (buf, _l) ->
-          let arg = if String.length buf = 0 then prefix else prefix @ [buf] in
-          let vmid = string_of_id arg in
-          match x with
-          | Info ->
-            begin match Vmm_resources.find t.resources arg with
-              | None ->
-                Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ;
-                R.error_msgf "info: %s not found" buf
-              | Some x ->
-                let data =
-                  Vmm_resources.fold (fun acc vm ->
-                      acc ^ Vmm_wire.Client.encode_vm vm.config.vname vm)
-                    "" x
-                in
-                let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in
-                Ok (t, [ `Tls (s, out) ])
-            end
-          | Destroy_vm ->
-            begin match Vmm_resources.find_vm t.resources arg with
-              | Some vm ->
-                Vmm_unix.destroy vm ;
-                let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
-                Ok (t, [ `Tls (s, out) ])
-              | _ ->
-                Error (`Msg ("destroy: not found " ^ buf))
-            end
-          | Attach ->
-            (* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *)
-            let on_success t =
-              let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in
-              let old = match String.Map.find vmid t.console_attached with
-                | None -> []
-                | Some s ->
-                  let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
-                  [ `Tls (s, out) ]
-              in
-              let console_attached = String.Map.add vmid s t.console_attached in
-              { t with console_counter = succ t.console_counter ; console_attached },
-              `Raw (t.console_socket, cons) :: old
-            in
-            let cons = Vmm_wire.Console.attach t.console_counter t.console_version vmid in
-            let console_requests = IM.add t.console_counter on_success t.console_requests in
-            Ok ({ t with console_counter = succ t.console_counter ; console_requests },
-                [ `Raw (t.console_socket, cons) ])
-          | Detach ->
-            let cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in
-            (match String.Map.find vmid t.console_attached with
-             | None -> Error (`Msg "not attached")
-             | Some x when t.cmp x s -> Ok (String.Map.remove vmid t.console_attached)
-             | Some _ -> Error (`Msg "this socket is not attached")) >>= fun console_attached ->
-            let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
-            Ok ({ t with console_counter = succ t.console_counter ; console_attached },
-                [ `Raw (t.console_socket, cons) ; `Tls (s, out) ])
-          | Statistics ->
-            begin match t.stats_socket with
-              | None -> Error (`Msg "no statistics available")
-              | Some _ -> match Vmm_resources.find_vm t.resources arg with
-                | Some vm ->
-                  let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vmid in
-                  let d = (s, hdr.Vmm_wire.id, translate_tap vm) in
-                  let stats_requests = IM.add t.stats_counter d t.stats_requests in
-                  Ok ({ t with stats_counter = succ t.stats_counter ; stats_requests },
-                      stat t stat_out)
-                | _ -> Error (`Msg ("statistics: not found " ^ buf))
-            end
-          | Log ->
-            begin
-              let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in
-              let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in
-              let log_counter = succ t.log_counter in
-              Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ])
-            end
-          | Create_block | Destroy_block -> Error (`Msg "NYI")
-        end
-      | Some _ -> Error (`Msg "unauthorised command")
-  in
-  match res with
-  | Ok r -> r
     | Error (`Msg msg) ->
       Logs.debug (fun m -> m "error while processing command: %s" msg) ;
-    let out = Vmm_wire.fail ~msg hdr.Vmm_wire.id t.client_version in
+      let out = Vmm_wire.fail ~msg t.client_version hdr.Vmm_wire.id in
-    (t, [ `Tls (s, out) ])
+      (t, [ `Data out ], `End)
-
-let handle_single_revocation t prefix serial =
-  let id = identifier serial in
-  (match Vmm_resources.find t.resources (prefix @ [ id ]) with
-   | None -> ()
-   | Some e -> Vmm_resources.iter Vmm_unix.destroy e) ;
-  (* also revoke all active sessions!? *)
-  (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *)
-  let log_attached, kill =
-    let pid = string_of_id prefix in
-    match String.Map.find pid t.log_attached with
-    | None -> t.log_attached, []
-    | Some xs ->
-      (* those where snd v = serial: drop *)
-      let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in
-      String.Map.add pid keep t.log_attached, drop
   in
-  (* two things:
+  msg_to_err (
-     1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above]
+    if Vmm_wire.is_reply hdr then begin
-     2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *)
+      Logs.warn (fun m -> m "ignoring reply") ;
-  let log_attached, kill =
+      Ok (t, [], `End)
-    String.Map.fold (fun k' v (l, k) ->
+    end else if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
-        if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then
+      Error (`Msg "unknown client version")
-          (l, v @ k)
+    else Vmm_wire.decode_strings buf >>= fun (id, _off) ->
-        else
+      match Vmm_wire.Vm.int_to_op hdr.Vmm_wire.tag with
-          (String.Map.add k' v l, k))
+      | None -> Error (`Msg "unknown command")
-      log_attached
+      | Some Info ->
-      (String.Map.empty, kill)
+        Logs.debug (fun m -> m "info %a" pp_id id) ;
-  in
+        begin match Vmm_resources.find t.resources id with
-  let state, out =
-    List.fold_left (fun (s, out) (t, _) ->
-        let s', out' = handle_disconnect s t in
-        s', out @ out')
-      ({ t with log_attached }, [])
-      kill
-  in
-  (state,
-   List.map (fun x -> `Raw x) out,
-   List.map fst kill)
-
-let handle_revocation t s leaf chain ca prefix =
-  Vmm_asn.crl_of_cert leaf >>= fun crl ->
-  (* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *)
-  let issuer = match chain with
-    | subca::_ -> subca
-    | [] -> ca
-  in
-  let time = Ptime_clock.now () in
-  (if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () ->
-  (* the this_update must be > now, next_update < now, this_update > <local>.this_update, number > <local>.number *)
-  (* TODO: can we have something better for uniqueness of CRL? *)
-  let local = try Some (List.find (fun crl -> X509.CRL.verify crl issuer) t.crls) with Not_found -> None in
-  (match local with
-   | None -> Ok ()
-   | Some local -> match X509.CRL.crl_number local, X509.CRL.crl_number crl with
-     | None, _ -> Ok ()
-     | Some _, None -> Error (`Msg "CRL number not present")
-     | Some x, Some y -> if y > x then Ok () else Error (`Msg "CRL number not increased")) >>= fun () ->
-  (* filename should be whatever_dir / crls / <id> *)
-  let filename = Fpath.(dbdir / "crls" / string_of_id prefix) in
-  Bos.OS.File.delete filename >>= fun () ->
-  Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () ->
-  (* remove crl with same issuer from crls, and inject this one into state *)
-  let crls =
-    match local with
-    | None -> crl :: t.crls
-    | Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls
-  in
-  (* iterate over revoked serials, find active resources, and kill them *)
-  let newly_revoked =
-    let old = match local with
-      | Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x)
-      | None -> []
-    in
-    let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in
-    List.filter (fun n -> not (List.mem n old)) new_rev
-  in
-  let t, out, close =
-    List.fold_left (fun (t, out, close) serial ->
-        let t', out', close' = handle_single_revocation t prefix serial in
-        (t', out @ out', close @ close'))
-      (t, [], []) newly_revoked
-  in
-  let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in
-  Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close)
-
-let handle_initial t s addr chain ca =
-  separate_chain chain >>= fun (leaf, chain) ->
-  Logs.debug (fun m -> m "leaf is %s, chain %a"
-                 (X509.common_name_to_string leaf)
-                 Fmt.(list ~sep:(unit "->") string)
-                 (List.map X509.common_name_to_string chain)) ;
-  (* TODO here: inspect top-level-cert of chain.
-     may need to create bridges and/or block device subdirectory (zfs create) *)
-  let prefix = List.map id chain in
-  let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in
-  let t, out = log t (login_hdr, login_ev) in
-  let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in
-  Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms ->
-  (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then
-     (* convert certificate to vm_config *)
-     Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
-     Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ;
-     (* get names and static resources *)
-     List.fold_left (fun acc ca ->
-         acc >>= fun acc ->
-         Vmm_asn.delegation_of_cert asn_version ca >>= fun res ->
-         let name = id ca in
-         Ok ((name, res) :: acc))
-       (Ok []) chain >>= fun policies ->
-     (* check static policies *)
-     Logs.debug (fun m -> m "now checking static policies") ;
-     check_policies vm_config (List.map snd policies) >>= fun () ->
-     let t, task =
-       let force = List.mem `Force_create perms in
-       if force then
-         let fid = vm_id vm_config in
-         match String.Map.find fid t.tasks with
-         | None -> t, None
-         | Some task ->
-           let kill () =
-             match Vmm_resources.find_vm t.resources (fullname vm_config) with
           | None ->
-               Logs.err (fun m -> m "found a task, but no vm for %a (%s)"
+            Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ;
-                            pp_id (fullname vm_config) fid)
+            Error (`Msg "info: not found")
+          | Some x ->
+            let data =
+              Vmm_resources.fold (fun acc vm -> vm :: acc) [] x
+            in
+            let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version data in
+            Ok (t, [ `Data out ], `End)
+        end
+      | Some Create ->
+        Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config ->
+        handle_create t hdr vm_config
+      | Some Destroy ->
+        match Vmm_resources.find_vm t.resources id with
         | Some vm ->
-               Logs.debug (fun m -> m "killing %a now" pp_vm vm) ;
+          Vmm_unix.destroy vm ;
-               Vmm_unix.destroy vm
+          let id_str = string_of_id id in
+          let out, next =
+            let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in
+            let s = [ `Data success ] in
+            match String.Map.find_opt id_str t.tasks with
+            | None -> s, `End
+            | Some t -> [], `Wait (t, s)
           in
-           let tasks = String.Map.remove fid t.tasks in
+          let tasks = String.Map.remove id_str t.tasks in
-           ({ t with tasks }, Some (kill, task))
+          Ok ({ t with tasks }, out, next)
-       else
+        | None -> Error (`Msg "destroy: not found"))
-         t, None
-     in
-     let next t sleeper =
-       handle_create t vm_config policies >>= fun cont ->
-       let id = vm_id vm_config in
-       let cons = Vmm_wire.Console.add t.console_counter t.console_version id in
-       let tasks = String.Map.add id sleeper t.tasks in
-       Ok ({ t with console_counter = succ t.console_counter ; tasks },
-           [ `Raw (t.console_socket, cons) ],
-           cont)
-     in
-     Ok (t, [], `Create (task, next))
-   else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
-     handle_revocation t s leaf chain ca prefix
-   else
-     let log_attached =
-       if cmd_allowed perms Log then
-         let pre = string_of_id prefix in
-         let v = match String.Map.find pre t.log_attached with
-           | None -> []
-           | Some xs -> xs
-         in
-         String.Map.add pre ((s, id leaf) :: v) t.log_attached
-       else
-         t.log_attached
-     in
-     Ok ({ t with log_attached }, [], `Loop (prefix, perms))
-  ) >>= fun (t, outs, res) ->
-  Ok (t, initial_out :: out @ outs, res)
-
-let handle_stat state hdr data =
-  let open Vmm_wire in
-  if not (version_eq hdr.version state.stats_version) then begin
-    Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
-    state, []
-  end else if hdr.tag = success_tag then
-    state, []
-  else
-    match IM.find hdr.id state.stats_requests with
-    | exception Not_found ->
-      Logs.err (fun m -> m "couldn't find stat request") ;
-      state, []
-    | (s, req_id, f) ->
-      let stats_requests = IM.remove hdr.id state.stats_requests in
-      let state = { state with stats_requests } in
-      let out =
-        match Stats.int_to_op hdr.tag with
-        | Some Stats.Stat_reply ->
-          begin match Stats.decode_stats (Cstruct.of_string data) with
-            | Ok (ru, vmm, ifs) ->
-              let ifs =
-                List.map
-                  (fun x ->
-                     match f x.name with
-                     | Some name -> { x with name }
-                     | None -> x)
-                  ifs
-              in
-              let data = Cstruct.to_string (Stats.encode_stats (ru, vmm, ifs)) in
-              let out = Client.stat data req_id state.client_version in
-              [ `Tls (s, out) ]
-            | Error (`Msg msg) ->
-              Logs.err (fun m -> m "error %s while decode statistics" msg) ;
-              let out = fail req_id state.client_version in
-              [ `Tls (s, out) ]
-          end
-        | None when hdr.tag = fail_tag ->
-          let out = fail ~msg:data req_id state.client_version in
-          [ `Tls (s, out) ]
-        | _ ->
-          Logs.err (fun m -> m "unexpected reply from stat") ;
-          []
-      in
-      (state, out)
-
-let handle_cons state hdr data =
-  let open Vmm_wire in
-  if not (version_eq hdr.version state.console_version) then begin
-    Logs.warn (fun m -> m "ignoring message with unknown console version") ;
-    state, []
-  end else match Console.int_to_op hdr.tag with
-    | Some Console.Data ->
-      begin match decode_str data with
-        | Error (`Msg msg) ->
-          Logs.err (fun m -> m "error while decoding console message %s" msg) ;
-          (state, [])
-        | Ok (file, off) ->
-        (match String.Map.find file state.console_attached with
-         | Some s ->
-           let out = Client.console off file data state.client_version in
-           (state, [ `Tls (s, out) ])
-         | None ->
-           (* TODO: should detach? *)
-           Logs.err (fun m -> m "couldn't find attached console for %s" file) ;
-           (state, []))
-    end
-  | None when hdr.tag = success_tag ->
-    (match IM.find hdr.id state.console_requests with
-     | exception Not_found ->
-       (state, [])
-     | cont ->
-       let state', outs = cont state in
-       let console_requests = IM.remove hdr.id state.console_requests in
-       ({ state' with console_requests }, outs))
-  | None when hdr.tag = fail_tag ->
-    (match IM.find hdr.id state.console_requests with
-     | exception Not_found ->
-       Logs.err (fun m -> m "fail couldn't find request id") ;
-       (state, [])
-     | _ ->
-       Logs.err (fun m -> m "failed while trying to do something on console") ;
-       let console_requests = IM.remove hdr.id state.console_requests in
-       ({ state with console_requests }, []))
-  | _ ->
-    Logs.err (fun m -> m "unexpected message received from console socket") ;
-    (state, [])
-
-let handle_log state hdr buf =
-  let open Vmm_wire in
-  let open Vmm_wire.Log in
-  if not (version_eq hdr.version state.log_version) then begin
-    Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
-    state, []
-  end else match IM.find hdr.id state.log_requests with
-    | exception Not_found ->
-      Logs.warn (fun m -> m "(ignored) coudn't find log request") ;
-      (state, [])
-    | (s, rid) ->
-      let r = match int_to_op hdr.tag with
-        | Some Data ->
-          decode_log_hdr (Cstruct.of_string buf) >>= fun (hdr, rest) ->
-          decode_event rest >>= fun event ->
-          let tls = Vmm_wire.Client.log hdr event state.client_version in
-          Ok (state, [ `Tls (s, tls) ])
-        | None when hdr.tag = success_tag ->
-          let log_requests = IM.remove hdr.id state.log_requests in
-          let tls = Vmm_wire.success rid state.client_version in
-          Ok ({ state with log_requests }, [ `Tls (s, tls) ])
-        | None when hdr.tag = fail_tag ->
-          let log_requests = IM.remove hdr.id state.log_requests in
-          let tls = Vmm_wire.fail rid state.client_version in
-          Ok ({ state with log_requests }, [ `Tls (s, tls) ])
-        | _ ->
-          Logs.err (fun m -> m "couldn't parse log reply") ;
-          let log_requests = IM.remove hdr.id state.log_requests in
-          Ok ({ state with log_requests }, [])
-      in
-      match r with
-      | Ok (s, out) -> s, out
-      | Error (`Msg msg) ->
-        Logs.err (fun m -> m "error while processing log %s" msg) ;
-        state, []

src/vmm_lwt.ml

@@ -2,6 +2,11 @@
 
 open Lwt.Infix
 
+let pp_sockaddr ppf = function
+  | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
+  | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
+                                         (Unix.string_of_inet_addr addr) port
+
 let pp_process_status ppf = function
   | Unix.WEXITED c -> Fmt.pf ppf "exited with %d" c
   | Unix.WSIGNALED s -> Fmt.pf ppf "killed by signal %a" Fmt.Dump.signal s
@@ -36,8 +41,8 @@ let wait_and_clear pid stdout =
     Logs.debug (fun m -> m "pid %d exited: %a" pid pp_process_status s) ;
     ret s
 
-let read_exactly s =
+let read_wire s =
-  let buf = Bytes.create 8 in
+  let buf = Bytes.create (Int32.to_int Vmm_wire.header_size) in
   let rec r b i l =
     Lwt.catch (fun () ->
         Lwt_unix.read s b i l >>= function
@@ -53,29 +58,28 @@ let read_exactly s =
          let err = Printexc.to_string e in
          Logs.err (fun m -> m "exception %s while reading" err) ;
          Lwt.return (Error `Exception))
-
   in
-  r buf 0 8 >>= function
+  r buf 0 (Int32.to_int Vmm_wire.header_size) >>= function
   | Error e -> Lwt.return (Error e)
   | Ok () ->
-    match Vmm_wire.parse_header (Bytes.to_string buf) with
+    match Vmm_wire.decode_header (Cstruct.of_bytes buf) with
     | Error (`Msg m) -> Lwt.return (Error (`Msg m))
     | Ok hdr ->
-      let l = hdr.Vmm_wire.length in
+      let l = Int32.to_int hdr.Vmm_wire.length in
       if l > 0 then
         let b = Bytes.create l in
         r b 0 l >|= function
         | Error e -> Error e
         | Ok () ->
-          (* Logs.debug (fun m -> m "read hdr %a, body %a"
+          Logs.debug (fun m -> m "read hdr %a, body %a"
                          Cstruct.hexdump_pp (Cstruct.of_bytes buf)
-                         Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; *)
+                         Cstruct.hexdump_pp (Cstruct.of_bytes b)) ;
-          Ok (hdr, Bytes.to_string b)
+          Ok (hdr, Cstruct.of_bytes b)
       else
-        Lwt.return (Ok (hdr, ""))
+        Lwt.return (Ok (hdr, Cstruct.empty))
 
-let write_raw s buf =
+let write_wire s buf =
-  let buf = Bytes.unsafe_of_string buf in
+  let buf = Cstruct.to_bytes buf in
   let rec w off l =
     Lwt.catch (fun () ->
         Lwt_unix.send s buf off l [] >>= fun n ->
@@ -87,5 +91,10 @@ let write_raw s buf =
          Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ;
          Lwt.return (Error `Exception))
   in
-  (* Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *)
+  Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ;
   w 0 (Bytes.length buf)
+
+let safe_close fd =
+  Lwt.catch
+    (fun () -> Lwt_unix.close fd)
+    (fun _ -> Lwt.return_unit)

src/vmm_tls.ml

@@ -26,14 +26,14 @@ let read_tls t =
             Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ;
             Lwt.return (Error `Exception))
   in
-  let buf = Cstruct.create 8 in
+  let buf = Cstruct.create (Int32.to_int Vmm_wire.header_size) in
-  r_n buf 0 8 >>= function
+  r_n buf 0 (Int32.to_int Vmm_wire.header_size) >>= function
   | Error e -> Lwt.return (Error e)
   | Ok () ->
-    match Vmm_wire.parse_header (Cstruct.to_string buf) with
+    match Vmm_wire.decode_header buf with
     | Error (`Msg m) -> Lwt.return (Error (`Msg m))
     | Ok hdr ->
-      let l = hdr.Vmm_wire.length in
+      let l = Int32.to_int hdr.Vmm_wire.length in
       if l > 0 then
         let b = Cstruct.create l in
         r_n b 0 l >|= function

src/vmm_wire.ml

@@ -3,124 +3,148 @@
 (* the wire protocol - length prepended binary data *)
 
 (* each message (on all channels) is prefixed by a common header:
-   - length (16 bit) spanning the message (excluding the 8 bytes header)
+   - tag (32 bit) the type of message
-   - id (16 bit) unique id chosen by sender (for request/reply) - 0 shouldn't be used (reserved for log/console messages which do not correspond to a request)
+      it is only 31 bit, the highest (leftmost) bit indicates query (0) or reply (1)
-   - version (16 bit) the version used on this channel
+      a failure is reported with the special tag 0xFFFFFFFF (all bits set) - data is a string
-   - tag (16 bit) the type of message
+      every request leads to a reply
+      WV0 and WV1 used 16 bit only
+   - version (16 bit) the version used on this channel (used to be byte 4-6)
+   - padding (16 bit)
+   - id (64 bit) unique id chosen by sender (for request/reply) - 0 shouldn't be used (reserved for log/console messages which do not correspond to a request)
+   - length (32 bit) spanning the message (excluding the 20 bytes header)
+   - full VM name (i.e. foo.bar.baz) encoded as size of list followed by list of strings
+   - replies do not contain the VM name
 
    Version and tag are protocol-specific - the channel between vmm and console
    uses different tags and mayuse a different version than between vmm and
-   client. *)
+   client.
+
+   every command issued is replied to with success or failure.  broadcast
+   communication (console data, log events) are not acknowledged by the
+   recipient.
+ *)
+
+
+(* TODO unlikely that this is 32bit clean *)
 
 open Astring
 
 open Vmm_core
 
-type version = [ `WV0 | `WV1 ]
+type version = [ `WV0 | `WV1 | `WV2 ]
 
 let version_to_int = function
   | `WV0 -> 0
   | `WV1 -> 1
+  | `WV2 -> 2
 
 let version_of_int = function
   | 0 -> Ok `WV0
   | 1 -> Ok `WV1
+  | 2 -> Ok `WV2
   | _ -> Error (`Msg "unknown wire version")
 
 let version_eq a b = match a, b with
   | `WV0, `WV0 -> true
   | `WV1, `WV1 -> true
+  | `WV2, `WV2 -> true
   | _ -> false
 
 let pp_version ppf v =
   Fmt.string ppf (match v with
       | `WV0 -> "wire version 0"
-      | `WV1 -> "wire version 1")
+      | `WV1 -> "wire version 1"
+      | `WV2 -> "wire version 2")
 
 type header = {
-  length : int ;
-  id : int ;
   version : version ;
-  tag : int ;
+  tag : int32 ;
+  length : int32 ;
+  id : int64 ;
 }
 
+let header_size = 20l
+
+let max_size = 0x7FFFFFFFl
+
+(* Throughout this module, we don't expect any cstruct bigger than the above
+   max_size (encode checks this!) *)
+
 open Rresult
 open R.Infix
 
+
+let cs_create len = Cstruct.create (Int32.to_int len)
+
+let cs_len cs =
+  let l = Cstruct.len cs in
+  assert (l lsr 31 = 0) ;
+  Int32.of_int l
+
 let check_len cs l =
-  if Cstruct.len cs < l then
+  if Int32.compare (cs_len cs) l = -1 then
     Error (`Msg "underflow")
   else
     Ok ()
 
+let cs_shift cs num =
+  check_len cs (Int32.of_int num) >>= fun () ->
+  Ok (Cstruct.shift cs num)
+
 let check_exact cs l =
-  if Cstruct.len cs = l then
+  if cs_len cs = l then
     Ok ()
   else
     Error (`Msg "bad length")
 
-let empty = Cstruct.create 0
-
 let null cs = if Cstruct.len cs = 0 then Ok () else Error (`Msg "trailing bytes")
 
-let parse_header buf =
+let decode_header cs =
-  let cs = Cstruct.of_string buf in
+  check_len cs 8l >>= fun () ->
-  check_len cs 8 >>= fun () ->
+  let version = Cstruct.BE.get_uint16 cs 4 in
-  let length = Cstruct.BE.get_uint16 cs 0
+  version_of_int version >>= function
-  and id = Cstruct.BE.get_uint16 cs 2
+  | `WV0 | `WV1 -> Error (`Msg "unsupported version")
-  and version = Cstruct.BE.get_uint16 cs 4
+  | `WV2 as version ->
-  and tag = Cstruct.BE.get_uint16 cs 6
+    check_len cs header_size >>= fun () ->
+    let tag = Cstruct.BE.get_uint32 cs 0
+    and id = Cstruct.BE.get_uint64 cs 8
+    and length = Cstruct.BE.get_uint32 cs 16
     in
-  version_of_int version >>= fun version ->
     Ok { length ; id ; version ; tag }
 
-let create_header { length ; id ; version ; tag } =
+let encode_header { length ; id ; version ; tag } =
-  let hdr = Cstruct.create 8 in
+  match version with
-  Cstruct.BE.set_uint16 hdr 0 length ;
+  | `WV0 | `WV1 -> invalid_arg "version no longer supported"
-  Cstruct.BE.set_uint16 hdr 2 id ;
+  | `WV2 ->
+    let hdr = cs_create header_size in
+    Cstruct.BE.set_uint32 hdr 0 tag ;
     Cstruct.BE.set_uint16 hdr 4 (version_to_int version) ;
-  Cstruct.BE.set_uint16 hdr 6 tag ;
+    Cstruct.BE.set_uint64 hdr 8 id ;
+    Cstruct.BE.set_uint32 hdr 16 length ;
     hdr
 
+let max_str_len = 0xFFFF
+
 let decode_string cs =
-  check_len cs 2 >>= fun () ->
+  check_len cs 2l >>= fun () ->
   let l = Cstruct.BE.get_uint16 cs 0 in
-  check_len cs (2 + l) >>= fun () ->
+  check_len cs (Int32.add 2l (Int32.of_int l)) >>= fun () ->
   let str = Cstruct.(to_string (sub cs 2 l)) in
   Ok (str, l + 2)
 
-(* external use only *)
-let decode_str str =
-  if String.length str = 0 then
-    Ok ("", 0)
-  else
-    decode_string (Cstruct.of_string str)
-
-let decode_strings cs =
-  let rec go acc buf =
-    if Cstruct.len buf = 0 then
-      Ok (List.rev acc)
-    else
-      decode_string buf >>= fun (x, l) ->
-      go (x :: acc) (Cstruct.shift buf l)
-  in
-  go [] cs
-
 let encode_string str =
   let l = String.length str in
+  assert (l < max_str_len) ;
   let cs = Cstruct.create (2 + l) in
   Cstruct.BE.set_uint16 cs 0 l ;
   Cstruct.blit_from_string str 0 cs 2 l ;
-  cs, 2 + l
+  cs
-
-let encode_strings xs =
-  Cstruct.concat
-    (List.map (fun s -> fst (encode_string s)) xs)
 
 let max = Int64.of_int max_int
 let min = Int64.of_int min_int
 
 let decode_int ?(off = 0) cs =
+  check_len cs Int32.(add (of_int off) 8l) >>= fun () ->
   let i = Cstruct.BE.get_uint64 cs off in
   if i > max then
     Error (`Msg "int too big")
@@ -134,35 +158,64 @@ let encode_int i =
   Cstruct.BE.set_uint64 cs 0 (Int64.of_int i) ;
   cs
 
-(* TODO: 32 bit system clean *)
+let decode_list inner buf =
-let decode_pid cs =
+  decode_int buf >>= fun len ->
-  check_len cs 4 >>= fun () ->
+  let rec go acc idx = function
-  let pid = Cstruct.BE.get_uint32 cs 0 in
+    | 0 -> Ok (List.rev acc, idx)
-  Ok (Int32.to_int pid)
+    | n ->
+      cs_shift buf idx >>= fun cs' ->
+      inner cs' >>= fun (data, len) ->
+      go (data :: acc) (idx + len) (pred n)
+  in
+  go [] 8 len
 
-(* TODO: can we do sth more appropriate than raise? *)
+let encode_list inner data =
-let encode_pid pid =
+  let cs = encode_int (List.length data) in
-  let cs = Cstruct.create 4 in
+  Cstruct.concat (cs :: (List.map inner data))
-  if Int32.to_int Int32.max_int > pid &&
-     Int32.to_int Int32.min_int < pid
-  then begin
-    Cstruct.BE.set_uint32 cs 0 (Int32.of_int pid) ;
-    cs
-  end else
-    invalid_arg "pid too big"
 
-let decode_ptime cs =
+let decode_strings = decode_list decode_string
-  check_len cs 16 >>= fun () ->
+
-  decode_int cs >>= fun d ->
+let encode_strings = encode_list encode_string
-  let ps = Cstruct.BE.get_uint64 cs 8 in
+
+let encode ?name ?body version id tag =
+  let vm = match name with None -> Cstruct.empty | Some id -> encode_strings id in
+  let payload = match body with None -> Cstruct.empty | Some x -> x in
+  let header =
+    let length = Int32.(add (cs_len payload) (cs_len vm)) in
+    { length ; id ; version ; tag }
+  in
+  Cstruct.concat [ encode_header header ; vm ; payload ]
+
+let maybe_str = function
+  | None -> Cstruct.empty
+  | Some c -> encode_string c
+
+let fail_tag = 0xFFFFFFFFl
+
+let reply_tag = 0x80000000l
+
+let is_tag v tag = Int32.logand v tag = v
+
+let is_reply { tag ; _ } = is_tag reply_tag tag
+
+let is_fail { tag ; _ } = is_tag fail_tag tag
+
+let reply ?body version id tag =
+  encode ?body version id (Int32.logor reply_tag tag)
+
+let fail ?msg version id =
+  encode ~body:(maybe_str msg) version id fail_tag
+
+let success ?msg version id tag =
+  reply ~body:(maybe_str msg) version id tag
+
+let decode_ptime ?(off = 0) cs =
+  cs_shift cs off >>= fun cs' ->
+  check_len cs' 16l >>= fun () ->
+  decode_int cs' >>= fun d ->
+  let ps = Cstruct.BE.get_uint64 cs' 8 in
   Ok (Ptime.v (d, ps))
 
-(* EXPORT only *)
-let decode_ts ?(off = 0) buf =
-  let cs = Cstruct.of_string buf in
-  let cs = Cstruct.shift cs off in
-  decode_ptime cs
-
 let encode_ptime ts =
   let d, ps = Ptime.(Span.to_d_ps (to_span ts)) in
   let cs = Cstruct.create 16 in
@@ -170,99 +223,70 @@ let encode_ptime ts =
   Cstruct.BE.set_uint64 cs 8 ps ;
   cs
 
-let fail_tag = 0xFFFE
-let success_tag = 0xFFFF
-
-let may_enc_str = function
-  | None -> empty, 0
-  | Some msg -> encode_string msg
-
-let success ?msg id version =
-  let data, length = may_enc_str msg in
-  let r =
-    Cstruct.append
-      (create_header { length ; id ; version ; tag = success_tag }) data
-  in
-  Cstruct.to_string r
-
-let fail ?msg id version =
-  let data, length = may_enc_str msg in
-  let r =
-    Cstruct.append
-      (create_header { length ; id ; version ; tag =  fail_tag }) data
-  in
-  Cstruct.to_string r
-
 module Console = struct
-  [%%cenum
   type op =
     | Add_console
     | Attach_console
     | Detach_console
     | History
-      | Data
+    | Data (* is a reply, never acked *)
-    [@@uint16_t]
-  ]
 
-  let encode id version op ?payload nam =
+  let op_to_int = function
-    let data, l = encode_string nam in
+    | Add_console -> 0x0100l
-    let length, p =
+    | Attach_console -> 0x0101l
-      match payload with
+    | Detach_console -> 0x0102l
-      | None -> l, empty
+    | History -> 0x0103l
-      | Some x -> l + Cstruct.len x, x
+    | Data -> 0x0104l
-    and tag = op_to_int op
-    in
-    let r =
-      Cstruct.concat
-        [ (create_header { length ; id ; version ; tag }) ; data ; p ]
-    in
-    Cstruct.to_string r
 
-  let data ?(id = 0) v file ts msg =
+  let int_to_op = function
-    let payload =
+    | 0x0100l -> Some Add_console
+    | 0x0101l -> Some Attach_console
+    | 0x0102l -> Some Detach_console
+    | 0x0103l -> Some History
+    | 0x0104l -> Some Data
+    | _ -> None
+
+  let data version name ts msg =
+    let body =
       let ts = encode_ptime ts
-      and data, _ = encode_string msg
+      and data = encode_string msg
       in
       Cstruct.append ts data
     in
-    encode id v Data ~payload file
+    encode version ~name ~body 0L (op_to_int Data)
 
-  let add id v name = encode id v Add_console name
+  let add id version name = encode ~name version id (op_to_int Add_console)
 
-  let attach id v name = encode id v Attach_console name
+  let attach id version name = encode ~name version id (op_to_int Attach_console)
 
-  let detach id v name = encode id v Detach_console name
+  let detach id version name = encode ~name version id (op_to_int Detach_console)
 
-  let history id v name since =
+  let history id version name since =
-    let payload = encode_ptime since in
+    let body = encode_ptime since in
-    encode id v History ~payload name
+    encode ~name ~body version id (op_to_int History)
 end
 
 module Stats = struct
-  [%%cenum
   type op =
     | Add
     | Remove
-      | Stat_request
+    | Stats
-      | Stat_reply
-    [@@uint16_t]
-  ]
 
-  let encode id version op ?payload nam =
+  let op_to_int = function
-    let data, l = encode_string nam in
+    | Add -> 0x0200l
-    let length, p =
+    | Remove -> 0x0201l
-      match payload with
+    | Stats -> 0x0202l
-      | None -> l, empty
+
-      | Some x -> l + Cstruct.len x, x
+  let int_to_op = function
-    and tag = op_to_int op
+    | 0x0200l -> Some Add
-    in
+    | 0x0201l -> Some Remove
-    let r =
+    | 0x0202l -> Some Stats
-      Cstruct.concat [ create_header { length ; version ; id ; tag } ; data ; p ]
+    | _ -> None
-    in
+
-    Cstruct.to_string r
+  let rusage_len = 144l
 
   let encode_rusage ru =
-    let cs = Cstruct.create (18 * 8) in
+    let cs = cs_create rusage_len in
     Cstruct.BE.set_uint64 cs 0 (fst ru.utime) ;
     Cstruct.BE.set_uint64 cs 8 (Int64.of_int (snd ru.utime)) ;
     Cstruct.BE.set_uint64 cs 16 (fst ru.stime) ;
@@ -284,7 +308,7 @@ module Stats = struct
     cs
 
   let decode_rusage cs =
-    check_exact cs 144 >>= fun () ->
+    check_exact cs rusage_len >>= fun () ->
     (decode_int ~off:8 cs >>= fun ms ->
      Ok (Cstruct.BE.get_uint64 cs 0, ms)) >>= fun utime ->
     (decode_int ~off:24 cs >>= fun ms ->
@@ -307,9 +331,11 @@ module Stats = struct
     Ok { utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ;
          nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw }
 
+  let ifdata_len = 116l
+
   let encode_ifdata i =
-    let name, _ = encode_string i.name in
+    let name = encode_string i.name in
-    let cs = Cstruct.create (12 * 8 + 5 * 4) in
+    let cs = cs_create ifdata_len in
     Cstruct.BE.set_uint32 cs 0 i.flags ;
     Cstruct.BE.set_uint32 cs 4 i.send_length ;
     Cstruct.BE.set_uint32 cs 8 i.max_send_length ;
@@ -331,8 +357,8 @@ module Stats = struct
 
   let decode_ifdata buf =
     decode_string buf >>= fun (name, l) ->
-    check_len buf (l + 116) >>= fun () ->
+    cs_shift buf l >>= fun cs ->
-    let cs = Cstruct.shift buf l in
+    check_len cs ifdata_len >>= fun () ->
     let flags = Cstruct.BE.get_uint32 cs 0
     and send_length = Cstruct.BE.get_uint32 cs 4
     and max_send_length = Cstruct.BE.get_uint32 cs 8
@@ -355,24 +381,18 @@ module Stats = struct
           baudrate ; input_packets ; input_errors ; output_packets ;
           output_errors ; collisions ; input_bytes ; output_bytes ; input_mcast ;
           output_mcast ; input_dropped ; output_dropped },
-        l + 116)
+        Int32.(to_int ifdata_len) + l)
 
-  let add id v nam pid taps =
+  let add id version name pid taps =
-    let payload = Cstruct.append (encode_pid pid) (encode_strings taps) in
+    let body = Cstruct.append (encode_int pid) (encode_strings taps) in
-    encode id v Add ~payload nam
+    encode ~name ~body version id (op_to_int Add)
 
-  let remove id v nam = encode id v Remove nam
+  let remove id version name = encode ~name version id (op_to_int Remove)
 
-  let stat id v nam = encode id v Stat_request nam
+  let stat id version name = encode ~name version id (op_to_int Stats)
 
-  let stat_reply id version payload =
+  let stat_reply id version body =
-    let length = Cstruct.len payload
+    reply ~body version id (op_to_int Stats)
-    and tag = op_to_int Stat_reply
-    in
-    let r =
-      Cstruct.append (create_header { length ; id ; version ; tag }) payload
-    in
-    Cstruct.to_string r
 
   let encode_int64 i =
     let cs = Cstruct.create 8 in
@@ -380,87 +400,76 @@ module Stats = struct
     cs
 
   let decode_int64 ?(off = 0) cs =
-    check_len cs (8 + off) >>= fun () ->
+    check_len cs (Int32.add 8l (Int32.of_int off)) >>= fun () ->
     Ok (Cstruct.BE.get_uint64 cs off)
 
-  let encode_vmm_stats xs =
+  let encode_vmm_stats =
-    encode_int (List.length xs) ::
+    encode_list
-    List.flatten
+      (fun (k, v) -> Cstruct.append (encode_string k) (encode_int64 v))
-      (List.map (fun (k, v) -> [ fst (encode_string k) ; encode_int64 v ]) xs)
 
-  let decode_vmm_stats cs =
+  let decode_vmm_stats =
-    let rec go acc ctr buf =
+    decode_list (fun buf ->
-      if ctr = 0 then
-        Ok (List.rev acc, buf)
-      else
         decode_string buf >>= fun (str, off) ->
         decode_int64 ~off buf >>= fun v ->
-        go ((str, v) :: acc) (pred ctr) (Cstruct.shift buf (off + 8))
+        Ok ((str, v), off + 8))
-    in
-    decode_int cs >>= fun stat_num ->
-    go [] stat_num (Cstruct.shift cs 8)
 
   let encode_stats (ru, vmm, ifd) =
     Cstruct.concat
-      (encode_rusage ru ::
+      [ encode_rusage ru ;
-       encode_vmm_stats vmm @
+        encode_vmm_stats vmm ;
-       encode_int (List.length ifd) :: List.map encode_ifdata ifd)
+        encode_list encode_ifdata ifd ]
 
   let decode_stats cs =
-    check_len cs 144 >>= fun () ->
+    check_len cs rusage_len >>= fun () ->
-    let ru, rest = Cstruct.split cs 144 in
+    let ru, rest = Cstruct.split cs (Int32.to_int rusage_len) in
     decode_rusage ru >>= fun ru ->
-    decode_vmm_stats rest >>= fun (vmm, rest) ->
+    decode_vmm_stats rest >>= fun (vmm, off) ->
-    let rec go acc ctr buf =
+    cs_shift rest off >>= fun rest' ->
-      if ctr = 0 then
+    decode_list decode_ifdata rest' >>= fun (ifs, _) ->
-        Ok (List.rev acc, buf)
-      else
-        decode_ifdata buf >>= fun (this, used) ->
-        go (this :: acc) (pred ctr) (Cstruct.shift buf used)
-    in
-    decode_int rest >>= fun num_if ->
-    go [] num_if (Cstruct.shift rest 8) >>= fun (ifs, _rest) ->
     Ok (ru, vmm, ifs)
 
   let decode_pid_taps data =
-    decode_pid data >>= fun pid ->
+    decode_int data >>= fun pid ->
-    decode_strings (Cstruct.shift data 4) >>= fun taps ->
+    decode_strings (Cstruct.shift data 8) >>= fun (taps, _off) ->
     Ok (pid, taps)
 end
 
+let decode_id_ts cs =
+  decode_strings cs >>= fun (id, off) ->
+  decode_ptime ~off cs >>= fun ts ->
+  Ok ((id, ts), off + 16)
+
+let split_id id = match List.rev id with
+  | [] -> Error (`Msg "bad header")
+  | name::rest -> Ok (name, List.rev rest)
+
 module Log = struct
-  [%%cenum
   type op =
-      | Data
+    | Log
     | History
-    [@@uint16_t]
+    | Broadcast
-  ]
+    | Subscribe
 
-  let history id version ctx ts =
+  let op_to_int = function
-    let tag = op_to_int History in
+    | Log -> 0x0300l
-    let nam, _ = encode_string ctx in
+    | History -> 0x0301l
-    let payload = Cstruct.append nam (encode_ptime ts) in
+    | Broadcast -> 0x0302l
-    let length = Cstruct.len payload in
+    | Subscribe -> 0x0303l
-    let r =
-      Cstruct.append (create_header { length ; version ; id ; tag }) payload
-    in
-    Cstruct.to_string r
 
-  let encode_log_hdr ?(drop_context = false) hdr =
+  let int_to_op = function
-    let ts = encode_ptime hdr.Log.ts
+    | 0x0300l -> Some Log
-    and ctx, _ = encode_string (if drop_context then "" else (string_of_id hdr.Log.context))
+    | 0x0301l -> Some History
-    and name, _ = encode_string hdr.Log.name
+    | 0x0302l -> Some Broadcast
-    in
+    | 0x0303l -> Some Subscribe
-    Cstruct.concat [ ts ; ctx ; name ]
+    | _ -> None
+
+  let history id version name ts =
+    encode ~name ~body:(encode_ptime ts) version id (op_to_int History)
 
   let decode_log_hdr cs =
-    decode_ptime cs >>= fun ts ->
+    decode_id_ts cs >>= fun ((id, ts), off) ->
-    let r = Cstruct.shift cs 16 in
+    split_id id >>= fun (name, context) ->
-    decode_string r >>= fun (ctx, l) ->
+    Ok ({ Log.ts ; context ; name }, Cstruct.shift cs (16 + off))
-    let context = id_of_string ctx in
-    let r = Cstruct.shift r l in
-    decode_string r >>= fun (name, l) ->
-    Ok ({ Log.ts ; context ; name }, Cstruct.shift r l)
 
   let encode_addr ip port =
     let cs = Cstruct.create 6 in
@@ -469,24 +478,25 @@ module Log = struct
     cs
 
   let decode_addr cs =
-    check_len cs 6 >>= fun () ->
+    check_len cs 6l >>= fun () ->
     let ip = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 cs 0)
     and port = Cstruct.BE.get_uint16 cs 4
     in
     Ok (ip, port)
 
   let encode_vm (pid, taps, block) =
-    let cs = encode_pid pid in
+    let cs = encode_int pid in
-    let bl, _ = encode_string (match block with None -> "" | Some x -> x) in
+    let bl = encode_string (match block with None -> "" | Some x -> x) in
     let taps = encode_strings taps in
     Cstruct.concat [ cs ; bl ; taps ]
 
   let decode_vm cs =
-    decode_pid cs >>= fun pid ->
+    decode_int cs >>= fun pid ->
-    let r = Cstruct.shift cs 4 in
+    let r = Cstruct.shift cs 8 in
     decode_string r >>= fun (block, l) ->
     let block = if block = "" then None else Some block in
-    decode_strings (Cstruct.shift r l) >>= fun taps ->
+    cs_shift r l >>= fun r' ->
+    decode_strings r' >>= fun taps ->
     Ok (pid, taps, block)
 
   let encode_pid_exit pid c =
@@ -495,19 +505,17 @@ module Log = struct
       | `Signal n -> 1, n
       | `Stop n -> 2, n
     in
-    let cs = Cstruct.create 1 in
+    let r_cs = encode_int r
-    Cstruct.set_uint8 cs 0 r ;
+    and pid_cs = encode_int pid
-    let pid = encode_pid pid
+    and c_cs = encode_int c
-    and code = encode_int c
     in
-    Cstruct.concat [ pid ; cs ; code ]
+    Cstruct.concat [ pid_cs ; r_cs ; c_cs ]
 
   let decode_pid_exit cs =
-    check_len cs 13 >>= fun () ->
+    check_len cs 24l >>= fun () ->
-    decode_pid cs >>= fun pid ->
+    decode_int cs >>= fun pid ->
-    let r = Cstruct.get_uint8 cs 4 in
+    decode_int ~off:8 cs >>= fun r ->
-    let code = Cstruct.shift cs 5 in
+    decode_int ~off:16 cs >>= fun c ->
-    decode_int code >>= fun c ->
     (match r with
      | 0 -> Ok (`Exit c)
      | 1 -> Ok (`Signal c)
@@ -515,43 +523,20 @@ module Log = struct
      | _ -> Error (`Msg "couldn't parse exit status")) >>= fun r ->
     Ok (pid, r)
 
-  let encode_block nam siz =
-    Cstruct.append (fst (encode_string nam)) (encode_int siz)
-
-  let decode_block cs =
-    decode_string cs >>= fun (nam, l) ->
-    check_len cs (l + 8) >>= fun () ->
-    decode_int ~off:l cs >>= fun siz ->
-    Ok (nam, siz)
-
-  let encode_delegate bridges bs =
-    Cstruct.append
-      (fst (encode_string (match bs with None -> "" | Some x -> x)))
-      (encode_strings bridges)
-
-  let decode_delegate buf =
-    decode_string buf >>= fun (bs, l) ->
-    let bs = if bs = "" then None else Some bs in
-    decode_strings (Cstruct.shift buf l) >>= fun bridges ->
-    Ok (bridges, bs)
-
   let encode_event ev =
     let tag, data = match ev with
-      | `Startup -> 0, empty
+      | `Startup -> 0, Cstruct.empty
       | `Login (ip, port) -> 1, encode_addr ip port
       | `Logout (ip, port) -> 2, encode_addr ip port
       | `VM_start vm -> 3, encode_vm vm
       | `VM_stop (pid, c) -> 4, encode_pid_exit pid c
-      | `Block_create (nam, siz) -> 5, encode_block nam siz
-      | `Block_destroy nam -> 6, fst (encode_string nam)
-      | `Delegate (bridges, bs) -> 7, encode_delegate bridges bs
     in
     let cs = Cstruct.create 2 in
     Cstruct.BE.set_uint16 cs 0 tag ;
     Cstruct.append cs data
 
   let decode_event cs =
-    check_len cs 2 >>= fun () ->
+    check_len cs 2l >>= fun () ->
     let data = Cstruct.(shift cs 2) in
     match Cstruct.BE.get_uint16 cs 0 with
      | 0 -> Ok `Startup
@@ -559,55 +544,139 @@ module Log = struct
      | 2 -> decode_addr data >>= fun addr -> Ok (`Logout addr)
      | 3 -> decode_vm data >>= fun vm -> Ok (`VM_start vm)
      | 4 -> decode_pid_exit data >>= fun ex -> Ok (`VM_stop ex)
-     | 5 -> decode_block data >>= fun bl -> Ok (`Block_create bl)
-     | 6 -> decode_string data >>= fun (nam, _) -> Ok (`Block_destroy nam)
-     | 7 -> decode_delegate data >>= fun d -> Ok (`Delegate d)
      | x -> R.error_msgf "couldn't parse event type %d" x
 
-  let data id version hdr event =
+  let log id version hdr event =
-    let hdr = encode_log_hdr hdr
+    let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event)
-    and ev = encode_event event
+    and name = hdr.Log.context @ [ hdr.Log.name ]
     in
-    let payload = Cstruct.append hdr ev in
+    encode ~name ~body version id (op_to_int Log)
-    let length = Cstruct.len payload
-    and tag = op_to_int Data
-    in
-    let r =
-      Cstruct.append (create_header { length ; id ; version ; tag }) payload
-    in
-    Cstruct.to_string r
 end
 
-module Client = struct
+module Vm = struct
-  let cmd_to_int = function
+  type op =
-    | Info -> 0
+    | Create
-    | Destroy_vm -> 1
+    | Destroy
-    | Create_block -> 2
+    | Info
-    | Destroy_block -> 3
+    (* | Add_policy *)
-    | Statistics -> 4
+
-    | Attach -> 5
+  let op_to_int = function
-    | Detach -> 6
+    | Create -> 0x0400l
-    | Log -> 7
+    | Destroy -> 0x0401l
-  and cmd_of_int = function
+    | Info -> 0x0402l
-    | 0 -> Some Info
+
-    | 1 -> Some Destroy_vm
+  let int_to_op = function
-    | 2 -> Some Create_block
+    | 0x0400l -> Some Create
-    | 3 -> Some Destroy_block
+    | 0x0401l -> Some Destroy
-    | 4 -> Some Statistics
+    | 0x0402l -> Some Info
-    | 5 -> Some Attach
-    | 6 -> Some Detach
-    | 7 -> Some Log
     | _ -> None
 
-  let console_msg_tag = 0xFFF0
+  let info id version name =
-  let log_msg_tag = 0xFFF1
+    encode ~name version id (op_to_int Info)
-  let stat_msg_tag = 0xFFF2
+
-  let info_msg_tag = 0xFFF3
+  let encode_vm vm =
+    let name = encode_strings (vm.config.prefix @ [ 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
+    and taps = encode_strings vm.taps
+    in
+    Cstruct.concat [ name ; memory ; cs ; pid ; taps ]
+
+  let info_reply id version vms =
+    let body = encode_list encode_vm vms in
+    reply ~body version id (op_to_int Info)
+
+  let decode_vm cs =
+    decode_strings cs >>= fun (id, l) ->
+    cs_shift cs l >>= fun cs' ->
+    decode_int cs' >>= fun memory ->
+    cs_shift cs' 8 >>= fun cs'' ->
+    decode_string cs'' >>= fun (cmd, l') ->
+    cs_shift cs'' l' >>= fun cs''' ->
+    decode_int cs''' >>= fun pid ->
+    cs_shift cs''' 8 >>= fun cs'''' ->
+    decode_strings cs'''' >>= fun (taps, l'') ->
+    Ok ((id, memory, cmd, pid, taps), l + 8 + l' + l'')
+
+  let decode_vms buf = decode_list decode_vm buf
+
+  let encode_vm_config vm =
+    let cpu = encode_int vm.cpuid
+    and mem = encode_int vm.requested_memory
+    and block = encode_string (match vm.block_device with None -> "" | Some x -> x)
+    and network = encode_strings vm.network
+    and vmimage = Cstruct.concat [ encode_int (vmtype_to_int (fst vm.vmimage)) ;
+                                   encode_int (Cstruct.len (snd vm.vmimage)) ;
+                                   snd vm.vmimage ]
+    and args = encode_strings (match vm.argv with None -> [] | Some args -> args)
+    in
+    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) ->
+    cs_shift buf off >>= fun buf' ->
+    decode_int buf' >>= fun cpuid ->
+    Logs.debug (fun m -> m "cpuid %d" cpuid) ;
+    decode_int ~off:8 buf' >>= fun requested_memory ->
+    Logs.debug (fun m -> m "mem %d" requested_memory) ;
+    cs_shift buf' 16 >>= fun buf'' ->
+    decode_string buf'' >>= fun (block, off) ->
+    Logs.debug (fun m -> m "block %s" block) ;
+    cs_shift buf'' off >>= fun buf''' ->
+    let block_device = if block = "" then None else Some block in
+    decode_strings buf''' >>= fun (network, off') ->
+    cs_shift buf''' off' >>= fun buf'''' ->
+    decode_int buf'''' >>= fun vmtype ->
+    (match int_to_vmtype vmtype with
+     | Some x -> Ok x
+     | None -> Error (`Msg "unknown vmtype")) >>= fun vmtype ->
+    decode_int ~off:8 buf'''' >>= fun size ->
+    check_len buf'''' (Int32.of_int size) >>= fun () ->
+    let vmimage = (vmtype, Cstruct.sub buf'''' 16 size) in
+    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 }
+
+  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)
+
+  let destroy id version name =
+    encode ~name version id (op_to_int Destroy)
+end
+
+(*
+module Client = struct
+  let cmd_to_int = function
+    | Info -> 0x0500l
+    | Destroy_vm -> 0x0501l
+    | Create_block -> 0x0502l
+    | Destroy_block -> 0x0503l
+    | Statistics -> 0x0504l
+    | Attach -> 0x0505l
+    | Detach -> 0x0506l
+    | Log -> 0x0507l
+  and cmd_of_int = function
+    | 0x0500l -> Some Info
+    | 0x0501l -> Some Destroy_vm
+    | 0x0502l -> Some Create_block
+    | 0x0503l -> Some Destroy_block
+    | 0x0504l -> Some Statistics
+    | 0x0505l -> Some Attach
+    | 0x0506l -> Some Detach
+    | 0x0507l -> Some Log
+    | _ -> None
 
   let cmd ?arg it id version =
     let pay, length = may_enc_str arg
     and tag = cmd_to_int it
     in
+    let length = Int32.of_int length in
     let hdr = create_header { length ; id ; version ; tag } in
     Cstruct.(to_string (append hdr pay))
 
@@ -617,17 +686,17 @@ module Client = struct
         (Log.encode_log_hdr ~drop_context:true hdr)
         (Log.encode_event event)
     in
-    let length = Cstruct.len payload in
+    let length = cs_len payload in
     let r =
       Cstruct.append
-        (create_header { length ; id = 0 ; version ; tag = log_msg_tag })
+        (create_header { length ; id = 0L ; version ; tag = Log.(op_to_int Data) })
         payload
     in
     Cstruct.to_string r
 
   let stat data id version =
-    let length = String.length data in
+    let length = Int32.of_int (String.length data) in
-    let hdr = create_header { length ; id ; version ; tag = stat_msg_tag } in
+    let hdr = create_header { length ; id ; version ; tag = Stats.(op_to_int Stat_reply) } in
     Cstruct.to_string hdr ^ data
 
   let console off name payload version =
@@ -640,15 +709,16 @@ module Client = struct
       let p' = Astring.String.drop ~max:off payload in
       p', l + String.length p'
     in
+    let length = Int32.of_int length in
     let hdr =
-      create_header { length ; id = 0 ; version ; tag = console_msg_tag }
+      create_header { length ; id = 0L ; version ; tag = Console.(op_to_int Data) }
     in
     Cstruct.(to_string (append hdr nam)) ^ payload
 
   let encode_vm name vm =
-    let name, _ = encode_string name
+    let name = encode_string name
-    and cs, _ = encode_string (Bos.Cmd.to_string vm.cmd)
+    and cs = encode_string (Bos.Cmd.to_string vm.cmd)
-    and pid = encode_pid vm.pid
+    and pid = encode_int vm.pid
     and taps = encode_strings vm.taps
     in
     let tapc = encode_int (Cstruct.len taps) in
@@ -657,13 +727,14 @@ module Client = struct
 
   let info data id version =
     let length = String.length data in
-    let hdr = create_header { length ; id ; version ; tag = info_msg_tag } in
+    let length = Int32.of_int length in
+    let hdr = create_header { length ; id ; version ; tag = success_tag } in
     Cstruct.to_string hdr ^ data
 
   let decode_vm cs =
     decode_string cs >>= fun (name, l) ->
     decode_string (Cstruct.shift cs l) >>= fun (cmd, l') ->
-    decode_pid (Cstruct.shift cs (l + l')) >>= fun pid ->
+    decode_int (Cstruct.shift cs (l + l')) >>= fun pid ->
     decode_int ~off:(l + l' + 4) cs >>= fun tapc ->
     let taps = Cstruct.sub cs (l + l' + 12) tapc in
     decode_strings taps >>= fun taps ->
@@ -695,3 +766,4 @@ module Client = struct
     decode_string (Cstruct.shift cs (l + 16)) >>= fun (line, _) ->
     Ok (name, ts, line)
 end
+                *)

src/vmm_x509.ml

@@ -0,0 +1,163 @@
+
+let asn_version = `AV0
+
+let handle_single_revocation t prefix serial =
+  let id = identifier serial in
+  (match Vmm_resources.find t.resources (prefix @ [ id ]) with
+   | None -> ()
+   | Some e -> Vmm_resources.iter Vmm_unix.destroy e) ;
+  (* also revoke all active sessions!? *)
+  (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *)
+  let log_attached, kill =
+    let pid = string_of_id prefix in
+    match String.Map.find pid t.log_attached with
+    | None -> t.log_attached, []
+    | Some xs ->
+      (* those where snd v = serial: drop *)
+      let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in
+      String.Map.add pid keep t.log_attached, drop
+  in
+  (* two things:
+     1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above]
+     2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *)
+  let log_attached, kill =
+    String.Map.fold (fun k' v (l, k) ->
+        if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then
+          (l, v @ k)
+        else
+          (String.Map.add k' v l, k))
+      log_attached
+      (String.Map.empty, kill)
+  in
+  let state, out =
+    List.fold_left (fun (s, out) (t, _) ->
+        let s', out' = handle_disconnect s t in
+        s', out @ out')
+      ({ t with log_attached }, [])
+      kill
+  in
+  (state,
+   List.map (fun x -> `Raw x) out,
+   List.map fst kill)
+
+let handle_revocation t s leaf chain ca prefix =
+  Vmm_asn.crl_of_cert leaf >>= fun crl ->
+  (* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *)
+  let issuer = match chain with
+    | subca::_ -> subca
+    | [] -> ca
+  in
+  let time = Ptime_clock.now () in
+  (if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () ->
+  (* the this_update must be > now, next_update < now, this_update > <local>.this_update, number > <local>.number *)
+  (* TODO: can we have something better for uniqueness of CRL? *)
+  let local = try Some (List.find (fun crl -> X509.CRL.verify crl issuer) t.crls) with Not_found -> None in
+  (match local with
+   | None -> Ok ()
+   | Some local -> match X509.CRL.crl_number local, X509.CRL.crl_number crl with
+     | None, _ -> Ok ()
+     | Some _, None -> Error (`Msg "CRL number not present")
+     | Some x, Some y -> if y > x then Ok () else Error (`Msg "CRL number not increased")) >>= fun () ->
+  (* filename should be whatever_dir / crls / <id> *)
+  let filename = Fpath.(dbdir / "crls" / string_of_id prefix) in
+  Bos.OS.File.delete filename >>= fun () ->
+  Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () ->
+  (* remove crl with same issuer from crls, and inject this one into state *)
+  let crls =
+    match local with
+    | None -> crl :: t.crls
+    | Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls
+  in
+  (* iterate over revoked serials, find active resources, and kill them *)
+  let newly_revoked =
+    let old = match local with
+      | Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x)
+      | None -> []
+    in
+    let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in
+    List.filter (fun n -> not (List.mem n old)) new_rev
+  in
+  let t, out, close =
+    List.fold_left (fun (t, out, close) serial ->
+        let t', out', close' = handle_single_revocation t prefix serial in
+        (t', out @ out', close @ close'))
+      (t, [], []) newly_revoked
+  in
+  let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in
+  Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close)
+
+let handle_initial t s addr chain ca =
+  separate_chain chain >>= fun (leaf, chain) ->
+  Logs.debug (fun m -> m "leaf is %s, chain %a"
+                 (X509.common_name_to_string leaf)
+                 Fmt.(list ~sep:(unit "->") string)
+                 (List.map X509.common_name_to_string chain)) ;
+  (* TODO here: inspect top-level-cert of chain.
+     may need to create bridges and/or block device subdirectory (zfs create) *)
+  let prefix = List.map id chain in
+  let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in
+  let t, out = log t (login_hdr, login_ev) in
+  let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in
+  Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms ->
+  (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then
+     (* convert certificate to vm_config *)
+     Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
+     Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ;
+     (* get names and static resources *)
+     List.fold_left (fun acc ca ->
+         acc >>= fun acc ->
+         Vmm_asn.delegation_of_cert asn_version ca >>= fun res ->
+         let name = id ca in
+         Ok ((name, res) :: acc))
+       (Ok []) chain >>= fun policies ->
+     (* check static policies *)
+     Logs.debug (fun m -> m "now checking static policies") ;
+     check_policies vm_config (List.map snd policies) >>= fun () ->
+     let t, task =
+       let force = List.mem `Force_create perms in
+       if force then
+         let fid = vm_id vm_config in
+         match String.Map.find fid t.tasks with
+         | None -> t, None
+         | Some task ->
+           let kill () =
+             match Vmm_resources.find_vm t.resources (fullname vm_config) with
+             | None ->
+               Logs.err (fun m -> m "found a task, but no vm for %a (%s)"
+                            pp_id (fullname vm_config) fid)
+             | Some vm ->
+               Logs.debug (fun m -> m "killing %a now" pp_vm vm) ;
+               Vmm_unix.destroy vm
+           in
+           let tasks = String.Map.remove fid t.tasks in
+           ({ t with tasks }, Some (kill, task))
+       else
+         t, None
+     in
+     let next t sleeper =
+       handle_create t vm_config policies >>= fun cont ->
+       let id = vm_id vm_config in
+       let cons = Vmm_wire.Console.add t.console_counter t.console_version id in
+       let tasks = String.Map.add id sleeper t.tasks in
+       Ok ({ t with console_counter = succ t.console_counter ; tasks },
+           [ `Raw (t.console_socket, cons) ],
+           cont)
+     in
+     Ok (t, [], `Create (task, next))
+   else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
+     handle_revocation t s leaf chain ca prefix
+   else
+     let log_attached =
+       if cmd_allowed perms Log then
+         let pre = string_of_id prefix in
+         let v = match String.Map.find pre t.log_attached with
+           | None -> []
+           | Some xs -> xs
+         in
+         String.Map.add pre ((s, id leaf) :: v) t.log_attached
+       else
+         t.log_attached
+     in
+     Ok ({ t with log_attached }, [], `Loop (prefix, perms))
+  ) >>= fun (t, outs, res) ->
+  Ok (t, initial_out :: out @ outs, res)

stats/vmm_stats.ml

@@ -192,10 +192,9 @@ let remove_vmid t vmid =
 let remove_vmids t vmids =
   List.fold_left remove_vmid t vmids
 
-let handle t hdr buf =
+let handle t hdr cs =
   let open Vmm_wire in
   let open Vmm_wire.Stats in
-  let cs = Cstruct.of_string buf in
   let r =
     if not (version_eq my_version hdr.version) then
       Error (`Msg "cannot handle version")
@@ -205,11 +204,11 @@ let handle t hdr buf =
       | Some Add ->
         decode_pid_taps (Cstruct.shift cs off) >>= fun (pid, taps) ->
         add_pid t name pid taps >>= fun t ->
-        Ok (t, `Add name, success ~msg:"added" hdr.id my_version)
+        Ok (t, `Add name, success ~msg:"added" my_version hdr.id (op_to_int Add))
       | Some Remove ->
         let t = remove_vmid t name in
-        Ok (t, `Remove name, success ~msg:"removed" hdr.id my_version)
+        Ok (t, `Remove name, success ~msg:"removed" my_version hdr.id (op_to_int Remove))
-      | Some Stat_request ->
+      | Some Stats ->
         stats t name >>= fun s ->
         Ok (t, `None, stat_reply hdr.id my_version (encode_stats s))
       | _ -> Error (`Msg "unknown command")
@@ -218,4 +217,4 @@ let handle t hdr buf =
   | Ok (t, action, out) -> t, action, out
   | Error (`Msg msg) ->
     Logs.err (fun m -> m "error while processing %s" msg) ;
-    t, `None, fail ~msg hdr.id my_version
+    t, `None, fail ~msg my_version hdr.id

stats/vmm_stats_lwt.ml

@@ -24,11 +24,11 @@ let pp_sockaddr ppf = function
 let handle s addr () =
   Logs.info (fun m -> m "handling stats connection %a" pp_sockaddr addr) ;
   let rec loop acc =
-    Vmm_lwt.read_exactly s >>= function
+    Vmm_lwt.read_wire s >>= function
     | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop acc
     | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return acc
     | Ok (hdr, data) ->
-      Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp (Cstruct.of_string data)) ;
+      Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ;
       let t', action, out = Vmm_stats.handle !t hdr data in
       let acc = match action with
         | `Add pid -> pid :: acc
@@ -36,8 +36,8 @@ let handle s addr () =
         | `None -> acc
       in
       t := t' ;
-      Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
+      Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp out) ;
-      Vmm_lwt.write_raw s out >>= function
+      Vmm_lwt.write_wire s out >>= function
       | Ok () -> loop acc
       | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc
   in