diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 087f3e2..633e66e 100644 --- a/app/vmm_tls_endpoint.ml +++ b/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 diff --git a/pkg/pkg.ml b/pkg/pkg.ml index e558c46..07b8ee9 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -10,16 +10,16 @@ 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" ; + Pkg.bin "app/vmm_influxdb_stats" ; ] diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index fbef56d..74b2e8a 100644 --- a/src/vmm_x509.ml +++ b/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 +*)