refactor commands into vmm_commands

_tags

@@ -10,7 +10,7 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring
 
 <app/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress)
 <app/vmm_client.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
-<app/vmmd.{ml,native,byte}>: package(tls.lwt)
+<app/vmm_tls_endpoint.{ml,native,byte}>: package(tls.lwt)
 <app/vmm_prometheus_stats.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
 
 <provision/*>: package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt decompress)

app/vmm_tls_endpoint.ml

@@ -2,24 +2,42 @@
 
 open Lwt.Infix
 
-let write_tls state t data =
+let pp_sockaddr ppf = function
-  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 connect socket_path =
+  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_path) >|= fun () ->
+  c
+
+let client_auth ca tls addr =
+  Logs.debug (fun m -> m "connection from %a" pp_sockaddr addr) ;
+  let authenticator =
+    let time = Ptime_clock.now () in
+    X509.Authenticator.chain_of_trust ~time (* ~crls:!state.Vmm_engine.crls *) [ca]
+  in
+  Lwt.catch
+    (fun () -> Tls_lwt.Unix.reneg ~authenticator tls)
+    (fun e ->
+       (match e with
+        | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a))
+        | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f))
+        | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ;
+       Tls_lwt.Unix.close tls >>= fun () ->
+       Lwt.fail e) >>= fun () ->
+  (match Tls_lwt.Unix.epoch tls with
+   | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
+   | `Error ->
+     Tls_lwt.Unix.close tls >>= fun () ->
+     Lwt.fail_with "error while getting epoch")
+
+let handle ca (tls, addr) =
+  client_auth ca tls addr >>= fun chain ->
+  let _ = Vmm_x509.handle_initial tls addr chain ca in
+  Lwt.return_unit
 
 let server_socket port =
   let open Lwt_unix in
@@ -30,69 +48,10 @@ let server_socket port =
   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
@@ -102,16 +61,6 @@ let jump _ cacert cert priv_key port =
        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) ->
@@ -123,7 +72,7 @@ let jump _ cacert cert priv_key port =
                 Lwt.fail exn) >>= fun t ->
            Lwt.async (fun () ->
                Lwt.catch
-                 (fun () -> handle ca state t)
+                 (fun () -> handle ca t)
                  (fun e ->
                     Logs.err (fun m -> m "error while handle() %s"
                                  (Printexc.to_string e)) ;

app/vmmc.ml

@@ -6,31 +6,11 @@ open Astring
 
 open Vmm_core
 
-let my_version = `WV2
-let my_command = 1L
-
 let process fd =
   Vmm_lwt.read_wire fd >|= function
-  | Error _ -> Error ()
+  | Error (`Msg m) -> Error (`Msg m)
-  | Ok (hdr, data) ->
+  | Error _ -> Error (`Msg "read error")
-    if not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) then begin
+  | Ok data -> Vmm_commands.handle_reply data
-      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 socket t = function
   | Some x -> x
@@ -42,97 +22,94 @@ let connect socket_path =
   Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
   c
 
+let read fd f =
+  (* now we busy read and process output *)
+  let rec loop () =
+    Vmm_lwt.read_wire fd >>= function
+    | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop ()
+    | Error _ -> Lwt.return (Error (`Msg "exception while reading"))
+    | Ok (hdr, data) ->
+      Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ;
+      if Vmm_wire.is_fail hdr then
+        let msg = match Vmm_wire.decode_string data with
+          | Error _ -> ""
+          | Ok (m, _) -> m
+        in
+        Lwt.return (Error (`Msg ("operation failed " ^ msg)))
+      else if Vmm_wire.is_reply hdr then
+        let msg = match Vmm_wire.decode_string data with
+          | Error _ -> None
+          | Ok (m, _) -> Some m
+        in
+        Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ;
+        loop ()
+      else
+        match f (hdr, data) with
+        | Ok () -> loop ()
+        | Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
+  in
+  loop ()
+
+let handle opt_socket (cmd : Vmm_commands.t) f =
+  let sock, next, cmd = Vmm_commands.handle cmd in
+  connect (socket sock opt_socket) >>= fun fd ->
+  Vmm_lwt.write_wire fd cmd >>= function
+  | Error `Exception -> Lwt.return (Error (`Msg "couldn't write"))
+  | Ok () ->
+    (match next with
+     | `Read -> read fd f
+     | `End ->
+       process fd >|= function
+       | Error e -> Error e
+       | Ok data -> f data) >>= fun res ->
+    Vmm_lwt.safe_close fd >|= fun () ->
+    res
+
+let jump opt_socket cmd f =
+  match
+    Lwt_main.run (handle opt_socket cmd f)
+  with
+  | Ok () -> `Ok ()
+  | Error (`Msg m) -> `Error (false, m)
+
 let info_ _ opt_socket name =
-  Lwt_main.run (
+  jump opt_socket (`Info name) (fun (_, data) ->
-    connect (socket `Vmmd opt_socket) >>= fun fd ->
+      let open Rresult.R.Infix in
-    let info = Vmm_wire.Vm.info my_command my_version name in
+      Vmm_wire.Vm.decode_vms data >>| fun (vms, _) ->
-    (Vmm_lwt.write_wire fd info >>= function
+      List.iter (fun (id, memory, cmd, pid, taps) ->
-      | Ok () ->
+          Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a"
-        (process fd >|= function
+                       pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
-          | Error () -> ()
+        vms)
-          | 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 policy _ opt_socket name =
-  Lwt_main.run (
+  jump opt_socket (`Policy name) (fun (_, data) ->
-    connect (socket `Vmmd opt_socket) >>= fun fd ->
+      let open Rresult.R.Infix in
-    let policy = Vmm_wire.Vm.policy my_command my_version name in
+      Vmm_wire.Vm.decode_policies data >>| fun (policies, _) ->
-    (Vmm_lwt.write_wire fd policy >>= function
+      List.iter (fun (id, policy) ->
-      | Ok () ->
+          Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy))
-        (process fd >|= function
+        policies)
-          | Error () -> ()
-          | Ok data ->
-            match Vmm_wire.Vm.decode_policies data with
-            | Ok (policies, _) ->
-              List.iter (fun (id, policy) ->
-                  Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy))
-                policies
-            | Error (`Msg msg) ->
-              Logs.err (fun m -> m "error %s while decoding policies" msg))
-      | Error `Exception -> Lwt.return_unit) >>= fun () ->
-    Vmm_lwt.safe_close fd
-  ) ;
-  `Ok ()
 
 let remove_policy _ opt_socket name =
-  Lwt_main.run (
+  jump opt_socket (`Remove_policy name) (fun _ ->
-    connect (socket `Vmmd opt_socket) >>= fun fd ->
+      Ok (Logs.app (fun m -> m "removed policy")))
-    let cmd = Vmm_wire.Vm.remove_policy my_command my_version name in
-    (Vmm_lwt.write_wire fd cmd >>= function
-      | Ok () ->
-        (process fd >|= function
-          | Error () -> ()
-          | Ok _ -> Logs.app (fun m -> m "removed policy"))
-      | Error `Exception -> Lwt.return_unit) >>= fun () ->
-    Vmm_lwt.safe_close fd) ;
-  `Ok ()
 
 let add_policy _ opt_socket name vms memory cpus block bridges =
-  Lwt_main.run (
+  let bridges = match bridges with
-    connect (socket `Vmmd opt_socket) >>= fun fd ->
+    | xs ->
-    let bridges = match bridges with
+      let add m v =
-      | xs ->
+        let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
-        let add m v =
+        String.Map.add n v m
-          let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
+      in
-          String.Map.add n v m
+      List.fold_left add String.Map.empty xs
-        in
+  and cpuids = IS.of_list cpus
-        List.fold_left add String.Map.empty xs
+  in
-    and cpuids = IS.of_list cpus
+  let policy = { vms ; cpuids ; memory ; block ; bridges } in
-    in
+  jump opt_socket (`Add_policy (name, policy)) (fun _ ->
-    let policy = { vms ; cpuids ; memory ; block ; bridges } in
+      Ok (Logs.app (fun m -> m "added policy")))
-    let cmd = Vmm_wire.Vm.insert_policy my_command my_version name policy in
-    (Vmm_lwt.write_wire fd cmd >>= function
-      | Ok () ->
-        (process fd >|= function
-          | Error () -> ()
-          | Ok _ -> Logs.app (fun m -> m "added policy"))
-      | Error `Exception -> Lwt.return_unit) >>= fun () ->
-    Vmm_lwt.safe_close fd) ;
-  `Ok ()
 
 let destroy _ opt_socket name =
-  Lwt_main.run (
+  jump opt_socket (`Destroy_vm name) (fun _ ->
-    connect (socket `Vmmd opt_socket) >>= fun fd ->
+      Ok (Logs.app (fun m -> m "destroyed VM")))
-    let cmd = Vmm_wire.Vm.destroy my_command my_version 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) ;
-  `Ok ()
 
 let create _ opt_socket force name image cpuid requested_memory boot_params block_device network =
   let image' = match Bos.OS.File.read (Fpath.v image) with
@@ -149,177 +126,51 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc
     vname = name ; cpuid ; requested_memory ; block_device ; network ;
     vmimage ; argv
   } in
-  Lwt_main.run (
+  let cmd =
-    connect (socket `Vmmd opt_socket) >>= fun fd ->
+    if force then
-    let vm =
+      `Force_create_vm vm_config
-      if force then
+    else
-        Vmm_wire.Vm.force_create my_command my_version vm_config
+      `Create_vm vm_config
-      else
+  in
-        Vmm_wire.Vm.create my_command my_version vm_config
+  let succ _ = Ok (Logs.app (fun m -> m "successfully started VM")) in
-    in
+  jump opt_socket cmd succ
-    (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 console _ opt_socket name =
-  Lwt_main.run (
+  jump opt_socket (`Console name) (fun (hdr, data) ->
-    connect (socket `Console opt_socket) >>= fun fd ->
+      let open Rresult.R.Infix in
-    let cmd = Vmm_wire.Console.attach my_command my_version name in
+      match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with
-    (Vmm_lwt.write_wire fd cmd >>= function
+      | Some Vmm_wire.Console.Data ->
-      | Error `Exception ->
+        Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) ->
-        Logs.err (fun m -> m "couldn't write to socket") ;
+        Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) ->
-        Lwt.return_unit
+        Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ;
-      | Ok () ->
+        Ok ()
-        (* now we busy read and process console output *)
+      | _ ->
-        let rec loop () =
+        Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)))
-          Vmm_lwt.read_wire fd >>= 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, data) ->
-            Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ;
-            if Vmm_wire.is_fail hdr then
-              let msg = match Vmm_wire.decode_string data with
-                | Error _ -> None
-                | Ok (m, _) -> Some m
-              in
-              Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ;
-              Lwt.return_unit
-            else if Vmm_wire.is_reply hdr then
-              let msg = match Vmm_wire.decode_string data with
-                | Error _ -> None
-                | Ok (m, _) -> Some m
-              in
-              Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ;
-              loop ()
-            else
-              let r =
-                let open Rresult.R.Infix in
-                match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with
-                | Some Vmm_wire.Console.Data ->
-                  Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) ->
-                  Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) ->
-                  Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ;
-                  Ok ()
-                | _ ->
-                  Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag))
-              in
-              match r with
-              | Ok () -> loop ()
-              | Error (`Msg msg) ->
-                Logs.err (fun m -> m "%s" msg) ;
-                Lwt.return_unit
-        in
-        loop ()) >>= fun () ->
-    Vmm_lwt.safe_close fd) ;
-  `Ok ()
 
-let stats _ opt_socket vm =
+let stats _ opt_socket name =
-  Lwt_main.run (
+  jump opt_socket (`Statistics name) (fun (hdr, data) ->
-    connect (socket `Stats opt_socket) >>= fun fd ->
+      let open Rresult.R.Infix in
-    let cmd = Vmm_wire.Stats.subscribe my_command my_version vm in
+      match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with
-    (Vmm_lwt.write_wire fd cmd >>= function
+      | Some Vmm_wire.Stats.Data ->
-      | Error `Exception -> Lwt.fail_with "write error"
+        Vmm_wire.decode_strings data >>= fun (name', off) ->
-      | Ok () -> Lwt.return_unit) >>= fun () ->
+        Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) ->
-    (* now we busy read and process stat output *)
+        Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@."
-    let rec loop () =
+                     pp_id name' Vmm_core.pp_rusage ru
-      Vmm_lwt.read_wire fd >>= function
+                     Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm
-      | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop ()
+                     Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ;
-      | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit
+      | _ ->
-      | Ok (hdr, data) ->
+        Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)))
-        if Vmm_wire.is_fail hdr then
-          let msg = match Vmm_wire.decode_string data with
-            | Error _ -> None
-            | Ok (m, _) -> Some m
-          in
-          Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ;
-          Lwt.return_unit
-        else if Vmm_wire.is_reply hdr then
-          let msg = match Vmm_wire.decode_string data with
-            | Error _ -> None
-            | Ok (m, _) -> Some m
-          in
-          Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ;
-          loop ()
-        else
-          let r =
-            let open Rresult.R.Infix in
-            match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with
-            | Some Vmm_wire.Stats.Data ->
-              Vmm_wire.decode_strings data >>= fun (id, off) ->
-              Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun stats ->
-              (Astring.String.concat ~sep:"." id, stats)
-            | _ ->
-              Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag))
-          in
-          match r with
-          | Ok (name, (ru, vmm, ifs)) ->
-            Logs.app (fun m -> m "stats %s@.%a@.%a@.%a@."
-                         name Vmm_core.pp_rusage ru
-                         Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm
-                         Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ;
-            loop ()
-          | Error (`Msg msg) ->
-            Logs.err (fun m -> m "%s" msg) ;
-            Lwt.return_unit
-    in
-    loop () >>= fun () ->
-    Vmm_lwt.safe_close fd) ;
-  `Ok ()
 
-let event_log _ opt_socket vm =
+let event_log _ opt_socket name =
-  Lwt_main.run (
+  jump opt_socket (`Log name) (fun (hdr, data) ->
-    connect (socket `Log opt_socket) >>= fun fd ->
+      let open Rresult.R.Infix in
-    let cmd = Vmm_wire.Log.subscribe my_command my_version vm in
+      match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with
-    (Vmm_lwt.write_wire fd cmd >>= function
+      | Some Vmm_wire.Log.Broadcast ->
-      | Error `Exception -> Lwt.fail_with "write error"
+        Vmm_wire.Log.decode_log_hdr data >>= fun (loghdr, logdata) ->
-      | Ok () -> Lwt.return_unit) >>= fun () ->
+        Vmm_wire.Log.decode_event logdata >>| fun event ->
-    (* now we busy read and process stat output *)
+        Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event))
-    let rec loop () =
+      | _ ->
-      Vmm_lwt.read_wire fd >>= function
+        Ok (Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag)))
-      | 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, data) ->
-        if Vmm_wire.is_fail hdr then
-          let msg = match Vmm_wire.decode_string data with
-            | Error _ -> None
-            | Ok (m, _) -> Some m
-          in
-          Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ;
-          Lwt.return_unit
-        else if Vmm_wire.is_reply hdr then
-          let msg = match Vmm_wire.decode_string data with
-            | Error _ -> None
-            | Ok (m, _) -> Some m
-          in
-          Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ;
-          loop ()
-        else
-          begin
-            (match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with
-             | Some Vmm_wire.Log.Broadcast ->
-               begin match Vmm_wire.Log.decode_log_hdr data with
-                 | Error (`Msg err) ->
-                   Logs.warn (fun m -> m "ignoring error %s while decoding log" err) ;
-                 | Ok (loghdr, logdata) ->
-                   match Vmm_wire.Log.decode_event logdata with
-                   | Error (`Msg err) ->
-                     Logs.warn (fun m -> m "loghdr %a ignoring error %s while decoding logdata"
-                                   Vmm_core.Log.pp_hdr loghdr err)
-                   | Ok event ->
-                     Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event))
-               end
-             | _ ->
-               Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag)) ;
-            loop ()
-          end
-    in
-    loop () >>= fun () ->
-    Vmm_lwt.safe_close fd) ;
-  `Ok ()
 
 let help _ _ man_format cmds = function
   | None -> `Help (`Pager, None)

pkg/pkg.ml

@@ -10,7 +10,7 @@ let () =
     Pkg.bin "app/vmm_console" ;
     Pkg.bin "app/vmm_log" ;
     (* Pkg.bin "app/vmm_client" ; *)
-    (* Pkg.bin "app/vmm_tls_endpoint" ; *)
+    Pkg.bin "app/vmm_tls_endpoint" ;
     Pkg.bin "app/vmmc" ;
     Pkg.bin "provision/vmm_req_command" ;
     Pkg.bin "provision/vmm_req_delegation" ;

src/vmm_commands.ml

@@ -1,223 +1,71 @@
-(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
-
-open Astring
 
 open Vmm_core
 
-open Rresult
+let c = 0L
-open R.Infix
+let ver = `WV2
 
-let handle_command t s prefix perms hdr buf =
+type t = [
-  let res =
+  | `Info of id
-    if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
+  | `Policy of id
-      Error (`Msg "unknown client version")
+  | `Add_policy of id * policy
-    else match Vmm_wire.Client.cmd_of_int hdr.Vmm_wire.tag with
+  | `Remove_policy of id
-      | None -> Error (`Msg "unknown command")
+  | `Create_vm of vm_config
-      | Some x when cmd_allowed perms x ->
+  | `Force_create_vm of vm_config
-        begin
+  | `Destroy_vm of id
-          Vmm_wire.decode_str buf >>= fun (buf, _l) ->
+  | `Statistics of id
-          let arg = if String.length buf = 0 then prefix else prefix @ [buf] in
+  | `Console of id
-          let vmid = string_of_id arg in
+  | `Log of id
-          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 handle = function
-  let open Vmm_wire in
+  | `Info name ->
-  if not (version_eq hdr.version state.stats_version) then begin
+    let cmd = Vmm_wire.Vm.info c ver name in
-    Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
+    `Vmmd, `End, cmd
-    state, []
+  | `Policy name ->
-  end else if hdr.tag = success_tag then
+    let cmd = Vmm_wire.Vm.policy c ver name in
-    state, []
+    `Vmmd, `End, cmd
+  | `Remove_policy name ->
+    let cmd = Vmm_wire.Vm.remove_policy c ver name in
+    `Vmmd, `End, cmd
+  | `Add_policy (name, policy) ->
+    let cmd = Vmm_wire.Vm.insert_policy c ver name policy in
+    `Vmmd, `End, cmd
+  | `Create_vm vm ->
+    let cmd = Vmm_wire.Vm.create c ver vm in
+    `Vmmd, `End, cmd
+  | `Force_create_vm vm ->
+    let cmd = Vmm_wire.Vm.force_create c ver vm in
+    `Vmmd, `End, cmd
+  | `Destroy_vm name ->
+    let cmd = Vmm_wire.Vm.destroy c ver name in
+    `Vmmd, `End, cmd
+  | `Statistics name ->
+    let cmd = Vmm_wire.Stats.subscribe c ver name in
+    `Stats, `Read, cmd
+  | `Console name ->
+    let cmd = Vmm_wire.Console.attach c ver name in
+    `Console, `Read, cmd
+  | `Log name ->
+    let cmd = Vmm_wire.Log.subscribe c ver name in
+    `Log, `Read, cmd
+(*  | `Crl _ -> assert false
+    (* write_to_file_unless_serial_smaller ; potentially destroy vms *)
+  | `Create_block (name, size) -> assert false
+  | `Destroy_block name -> assert false
+*)
+
+let handle_reply (hdr, data) =
+  if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then
+    Error (`Msg "unknown wire protocol version")
   else
-    match IM.find hdr.id state.stats_requests with
+  if Vmm_wire.is_fail hdr then
-    | exception Not_found ->
+    let msg = match Vmm_wire.decode_string data with
-      Logs.err (fun m -> m "couldn't find stat request") ;
+      | Ok (msg, _) -> msg
-      state, []
+      | Error _ -> ""
-    | (s, req_id, f) ->
+    in
-      let stats_requests = IM.remove hdr.id state.stats_requests in
+    Error (`Msg ("command failed " ^ msg))
-      let state = { state with stats_requests } in
+  else if Vmm_wire.is_reply hdr && hdr.Vmm_wire.id = c then
-      let out =
+    Ok (hdr, data)
-        match Stats.int_to_op hdr.tag with
+  else
-        | Some Stats.Stat_reply ->
+    Error (`Msg "received unexpected data")
-          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

@@ -229,10 +229,12 @@ let identifier serial =
   match Hex.of_cstruct @@ Nocrypto.Hash.SHA256.digest @@
     Nocrypto.Numeric.Z.to_cstruct_be @@ serial
   with
-  | `Hex str -> fst (String.span ~max:6 str)
+  | `Hex str -> str
 
 let id cert = identifier (X509.serial cert)
 
+let name cert = X509.common_name_to_string cert
+
 let parse_db lines =
   List.fold_left (fun acc s ->
       acc >>= fun datas ->

src/vmm_x509.ml

@@ -1,6 +1,11 @@
+open Astring
+open Rresult.R.Infix
+
+open Vmm_core
 
 let asn_version = `AV1
 
+(*
 let handle_single_revocation t prefix serial =
   let id = identifier serial in
   (match Vmm_resources.find t.resources (prefix @ [ id ]) with
@@ -39,7 +44,9 @@ let handle_single_revocation t prefix serial =
   (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))! *)
@@ -85,20 +92,51 @@ let handle_revocation t s leaf chain ca prefix =
   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 =
+let my_command = 1L
+let my_version = `WV2
+
+
+let handle_initial s addr chain ca =
   separate_chain chain >>= fun (leaf, chain) ->
+  let prefix = List.map name chain in
+  let name = prefix @ [ name leaf ] in
   Logs.debug (fun m -> m "leaf is %s, chain %a"
                  (X509.common_name_to_string leaf)
-                 Fmt.(list ~sep:(unit "->") string)
+                 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 name, `Login addr in *)
-  let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in
+  Ok ()
-  let t, out = log t (login_hdr, login_ev) in
+(*  Vmm_asn.command_of_cert asn_version leaf >>= function
-  let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in
+  | `Info ->
-  Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms ->
+    let cmd = Vmm_wire.Vm.info my_command my_version name in
+    Ok (`Vmmd, cmd)
+  | `Create_vm ->
+    Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
+    let cmd = Vmm_wire.Vm.create my_command my_version vm_config in
+    (* TODO: update acl *)
+    Ok (`Vmmd, cmd)
+  | `Force_create_vm ->
+    Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
+    let cmd = Vmm_wire.Vm.force_create my_command my_version vm_config in
+    (* TODO: update acl *)
+    Ok (`Vmmd, cmd)
+  | `Destroy_vm ->
+    let cmd = Vmm_wire.Vm.destroy my_command my_version name in
+    Ok (`Vmmd, cmd)
+  | `Statistics ->
+    let cmd = Vmm_wire.Stats.subscribe my_command my_version name in
+    Ok (`Stats, cmd)
+  | `Console -> `Cons, Vmm_wire.Console.attach ; read there and write to tls
+  | `Log -> `Log, Vmm_wire.Log.subscribe ; read there and write to tls
+  | `Crl -> write_to_file_unless_serial_smaller ; potentially destroy vms
+  | `Create_block -> ??
+  | `Destroy_block -> ??
+
+
   (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 ->
@@ -144,20 +182,6 @@ let handle_initial t s addr chain ca =
            cont)
      in
      Ok (t, [], `Create (task, next))
-   else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
+(*   else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
-     handle_revocation t s leaf chain ca prefix
+     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)