tls endpoint

app/vmm_tls_endpoint.ml

@@ -2,6 +2,10 @@
 
 open Lwt.Infix
 
+let my_version = `AV2
+
+let command = ref 0L
+
 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"
@@ -38,11 +42,10 @@ let read fd tls =
   (* 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) ->
-      let full = Cstruct.append (Vmm_wire.encode_header hdr) data in
-      Vmm_tls.write_tls tls full >>= function
+    | Ok wire ->
+      Logs.debug (fun m -> m "read proxying %a" Vmm_asn.pp_wire wire) ;
+      Vmm_tls.write_tls tls wire >>= function
       | Ok () -> loop ()
       | Error `Exception -> Lwt.return (Error (`Msg "exception"))
   in
@@ -50,11 +53,10 @@ let read fd tls =
 
 let process fd tls =
   Vmm_lwt.read_wire fd >>= function
-  | Error (`Msg m) -> Lwt.return (Error (`Msg m))
   | Error _ -> Lwt.return (Error (`Msg "read error"))
-  | Ok (hdr, data) ->
-    let full = Cstruct.append (Vmm_wire.encode_header hdr) data in
-    Vmm_tls.write_tls tls full >|= function
+  | Ok wire ->
+    Logs.debug (fun m -> m "proxying %a" Vmm_asn.pp_wire wire) ;
+    Vmm_tls.write_tls tls wire >|= function
     | Ok () -> Ok ()
     | Error `Exception -> Error (`Msg "exception on write")
 
@@ -62,10 +64,15 @@ let handle ca (tls, addr) =
   client_auth ca tls addr >>= fun chain ->
   match Vmm_x509.handle addr chain with
   | Error (`Msg m) -> Lwt.fail_with m
-  | Ok cmd ->
-    let sock, next, cmd = Vmm_commands.handle cmd in
+  | Ok (name, cmd) ->
+    let sock, next = Vmm_commands.handle cmd in
     connect (Vmm_core.socket_path sock) >>= fun fd ->
-    Vmm_lwt.write_wire fd cmd >>= function
+    let wire =
+      let header = Vmm_asn.{version = my_version ; sequence = !command ; id = name } in
+      command := Int64.succ !command ;
+      (header, `Command cmd)
+    in
+    Vmm_lwt.write_wire fd wire >>= function
     | Error `Exception -> Lwt.return (Error (`Msg "couldn't write"))
     | Ok () ->
       (match next with

pkg/pkg.ml

@@ -10,15 +10,15 @@ let () =
     Pkg.bin "app/vmmd" ;
     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_client" ; *)
+    Pkg.bin "app/vmm_tls_endpoint" ;
     Pkg.bin "app/vmmc" ;
-(*    Pkg.bin "provision/vmm_req_command" ;
+    Pkg.bin "provision/vmm_req_command" ;
     Pkg.bin "provision/vmm_req_delegation" ;
     Pkg.bin "provision/vmm_req_vm" ;
     Pkg.bin "provision/vmm_sign" ;
     Pkg.bin "provision/vmm_revoke" ;
-      Pkg.bin "provision/vmm_gen_ca" ; *)
+    Pkg.bin "provision/vmm_gen_ca" ;
     (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *)
     Pkg.bin "stats/vmm_stats_lwt" ;
     Pkg.bin "app/vmm_influxdb_stats" ;

src/vmm_x509.ml

@@ -29,24 +29,25 @@ let handle _addr chain =
      may need to create bridges and/or block device subdirectory (zfs create) *)
   (* let login_hdr, login_ev = Log.hdr name, `Login addr in *)
   Vmm_asn.command_of_cert asn_version leaf >>= function
-  | `Info -> Ok (`Info name)
+  | `Info -> Ok (name, `Vm_cmd `Vm_info)
   | `Create_vm ->
     (* TODO: update acl *)
     Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
-    `Create_vm vm_config
+    (name, `Vm_cmd (`Vm_create vm_config))
   | `Force_create_vm ->
     (* TODO: update acl *)
     Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
-    `Force_create_vm vm_config
-  | `Destroy_vm -> Ok (`Destroy_vm name)
-  | `Statistics -> Ok (`Statistics name)
-  | `Console -> Ok (`Console name)
-  | `Log -> Ok (`Log name)
-  | `Crl -> Ok `Crl
-  | `Create_block ->
-    Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name ->
+    (name, `Vm_cmd (`Vm_force_create vm_config))
+  | `Destroy_vm -> Ok (name, `Vm_cmd `Vm_destroy)
+  | `Statistics -> Ok (name, `Stats_cmd `Stats_subscribe)
+  | `Console -> Ok (name, `Console_cmd `Console_subscribe)
+  | `Log -> Ok (name, `Log_cmd `Log_subscribe)
+  | `Crl -> assert false
+  | `Create_block -> assert false
+(*    Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name ->
     Vmm_asn.block_size_of_cert asn_version leaf >>| fun block_size ->
-    `Create_block (block_name, block_size)
-  | `Destroy_block ->
-    Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name ->
+      `Create_block (block_name, block_size) *)
+  | `Destroy_block -> assert false
+(*    Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name ->
     `Destroy_block block_name
+*)