From 2393d8d5b937139fdf705d1defca067c9eb7eadc Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 14 May 2019 16:52:26 +0200 Subject: [PATCH] GUId mvar, see #33 --- lib/formats.ml | 135 +++++++++++++++++++----- lib/gUI.ml | 262 +++++++++++++++++++++++++++++++--------------- lib/gUI.mli | 50 ++++++++- mirage-qubes.opam | 1 + 4 files changed, 337 insertions(+), 111 deletions(-) diff --git a/lib/formats.ml b/lib/formats.ml index ee61f20..0484e2b 100644 --- a/lib/formats.ml +++ b/lib/formats.ml @@ -117,13 +117,8 @@ module GUI = struct } [@@little_endian] ] - [%%cstruct - type msg_clipboard_data = { - len_big : uint32_t [@big_endian]; - len_little : uint32_t; - (* followed by a uint8 array of size len *) - } [@@little_endian] - ] + (** Dom0 -> VM, VM -> Dom0: MSG_CLIPBOARD_DATA:*) + (** a normal header, followed by a uint8 array of size len *) (** VM -> Dom0 *) [%%cstruct @@ -139,9 +134,10 @@ module GUI = struct type msg_keypress_t = { + ty : int32; (* TODO make bool? XKeyEvent->type, see KeyPressMask/KeyReleaseMask *) x : int32; y : int32; - state : int32; + state : int32; (* key mask *) keycode : int32; } @@ -149,7 +145,7 @@ module GUI = struct (* https://github.com/drinkcat/chroagh/commit/1d38c2e2422f97b6bf55580c9efc027ecf9f2721 *) [%%cstruct type msg_keypress = { - ty : uint32_t; (* TODO *) + ty : uint32_t; x : uint32_t; y : uint32_t; state : uint32_t; (** 1:down, 0:up *) @@ -157,6 +153,14 @@ module GUI = struct } [@@little_endian] ] + type msg_button_t = { + ty : int32 ; (* TODO make bool? ButtonPress / ButtonRelease*) + x : int32 ; + y : int32 ; + state : int32 ; (* button mask *) + button: int32 ; + } + (** Dom0 -> VM, TODO seems to be mouse buttons? *) [%%cstruct type msg_button = { @@ -168,6 +172,14 @@ module GUI = struct } [@@little_endian] ] + let decode_msg_button cs : msg_button_t option = + Some ({ ty = get_msg_button_ty cs ; + x = get_msg_button_x cs ; + y = get_msg_button_y cs ; + state = get_msg_button_state cs ; + button = get_msg_button_button cs ; + }) + (* dom0 -> VM, mouse / cursor movement *) type msg_motion_t = { x : int; @@ -241,7 +253,23 @@ module GUI = struct height : uint32_t; override_redirect : uint32_t; } [@@little_endian] - ] + ] + + type msg_configure_t = { + x: int32; + y: int32; + width: int32; + height: int32; + override_redirect: int32; + } + + let decode_msg_configure cs : msg_configure_t option = + Some ({ x = get_msg_configure_x cs ; + y = get_msg_configure_y cs ; + width = get_msg_configure_width cs ; + height = get_msg_configure_height cs ; + override_redirect = get_msg_configure_override_redirect cs ; + } : msg_configure_t) (** VM -> Dom0 *) [%%cstruct @@ -412,12 +440,11 @@ http://ccrc.web.nthu.edu.tw/ezfiles/16/1016/img/598/v14n_xen.pdf *) (* type mfn : uint32_t; big-endian 24-bit RGB pixel *) - let make_with_header ?(window=const_QUBES_MAIN_WINDOW) ~ty body = + let make_with_header ~window ~ty body = (** see qubes-gui-agent-linux/include/txrx.h:#define write_message *) (** TODO consider using Cstruct.add_len *) let body_len = Cstruct.len body in let msg = Cstruct.create (sizeof_msg_header + body_len) in - let()= Cstruct.memset msg 0 in let()= set_msg_header_ty msg (msg_type_to_int ty) in let()= set_msg_header_window msg window in let()= set_msg_header_untrusted_len msg Int32.(of_int body_len) in @@ -427,25 +454,38 @@ http://ccrc.web.nthu.edu.tw/ezfiles/16/1016/img/598/v14n_xen.pdf (* length: *) Cstruct.(len body) in msg - let make_msg_mfndump ~domid ~width ~height ~mfns = + let make_msg_mfndump ~window ~width ~height ~mfns = + (* n.b. must be followed by a MSG_SHMIMAGE to actually repaint *) let num_mfn = List.length mfns in let offset = 0x0l in let body = Cstruct.create (sizeof_shm_cmd + num_mfn*4) in - set_shm_cmd_shmid body 0l; (* TODO what *) set_shm_cmd_width body width; set_shm_cmd_height body height; set_shm_cmd_bpp body 24l; (* bits per pixel *) set_shm_cmd_off body offset; set_shm_cmd_num_mfn body Int32.(of_int num_mfn); - set_shm_cmd_domid body Int32.(of_int domid); + (* From https://www.qubes-os.org/doc/gui/ + >> "shmid" and "domid" parameters are just placeholders (to be filled + >> by *qubes_guid* ), so that we can use the same structure when talking + >> to shmoverride.so **) + (* set_shm_cmd_domid body Int32.(of_int domid); + set_shm_cmd_shmid body 0l; *) + (* TODO let n = (4 * width * height + offset + (XC_PAGE_SIZE-1)) / XC_PAGE_SIZE; *) mfns |> List.iteri (fun i -> Cstruct.LE.set_uint32 body (sizeof_shm_cmd + i*4)); - let msg = make_with_header ~ty:MSG_MFNDUMP body in - msg + make_with_header ~window ~ty:MSG_MFNDUMP body - let make_msg_create ~width ~height ~x ~y ~override_redirect ~parent = + let make_msg_shmimage ~window ~x ~y ~width ~height = + let body = Cstruct.create (sizeof_msg_shmimage) in + set_msg_shmimage_x body x; + set_msg_shmimage_y body y; + set_msg_shmimage_width body width; + set_msg_shmimage_height body height; + make_with_header ~window ~ty:MSG_SHMIMAGE body + + let make_msg_create ~window ~width ~height ~x ~y ~override_redirect ~parent = let body = Cstruct.create sizeof_msg_create in set_msg_create_width body width; (* w *) set_msg_create_height body height; (* h *) @@ -453,21 +493,21 @@ http://ccrc.web.nthu.edu.tw/ezfiles/16/1016/img/598/v14n_xen.pdf set_msg_create_y body y; set_msg_create_override_redirect body override_redirect; set_msg_create_parent body parent; - make_with_header ~ty:MSG_CREATE body + make_with_header ~window ~ty:MSG_CREATE body - let make_msg_map_info ~override_redirect ~transient_for = + let make_msg_map_info ~window ~override_redirect ~transient_for = let body = Cstruct.create sizeof_msg_map_info in let()= set_msg_map_info_override_redirect body override_redirect in let()= set_msg_map_info_transient_for body transient_for in - make_with_header ~ty:MSG_MAP body + make_with_header ~window ~ty:MSG_MAP body - let make_msg_wmname ~wmname = + let make_msg_wmname ~window ~wmname = let body = Cstruct.create sizeof_msg_wmname in let()= Cstruct.blit_from_string wmname 0 body 0 (min String.(length wmname) sizeof_msg_wmname) ; (* length *) in - make_with_header ~ty:MSG_WMNAME body + make_with_header ~window ~ty:MSG_WMNAME body - let make_msg_window_hints ~width ~height = + let make_msg_window_hints ~window ~width ~height = let body = Cstruct.create sizeof_msg_window_hints in set_msg_window_hints_flags body Int32.(16 lor 32 |> of_int) ; (*^-- PMinSize | PMaxSize *) @@ -475,9 +515,9 @@ http://ccrc.web.nthu.edu.tw/ezfiles/16/1016/img/598/v14n_xen.pdf set_msg_window_hints_min_height body height; set_msg_window_hints_max_width body width; set_msg_window_hints_max_height body height; - make_with_header ~ty:MSG_WINDOW_HINTS body + make_with_header ~window ~ty:MSG_WINDOW_HINTS body - let make_msg_configure ~x ~y ~width ~height = + let make_msg_configure ~window ~x ~y ~width ~height = let body = Cstruct.create sizeof_msg_configure in set_msg_configure_x body x ; set_msg_configure_y body y ; (* x and y are from qs->window_x and window_y*) @@ -485,7 +525,7 @@ http://ccrc.web.nthu.edu.tw/ezfiles/16/1016/img/598/v14n_xen.pdf set_msg_configure_width body width ; set_msg_configure_height body height ; set_msg_configure_override_redirect body 0l ; - make_with_header ~ty:MSG_CONFIGURE body + make_with_header ~window ~ty:MSG_CONFIGURE body module Framing = struct let header_size = sizeof_msg_header @@ -537,3 +577,44 @@ module QubesDB = struct let body_size_from_header h = get_msg_header_data_len h |> Int32.to_int end end + +module Rpc_filecopy = struct + (* see qubes-linux-utils/qrexec-lib/libqubes-rpc-filecopy.h + * and qubes-core-agent-windows/src/qrexec-services/common/filecopy.h*) + [%%cstruct + type file_header = { + namelen : uint32; + mode : uint32; + filelen : uint64; + atime : uint32; + atime_nsec : uint32; + mtime : uint32; + mtime_nsec : uint32; + } [@@little_endian] + (* followed by filename[namelen] and data[filelen] *) + ] + + [%%cstruct + type result_header = { + error_code : uint32; + _pad : uint32; + crc32 : uint64; + } [@@little_endian] + ] + + [%%cstruct + type result_header_ext = { + last_namelen : uint32; + (* TODO char last_name[0]; variable length[last_namelen] *) + } [@@little_endian] + ] + + let make_result_header_ext last_filename = + let namelen = Cstruct.len last_filename in + let msg = Cstruct.create (sizeof_result_header_ext + namelen) in + set_result_header_ext_last_namelen msg (Int32.of_int namelen); + Cstruct.blit (* src srcoff *) last_filename 0 + (* dst dstoff *) msg sizeof_result_header_ext + (* len *) namelen ; + msg +end diff --git a/lib/gUI.ml b/lib/gUI.ml index d7cb32c..ab69fdb 100644 --- a/lib/gUI.ml +++ b/lib/gUI.ml @@ -19,28 +19,44 @@ let gui_agent_port = | `Error msg -> failwith msg | `Ok port -> port -type t = QV.t - -let connect ~domid () = - Log.info (fun f -> f "waiting for client..."); - QV.server ~domid ~port:gui_agent_port () >>= fun gui -> - (* qubesgui_init_connection *) - let version = Cstruct.create sizeof_gui_protocol_version in - set_gui_protocol_version_version version qubes_gui_protocol_version_linux; - QV.send gui [version] >>= function - | `Eof -> Lwt.fail (error "End-of-file sending protocol version") - | `Ok () -> - QV.recv_fixed gui sizeof_xconf >>= function - | `Eof -> Lwt.fail (error "End-of-file getting X configuration") - | `Ok conf -> - let screen_w = get_xconf_w conf in - let screen_h = get_xconf_h conf in - let xdepth = get_xconf_depth conf in - let xmem = get_xconf_mem conf in - Log.info (fun f -> - f "client connected (screen size: %ldx%ld depth: %ld mem: %ldx)" - screen_w screen_h xdepth xmem); - Lwt.return gui +type event = + | UNIT of unit (* placeholder for unimplemented events *) + | Keypress of msg_keypress_t + | Focus of msg_focus_t + | Motion of msg_motion_t + | Clipboard_request + | Clipboard_data of Cstruct.t + | Configure of Formats.GUI.msg_configure_t + | Window_crossing of msg_crossing_t + | Window_destroy + | Window_close + | Button of msg_button_t + +let pp_event fmt event = + let pf() = Format.fprintf fmt in + match event with + | UNIT () -> pf() "UNIT" + | Button _ -> pf() "Button" + | Clipboard_request -> pf() "Clipboard_request" + | Clipboard_data cs -> pf() "Clipboard_data: %S" (Cstruct.to_string cs) + | Configure x -> pf() "Configure: @[x=%ld;@ y=%ld;@ width=%ld;@ height=%ld@]" + x.x x.y x.width x.height + | Focus {mode;detail} -> pf() "Focus mode: %ld detail: %ld" mode detail + | Keypress {x;y;state;keycode; ty = _ } -> + pf() "Keypress x: %ld y: %ld state: %ld keycode: %ld" x y state keycode + | Motion m -> pf() "Motion x: %d y: %d state: %ld is_hint: %d" + m.x m.y m.state m.is_hint + | Window_close -> pf() "Window_close" + | Window_crossing {ty;x;y ; state ; mode ; detail ; focus } -> + pf() "Window_crossing type type: %ld x: %ld y: %ld \ + state: %ld mode: %ld detail: %ld focus: %ld " + ty x y state mode detail focus + | Window_destroy -> pf() "Window_destroy" + +type window_id = Cstruct.uint32 +type window = {no : window_id ; mvar : event Lwt_mvar.t ; qv : QV.t } +type t = { qv : QV.t ; + mutable mvar : window list} let decode_KEYPRESS buf = let keypress : Formats.GUI.msg_keypress_t = { @@ -48,51 +64,119 @@ let decode_KEYPRESS buf = y = get_msg_keypress_y buf; state = get_msg_keypress_state buf; keycode = get_msg_keypress_keycode buf; + ty = get_msg_keypress_ty buf; } in - Log.warn (fun f -> - f "Got a keypress ty: %ld x: %ld y: %ld state: %ld keycode: %ld" - (get_msg_keypress_ty buf) - keypress.Formats.GUI.x keypress.y keypress.state keypress.keycode) + Keypress keypress let decode_FOCUS buf = let focus : Formats.GUI.msg_focus_t = { mode = get_msg_focus_mode buf; detail = get_msg_focus_detail buf; } in - Log.warn (fun f -> - f "Focus event: mode: %ld detail: %ld" focus.mode focus.detail) + Focus focus -let _decode_DESTROY buf = - Log.warn (fun f -> f "DESTROY event: %s" (Cstruct.to_string buf)) - -let _decode_CLOSE buf = - Log.warn (fun f -> f "CLOSE event: %s" (Cstruct.to_string buf)) +let decode_MSG_CLOSE buf = + Log.warn (fun f -> f "Event: CLOSE: %a" Cstruct.hexdump_pp buf) ; + Window_close let decode_CLIPBOARD_DATA buf = - Log.warn (fun f -> - f "Event: Received clipboard data from dom0: %S" (Cstruct.to_string buf)) + Log.warn (fun f -> f "Event: CLIPBOARD_DATA: %a" Cstruct.hexdump_pp buf); + Clipboard_data buf + +let int32_of_window (w : window) : int32 = w.no -let _decode_MSG_MOTION buf = +let decode_MSG_MOTION buf = match Formats.GUI.decode_msg_motion buf with | Some m -> Log.warn (fun f -> f "Motion event: x: %d y: %d state: %ld is_hint: %d" - m.x m.y m.state m.is_hint) + m.x m.y m.state m.is_hint); + Motion m | None -> - Log.warn (fun f -> f "attempted to decode a motion event, but we were not successful") + Log.warn (fun f -> f "attempted to decode a motion event, but we were not successful: %a" Cstruct.hexdump_pp buf); + UNIT () -let _decode_MSG_CROSSING buf = - match decode_msg_crossing buf with - | Some m -> - Log.warn (fun f -> f "Event: CROSSING: type: %ld x: %ld y: %ld" m.ty m.x m.y) +let decode_CONFIGURE buf = + match decode_msg_configure buf with + | Some m -> Configure m | None -> - Log.warn (fun f -> f "attempted to decode a crossing event, but we were not successful") + Log.warn (fun f -> f "failed decoding CONFIGURE message from dom0: %a" + Cstruct.hexdump_pp buf) ; + UNIT () + +let recv_event (window:window) = + Lwt_mvar.take window.mvar + +let debug_window w = + let rec loop () = recv_event w >>= fun e -> + Log.info (fun m -> m "debug_window [%ld]: %a" w.no pp_event e); + loop () + in loop + +let send t cs_lst = QV.send t.qv cs_lst + +let set_title (window : window) title = + QV.send window.qv + [Formats.GUI.make_msg_wmname ~window:window.no ~wmname:title] + +let create_window ?(parent=(0l:window_id)) ~x ~y ~title ~width ~height t + : window S.or_eof Lwt.t = + let w : window = { no = List.length t.mvar |> Int32.of_int ; + mvar = Lwt_mvar.create_empty () ; + qv = t.qv } + in + let window = w.no in + Logs.warn (fun m -> m "Qubes.GUI: Creating new window id %ld" window); + t.mvar <- w :: t.mvar ; + let messages = + let override_redirect = 0l in + [Formats.GUI.make_msg_create ~width ~height ~x ~y + ~override_redirect ~parent ~window ; + Formats.GUI.make_msg_map_info ~override_redirect ~transient_for:0l ~window; + Formats.GUI.make_msg_wmname ~window ~wmname:title ; + Formats.GUI.make_msg_configure ~width ~height ~x ~y ~window ; + ] + in + send t messages + >>= function | `Ok () -> Lwt.return (`Ok w) + | `Eof -> Lwt.return `Eof -let rec listen t = - QV.recv t >>= function +let connect ~domid () = + Log.info (fun f -> f "waiting for client..."); + QV.server ~domid ~port:gui_agent_port () >>= fun qv -> + (* qubesgui_init_connection *) + let version = Cstruct.create sizeof_gui_protocol_version in + set_gui_protocol_version_version version qubes_gui_protocol_version_linux; + QV.send qv [version] >>= function + | `Eof -> Lwt.fail (error "End-of-file sending protocol version") + | `Ok () -> + QV.recv_fixed qv sizeof_xconf >>= function + | `Eof -> Lwt.fail (error "End-of-file getting X configuration") + | `Ok conf -> + let screen_w = get_xconf_w conf in + let screen_h = get_xconf_h conf in + let xdepth = get_xconf_depth conf in + let xmem = get_xconf_mem conf in + Log.info (fun f -> + f "client connected (screen size: %ldx%ld depth: %ld mem: %ldx)" + screen_w screen_h xdepth xmem); + let main_window = {no = 0l ; qv ; mvar = Lwt_mvar.create_empty ()} in + Lwt.async (debug_window main_window) ; + Lwt.return { qv ; + mvar = [main_window] } + +let rec listen t () = + QV.recv t.qv >>= function | `Eof -> failwith "End-of-file from GUId in dom0" | `Ok (msg_header , msg_buf) -> - let msg_window = get_msg_header_window msg_header |> Int32.to_int in + let window = get_msg_header_window msg_header in + let send_to_window event = + match List.find (fun t -> t.no = window) t.mvar with + | w -> Lwt_mvar.put w.mvar event + | exception _ -> Log.warn (fun m -> m "No such window %ld" window); + Lwt.return () + in let msg_len = get_msg_header_untrusted_len msg_header |> Int32.to_int in + send_to_window begin match int_to_msg_type (get_msg_header_ty msg_header) with (* handle fixed-length messages *) @@ -102,44 +186,50 @@ let rec listen t = | MSG_EXECUTE | MSG_WMNAME | MSG_KEYMAP_NOTIFY | MSG_WINDOW_HINTS | MSG_WINDOW_FLAGS | MSG_WMCLASS | MSG_CLIPBOARD_REQ | MSG_CLOSE as msg) - when msg_len <> (match msg_type_size msg with Some x -> x | None -> -1) -> - Log.warn (fun f -> f "BUG: expected_size [%d] <> msg_len [%d] for fixed-\ - size msg! msg_header: %S Received raw buffer:: %S" - (match msg_type_size msg with Some x -> x | None -> -1) - msg_len - Cstruct.(to_string msg_header) - Cstruct.(to_string msg_buf)) + when (match msg_type_size msg with Some x -> x <> msg_len | None -> true) -> + Log.warn (fun f -> f "BUG: expected_size [%d] <> msg_len [%d] for fixed-\ + size msg! msg_header: %a@ Received raw buffer:: %a" + (match msg_type_size msg with Some x -> x | None -> -1) + msg_len + Cstruct.hexdump_pp msg_header + Cstruct.hexdump_pp msg_buf) ; + UNIT() + | Some MSG_MAP -> + Log.warn (fun f -> f "Event: MAP: %a" Cstruct.hexdump_pp msg_buf) ; + UNIT() | Some MSG_KEYPRESS -> decode_KEYPRESS msg_buf | Some MSG_FOCUS -> decode_FOCUS msg_buf - | Some MSG_MOTION -> ignore @@ decode_msg_motion msg_buf + | Some MSG_MOTION -> decode_MSG_MOTION msg_buf | Some MSG_CLIPBOARD_REQ -> - Log.warn (fun f -> - f "Event: dom0 requested our clipboard. debug: sizeof: %d" - sizeof_msg_clipboard_req) - | Some MSG_CROSSING -> ignore @@ decode_msg_crossing msg_buf - | Some MSG_DESTROY -> - Log.warn (fun f -> f "Event: DESTROY: %S" Cstruct.(to_string msg_buf)) - | Some MSG_CLOSE -> Log.warn (fun f -> f "Event: CLOSE window %d" msg_window) - | Some MSG_BUTTON -> - Log.warn (fun f -> f "Event: BUTTON: %S" Cstruct.(to_string msg_buf)) - | Some MSG_CREATE -> - Log.warn (fun f -> f "Event: CREATE: %S" Cstruct.(to_string msg_buf)) - | Some MSG_EXECUTE -> - Log.warn (fun f -> f "Event: EXECUTE: %S" Cstruct.(to_string msg_buf)) - | Some MSG_WMNAME -> - Log.warn (fun f -> f "Event: WMNAME: %S" Cstruct.(to_string msg_buf)) + Log.warn (fun f -> f "Event: dom0 requested our clipboard.") ; + Clipboard_request + | Some MSG_CROSSING -> begin match decode_msg_crossing msg_buf with + | Some event -> Window_crossing event + | None -> Log.warn (fun m -> m "Invalid MSG_CROSSING during decoding %a" + Cstruct.hexdump_pp msg_buf) + ; UNIT () + end + | Some MSG_CLOSE -> decode_MSG_CLOSE msg_buf + | Some MSG_BUTTON -> begin match decode_msg_button msg_buf with + | Some button_event -> Button button_event + | None -> Log.warn (fun m -> m "Invalid MSG_BUTTON decoding %a" + Cstruct.hexdump_pp msg_buf) + ; UNIT () + end | Some MSG_KEYMAP_NOTIFY -> - Log.warn (fun f -> f "Event: KEYMAP_NOTIFY: %S" Cstruct.(to_string msg_buf)) - | Some MSG_WINDOW_HINTS -> - Log.warn (fun f -> f "Event: WINDOW_HINTS: %S" Cstruct.(to_string msg_buf)) + (* Synchronize the keyboard state (key pressed/released) with dom0 *) + Log.warn (fun f -> f "Event: KEYMAP_NOTIFY: %S" + Cstruct.(to_string msg_buf)) ; + UNIT() | Some MSG_WINDOW_FLAGS -> Log.warn (fun f -> f "Event: WINDOW_FLAGS: %S" Cstruct.(to_string msg_buf)) + ; UNIT () | Some MSG_CONFIGURE -> - Log.warn (fun f -> f "Event: CONFIGURE: %S" Cstruct.(to_string msg_buf)) - | Some MSG_SHMIMAGE - | Some MSG_WMCLASS -> - Log.warn (fun f -> f "Event: Unhandled fixed-length: %S" - Cstruct.(to_string msg_buf)) + Log.warn (fun f -> f "Event: CONFIGURE (should reply with this): %a" + Cstruct.hexdump_pp msg_buf) ; + (* TODO here we should ACK to Qubes that we accept the new dimensions, + atm this is the responsibility of the user: *) + decode_CONFIGURE msg_buf (* parse variable-length messages: *) @@ -147,12 +237,18 @@ let rec listen t = (* handle unimplemented/unexpected messages:*) - | Some (MSG_MAP|MSG_UNMAP|MSG_MFNDUMP|MSG_DOCK) -> + | Some ( MSG_UNMAP | MSG_MFNDUMP | MSG_DOCK | MSG_WINDOW_HINTS + | MSG_SHMIMAGE | MSG_WMCLASS | MSG_EXECUTE | MSG_CREATE + | MSG_WMNAME | MSG_DESTROY ) -> + (* Handle messages that are appvm->dom0 and thus dom0 is not supposed + to send to the VM: *) Log.warn (fun f -> - f "UNHANDLED DATA of non-fixed length received. Data: %S" - Cstruct.(to_string msg_buf)) + f "UNEXPECTED message received. Data: %a" + Cstruct.hexdump_pp msg_buf); UNIT() | None -> - Log.warn (fun f -> f "Unexpected data with unknown type: [%S]%S" - (Cstruct.to_string msg_header) (Cstruct.to_string msg_buf)) + Log.warn (fun f -> f "Unexpected data with unknown type: [%a] %aa" + Cstruct.hexdump_pp msg_header + Cstruct.hexdump_pp msg_buf) ; + UNIT() end - ; listen t + >>= fun () -> listen t () diff --git a/lib/gUI.mli b/lib/gUI.mli index 6024b85..9a33141 100644 --- a/lib/gUI.mli +++ b/lib/gUI.mli @@ -4,7 +4,55 @@ (** The Qubes GUI agent *) type t +type window_id +type window + +open Formats.GUI + +type event = + | UNIT of unit + | Keypress of Formats.GUI.msg_keypress_t + | Focus of msg_focus_t + | Motion of msg_motion_t + | Clipboard_request + | Clipboard_data of Cstruct.t + | Configure of Formats.GUI.msg_configure_t + | Window_crossing of msg_crossing_t + | Window_destroy + | Window_close + | Button of msg_button_t + +val pp_event : Format.formatter -> event -> unit +(** [pp_event formatter event] pretty-prints an event. *) val connect : domid:int -> unit -> t Lwt.t +(** [connect domid ()] connects to the guid in the given [domid] over Vchan. *) + +val listen : t -> unit -> t Lwt.t +(** [listen ti ()] is an event listener thread. It can be run with Lwt.async + and will never return. Events are dispatched to windows + created using [create_window].*) + +val set_title : window -> string -> unit S.or_eof Lwt.t +val int32_of_window : window -> int32 + +val create_window : ?parent:window_id -> x:Cstruct.uint32 -> y:Cstruct.uint32 -> + title:string -> + width:Cstruct.uint32 -> + height:Cstruct.uint32 -> t-> window S.or_eof Lwt.t +(** [create_window ?parent ~title ~width ~height t] instantiates a new window. + The window will have dimensions [width] * [height], and be instantiated at + coordinates [x]*[y] (relative to the screen's [0,0]). +*) + +val send : t -> Cstruct.t list -> unit S.or_eof Lwt.t +(** [send t messages] synchronously sends [messages] to the Qubes GUId + using [t]'s established vchan *) + +val recv_event : window -> event Lwt.t +(** [recv_event] is a blocking Lwt thread that can be called repeatedly to + read new events coming in on [window] *) -val listen : t -> 'a Lwt.t +val debug_window : window -> unit -> unit Lwt.t +(** [debug_window] is a window "handler" to be called with Lwt.async + that pretty-prints the received events.*) diff --git a/mirage-qubes.opam b/mirage-qubes.opam index bc96d5f..2725749 100644 --- a/mirage-qubes.opam +++ b/mirage-qubes.opam @@ -16,6 +16,7 @@ depends: [ "dune" {build & >= "1.0"} "cstruct" { >= "1.9.0" } "ppx_cstruct" + "mirage-protocols-lwt" { >= "2.0.0" } "vchan-xen" "xen-evtchn" "xen-gnt"