From 1cab7b21efdbf0bc989b34a404c771955d6f0451 Mon Sep 17 00:00:00 2001 From: Mindy Date: Wed, 1 May 2019 18:49:13 -0500 Subject: [PATCH 1/8] since we require dune, refer to it in makefile --- Makefile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index f740af3..07cf799 100644 --- a/Makefile +++ b/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 From cf58575f9ff8fea5678763bf00f7d8a8d079f8a3 Mon Sep 17 00:00:00 2001 From: Mindy Date: Mon, 22 Apr 2019 15:46:37 -0500 Subject: [PATCH 2/8] formats: add trigger_service_params & service_refused Co-authored-by: linse --- lib/formats.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/lib/formats.ml b/lib/formats.ml index ee61f20..2ed9b73 100644 --- a/lib/formats.ml +++ b/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 From e853aded1683ceb83b937d43f2c3e6ef0e839737 Mon Sep 17 00:00:00 2001 From: Mindy Date: Mon, 22 Apr 2019 16:25:57 -0500 Subject: [PATCH 3/8] formats: add string_of_type for message types Co-authored-by: linse --- lib/formats.ml | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/lib/formats.ml b/lib/formats.ml index 2ed9b73..25cd111 100644 --- a/lib/formats.ml +++ b/lib/formats.ml @@ -80,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 From b4ea72871e05bebf09cde72879e699965b94fd33 Mon Sep 17 00:00:00 2001 From: Mindy Date: Mon, 22 Apr 2019 16:26:28 -0500 Subject: [PATCH 4/8] qrexec: reword error message for unexpected recv msg Co-authored-by: linse --- lib/rExec.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/rExec.ml b/lib/rExec.ml index 0365ca9..ef92b87 100644 --- a/lib/rExec.ml +++ b/lib/rExec.ml @@ -218,8 +218,8 @@ let listen t handler = | `Ok (`Just_exec | `Exec_cmdline as ty, data) -> exec t ~ty ~handler data; loop () | `Ok (ty, _) -> - Log.info (fun f -> f "unknown qrexec message type received: %ld" - (int_of_type ty)); + Log.info (fun f -> f "unhandled qrexec message type received: %ld (%s)" + (int_of_type ty) (string_of_type ty)); loop () | `Eof -> Log.info (fun f -> f "connection closed; ending listen loop"); From c48f093a9ebb794e0b0aa6043db2be892a02a88b Mon Sep 17 00:00:00 2001 From: Mindy Date: Wed, 1 May 2019 18:43:14 -0500 Subject: [PATCH 5/8] move previous rexec to rexec_server --- lib/{rExec.ml => rExec_server.ml} | 0 lib/{rExec.mli => rExec_server.mli} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename lib/{rExec.ml => rExec_server.ml} (100%) rename lib/{rExec.mli => rExec_server.mli} (100%) diff --git a/lib/rExec.ml b/lib/rExec_server.ml similarity index 100% rename from lib/rExec.ml rename to lib/rExec_server.ml diff --git a/lib/rExec.mli b/lib/rExec_server.mli similarity index 100% rename from lib/rExec.mli rename to lib/rExec_server.mli From 7c0d9c7a2388732ead87ee7c9cbffcbe5c165a62 Mon Sep 17 00:00:00 2001 From: Mindy Date: Mon, 13 May 2019 12:55:53 -0400 Subject: [PATCH 6/8] require ocaml 4.05, and test compilers 4.05 and 4.07 --- .travis.yml | 4 ++-- mirage-qubes.opam | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 408f791..76712ad 100644 --- a/.travis.yml +++ b/.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 diff --git a/mirage-qubes.opam b/mirage-qubes.opam index bc96d5f..bc63d4d 100644 --- a/mirage-qubes.opam +++ b/mirage-qubes.opam @@ -22,6 +22,6 @@ depends: [ "mirage-xen" { >= "3.0.0" } "lwt" "logs" { >= "0.5.0" } - "ocaml" { >= "4.03.0" } + "ocaml" { >= "4.05.0" } ] synopsis: "Implementations of various Qubes protocols for MirageOS" From c6e66ccd168b262df661901df69e810934a1f26f Mon Sep 17 00:00:00 2001 From: Mindy Date: Mon, 13 May 2019 12:57:10 -0400 Subject: [PATCH 7/8] move common stuff to rExec_common --- lib/rExec_common.ml | 67 ++++++++++++++++++++++++++++++++++++++++++ lib/rExec_server.ml | 71 ++------------------------------------------- 2 files changed, 70 insertions(+), 68 deletions(-) create mode 100644 lib/rExec_common.ml diff --git a/lib/rExec_common.ml b/lib/rExec_common.ml new file mode 100644 index 0000000..d45d268 --- /dev/null +++ b/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 + diff --git a/lib/rExec_server.ml b/lib/rExec_server.ml index ef92b87..98f4963 100644 --- a/lib/rExec_server.ml +++ b/lib/rExec_server.ml @@ -5,55 +5,11 @@ open Lwt.Infix open Formats.Qrexec open Utils -module QV = Msg_chan.Make(Framing) +include RExec_common -let src = Logs.Src.create "qubes.rexec" ~doc:"Qubes qrexec-agent" +let src = Logs.Src.create "qubes.rexec_server" ~doc:"Qubes qrexec-agent" module Log = (val Logs.src_log src : Logs.LOG) -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 t = - QV.disconnect t - -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)) - module Flow = struct type t = { dstream : QV.t; @@ -100,10 +56,7 @@ module Flow = struct let rec read_line flow = let buf = Cstruct.to_string flow.stdin_buf in - let i = - try Some (String.index buf '\n') - with Not_found -> None in - match i with + match String.index_opt buf '\n' with | Some i -> let retval = String.sub buf 0 i in flow.stdin_buf <- Cstruct.shift flow.stdin_buf (i + 1); @@ -127,19 +80,6 @@ end type handler = user:string -> string -> Flow.t -> int Lwt.t -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 try_close flow return_code = Flow.close flow return_code >|= function | `Ok () -> () @@ -174,11 +114,6 @@ let with_flow ~ty ~domid ~port fn = return () ) -let port_of_int i = - match Int32.to_string i |> Vchan.Port.of_string with - | `Ok p -> p - | `Error msg -> failwith msg - let parse_cmdline cmd = let cmd = Cstruct.to_string cmd in if cmd.[String.length cmd - 1] <> '\x00' then From d241564e26e785a0c177349518ff62fcc0cb3746 Mon Sep 17 00:00:00 2001 From: Mindy Date: Mon, 13 May 2019 12:58:44 -0400 Subject: [PATCH 8/8] implement rExec_client --- lib/rExec_client.ml | 133 +++++++++++++++++++++++++++++++++++++++++++ lib/rExec_client.mli | 27 +++++++++ 2 files changed, 160 insertions(+) create mode 100644 lib/rExec_client.ml create mode 100644 lib/rExec_client.mli diff --git a/lib/rExec_client.ml b/lib/rExec_client.ml new file mode 100644 index 0000000..6286110 --- /dev/null +++ b/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 diff --git a/lib/rExec_client.mli b/lib/rExec_client.mli new file mode 100644 index 0000000..7398c23 --- /dev/null +++ b/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. *)