implement an rexec_client; move previous rexec code to rexec_server

.travis.yml

@@ -6,7 +6,7 @@ env:
   global:
   - PINS="mirage-qubes.dev:. mirage-qubes-ipv4.dev:."
   matrix:
-  - OCAML_VERSION=4.04 PACKAGE=mirage-qubes
-  - OCAML_VERSION=4.04 PACKAGE=mirage-qubes-ipv4
   - OCAML_VERSION=4.05 PACKAGE=mirage-qubes
   - OCAML_VERSION=4.05 PACKAGE=mirage-qubes-ipv4
+  - OCAML_VERSION=4.07 PACKAGE=mirage-qubes
+  - OCAML_VERSION=4.07 PACKAGE=mirage-qubes-ipv4

Makefile

@@ -2,16 +2,16 @@
 .PHONY: build clean test
 
 build:
-	jbuilder build @install --dev
+	dune build @install
 
 test:
-	jbuilder runtest --dev
+	dune runtest
 
 install:
-	jbuilder install
+	dune install
 
 uninstall:
-	jbuilder uninstall
+	dune uninstall
 
 clean:
 	rm -rf _build

lib/formats.ml

@@ -37,10 +37,19 @@ module Qrexec = struct
       } [@@little_endian]
   ]
 
+  [%%cstruct
+    type trigger_service_params = {
+      service_name : uint8_t [@len 64];
+      target_domain : uint8_t [@len 32];
+      request_id : uint8_t [@len 32]
+    } [@@little_endian]
+  ]
+
   type msg_type =
     [ `Exec_cmdline
     | `Just_exec
     | `Service_connect
+    | `Service_refused
     | `Trigger_service
     | `Connection_terminated
     | `Hello
@@ -57,6 +66,7 @@ module Qrexec = struct
     | 0x200l -> `Exec_cmdline
     | 0x201l -> `Just_exec
     | 0x202l -> `Service_connect
+    | 0x203l -> `Service_refused
     | 0x210l -> `Trigger_service
     | 0x211l -> `Connection_terminated
     | 0x300l -> `Hello
@@ -70,11 +80,27 @@ module Qrexec = struct
     | `Exec_cmdline -> 0x200l
     | `Just_exec -> 0x201l
     | `Service_connect -> 0x202l
+    | `Service_refused -> 0x203l
     | `Trigger_service -> 0x210l
     | `Connection_terminated -> 0x211l
     | `Hello -> 0x300l
     | `Unknown x -> x
 
+  let string_of_type = function
+    | `Data_stdin -> "DATA_STDIN"
+    | `Data_stdout -> "DATA_STDOUT"
+    | `Data_stderr -> "DATA_STDERR"
+    | `Data_exit_code -> "DATA_EXIT_CODE"
+    | `Exec_cmdline -> "MSG_EXEC_CMDLINE"
+    | `Just_exec -> "MSG_JUST_EXEC"
+    | `Service_connect -> "MSG_SERVICE_CONNECT"
+    | `Service_refused -> "MSG_SERVICE_REFUSED"
+    | `Trigger_service -> "MSG_TRIGGER_SERVICE"
+    | `Connection_terminated -> "MSG_CONNECTION_TERMINATED"
+    | `Hello -> "MSG_HELLO"
+    | `Unknown x -> "Unknown message: " ^ (Int32.to_string x)
+
+
   module Framing = struct
     let header_size = sizeof_msg_header
     let body_size_from_header h = get_msg_header_len h |> Int32.to_int

lib/rExec_client.ml

@@ -0,0 +1,133 @@
+include RExec_common
+
+open Lwt.Infix
+
+let src = Logs.Src.create "qubes.rexec_client" ~doc:"Qubes qrexec-client"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Flow = struct
+  type t = {
+    connection : QV.t;
+    mutable stderr_buf : Cstruct.t;
+    mutable stdout_buf : Cstruct.t;
+  }
+
+  let create connection = { connection; stderr_buf = Cstruct.empty;
+                            stdout_buf = Cstruct.empty;
+                          }
+
+  let write t data = send ~ty:`Data_stdin t.connection data
+
+  let writef t fmt =
+    fmt |> Printf.ksprintf @@ fun s ->
+    send ~ty:`Data_stdin t.connection (Cstruct.of_string (s ^ "\n"))
+
+  let next_msg t =
+    recv t.connection >|= function
+    | `Ok (`Data_stdout, data) ->
+      t.stdout_buf <- Cstruct.append t.stdout_buf data;
+      `Ok t
+    | `Ok (`Data_stderr, data) ->
+      t.stderr_buf <- Cstruct.append t.stderr_buf data;
+      `Ok t
+    | `Ok (`Data_exit_code, data) ->
+      `Done (Formats.Qrexec.get_exit_status_return_code data)
+    | `Ok (ty, _) ->
+      Log.debug Formats.Qrexec.(fun f -> f "unexpected message of type %ld (%s) received; \
+                             ignoring it" (int_of_type ty) (string_of_type ty));
+      `Ok t
+    | `Eof -> `Eof
+
+  let read t =
+    let rec aux = function
+      | `Eof | `Done _ as s -> Lwt.return s
+      | `Ok t ->
+        let drain_stdout () =
+            let output = t.stdout_buf in
+            t.stdout_buf <- Cstruct.empty;
+            Lwt.return @@ `Stdout output
+        and drain_stderr () =
+            let output = t.stderr_buf in
+            t.stderr_buf <- Cstruct.empty;
+            Lwt.return @@ `Stderr output
+        in
+        if Cstruct.len t.stdout_buf > 0 then drain_stdout ()
+        else if Cstruct.len t.stderr_buf > 0 then drain_stderr ()
+        else next_msg t >>= aux
+    in
+    aux (`Ok t)
+
+  let rec read_line t =
+    let stdout = Cstruct.to_string t.stdout_buf
+    and stderr = Cstruct.to_string t.stderr_buf
+    in
+    let newline buf = String.index_opt buf '\n' in
+    match newline stdout, newline stderr with
+    | Some i, _ ->
+      let retval = String.sub stdout 0 i in
+      t.stdout_buf <- Cstruct.shift t.stdout_buf (i + 1);
+      Lwt.return (`Stdout retval)
+    | _, Some i ->
+      let retval = String.sub stderr 0 i in
+      t.stderr_buf <- Cstruct.shift t.stderr_buf (i + 1);
+      Lwt.return (`Stderr retval)
+    | None, None ->
+      next_msg t >>= function
+      | `Done _ | `Eof as s -> Lwt.return s
+      | `Ok t -> read_line t
+end
+
+let start_connection data =
+  let domid = Formats.Qrexec.get_exec_params_connect_domain data in
+  let port = Formats.Qrexec.get_exec_params_connect_port data in
+  Log.debug (fun f -> f "service_connect message received: domain %ld, port %ld" domid port);
+  Log.debug (fun f -> f "Connecting...");
+  match Vchan.Port.of_string (Int32.to_string port) with
+  | `Error msg -> Lwt.return @@ Error (`Msg msg)
+  | `Ok port ->
+    QV.server ~domid:(Int32.to_int domid) ~port () >>= fun remote ->
+    send_hello remote >>= fun () ->
+    recv_hello remote >>= fun version ->
+    Log.debug (fun f -> f "server connected on port %s, using protocol version %ld" (Vchan.Port.to_string port) version);
+    Lwt.return @@ Ok (Flow.create remote)
+
+let connect ~vm ~service ~identifier =
+  let write_trigger_service_parameters_into buf =
+    let write_string s ~dst_offset ~max_len =
+      Cstruct.blit_from_string s 0 buf dst_offset (min (String.length s) max_len)
+    in
+    write_string service ~dst_offset:0 ~max_len:64;
+    write_string vm ~dst_offset:64 ~max_len:32;
+    write_string identifier ~dst_offset:(64+32) ~max_len:32;
+    buf
+  in
+  let tsp = write_trigger_service_parameters_into @@
+    Cstruct.create Formats.Qrexec.sizeof_trigger_service_params in
+  Log.debug (fun f -> f "Initiating connection to dom0 (to request service start)");
+  QV.server ~domid:0 ~port:vchan_base_port () >>= fun server ->
+  RExec_common.send_hello server >>= fun () ->
+  RExec_common.recv_hello server >>= fun version ->
+  Log.debug (fun f -> f "connection with dom0 established (version %ld)" version);
+  RExec_common.send server ~ty:`Trigger_service tsp >>= function
+  | `Eof -> Lwt.return @@ Error `Closed
+  | `Ok () ->
+    let rec try_recv () =
+      recv server >>= function
+      | `Eof -> Lwt.return @@ Error `Closed
+      | `Ok (`Service_refused, _) -> Lwt.return @@ Error `Permission_denied
+      | `Ok (`Service_connect, data) ->
+        (* we have everything we need, so close the server connection *)
+        QV.disconnect server >>= fun () ->
+        start_connection data
+      | `Ok (ty, _) ->
+        let open Formats.Qrexec in
+        Log.debug (fun f -> f
+                     "unhandled qrexec message type received in response to \
+                      trigger service request: %ld (%s)"
+                     (int_of_type ty) (string_of_type ty));
+        try_recv ()
+    in
+    try_recv ()
+
+let close t =
+  QV.disconnect t.Flow.connection

lib/rExec_client.mli

@@ -0,0 +1,27 @@
+module Flow : sig
+  type t
+
+  val write : t -> Cstruct.t -> [ `Ok of unit | `Eof ] Lwt.t
+
+  val writef : t -> ('a, unit, string, unit S.or_eof Lwt.t) format4 -> 'a
+
+  val read : t -> [ `Stderr of Cstruct.t
+                  | `Stdout of Cstruct.t
+                  | `Done of int32 | `Eof ] Lwt.t
+
+  val read_line : t -> [ `Stderr of string
+                       | `Stdout of string
+                       | `Done of int32 | `Eof ] Lwt.t
+
+end
+
+val connect : vm:string -> service:string -> identifier:string ->
+  (Flow.t, [`Closed | `Permission_denied | `Msg of string ]) result Lwt.t
+(** Attempt to establish a qrexec connection to the guest named [vm],
+    and try to start the provided [service].
+    Use [identifier] to disambiguate this traffic.
+*)
+
+val close : Flow.t -> unit Lwt.t
+(** Close the underlying vchan without waiting for the remote side to complete.
+    Any remaining messages will be discarded. *)

lib/rExec_common.ml

@@ -0,0 +1,67 @@
+open Formats.Qrexec
+open Utils
+open Lwt.Infix
+
+module QV = Msg_chan.Make(Framing)
+
+type t = QV.t
+
+let (>>!=) = Msg_chan.(>>!=)
+
+let split chr s =
+  try
+    let i = String.index s chr in
+    Some (String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1))
+  with Not_found ->
+    None
+
+let or_fail = function
+  | `Ok y -> return y
+  | `Error (`Unknown msg) -> fail (Failure msg)
+  | `Eof -> fail End_of_file
+
+let disconnect = QV.disconnect
+
+let vchan_base_port =
+  match Vchan.Port.of_string "512" with
+  | `Error msg -> failwith msg
+  | `Ok port -> port
+
+let max_data_chunk = 4096
+(** Max size for data chunks. See MAX_DATA_CHUNK in qubes-linux-utils/qrexec-lib/qrexec.h *)
+
+let rec send t ~ty data =
+  let data, data' = Cstruct.split data (min max_data_chunk (Cstruct.len data)) in
+  let hdr = Cstruct.create sizeof_msg_header in
+  set_msg_header_ty hdr (int_of_type ty);
+  set_msg_header_len hdr (Cstruct.len data |> Int32.of_int);
+  if Cstruct.len data' = 0
+  then QV.send t [hdr; data]
+  else QV.send t [hdr; data] >>= function
+    | `Eof -> return `Eof
+    | `Ok () ->
+      send t ~ty data'
+
+let recv t =
+  QV.recv t >>!= fun (hdr, data) ->
+  let ty = get_msg_header_ty hdr |> type_of_int in
+  return (`Ok (ty, data))
+
+let send_hello t =
+  let hello = Cstruct.create sizeof_peer_info in
+  set_peer_info_version hello 2l;
+  send t ~ty:`Hello hello >>= function
+  | `Eof -> fail (error "End-of-file sending msg_hello")
+  | `Ok () -> return ()
+
+let recv_hello t =
+  recv t >>= function
+  | `Eof -> fail (error "End-of-file waiting for msg_hello")
+  | `Ok (`Hello, resp) -> return (get_peer_info_version resp)
+  | `Ok (ty, _) -> fail (error "Expected msg_hello, got %ld" (int_of_type ty))
+
+let port_of_int i =
+  match Int32.to_string i |> Vchan.Port.of_string with
+  | `Ok p -> p
+  | `Error msg -> failwith msg
+