wayland client in Guile without libwayland-client

[Matt Wette]

Hi All,

Just for fun, I'm working on an "all" Guile client-side program
to use with Wayland.   I'm just getting started, but I thought you
all might be interested to see what I'm doing.

Wayland is the apparent replacement for X11.  My reading is that
it provides a client software tighter intergration with the GPUs.
In Wayland the display is managed by the "compositor".  Applications
communicate with the compositor via UNIX domain sockets.   Messages
have an eight byte header that provides object id, object code and
message size.  An object id is mapped to an interface, and the object
code is mapped to an interface method.  The interfaces and their
methods are specified in the protocol file "wayland.xml".

ref:https://wayland-book.com
ref:https://github.com/wayland-project/wayland/blob/main/protocol/wayland.xml

The above implies that one could write a client application for
Wayland in Guile using a socket interface and procedures generated
from wayland.xml.  I have started working on just that.  One issue
is that clients operate on buffers and surfaces directly.  To
negotiate buffer sharing, file descriptors are transferred over
the socket connection.  This means we need sendmsg() and recvmsg()
in Guile.  I have coded prototypes for those.  In addition, I have
generated an auto-coder to translate wayland.xml to Guile Scheme.

Socket extension procedures are:

  (sendmsg sock iobuf ix length cm-buf flags) => n-sent
  (recvmsg! sock iobuf ix cmsg-list flags) => (n-sent cm-buf)

cm-buf is a bytevector of control messages (`man cmsg`).  To deal
with control messages I have generated these procedures:

  (cmsg-list->bytevector cmsg-list) => bytevector
  (bytevector->cmsg-list bytevector) => cmsg-list

Here is an example of auto-coded request (client->server), from
wayland.xml to Guile Scheme:

(define-public encode-wl_display:get_registry
  (lambda (obj-id bv ix registry)
    (define (encode-body)
      (bytevector-u32-native-set! bv (+ ix 8) registry)
      (values (+ ix 12) #f))
    (call-with-values
      encode-body
      (lambda (msg-size control)
        (bytevector-u32-native-set! bv ix obj-id)
        (bytevector-u16-native-set! bv (+ ix 6) msg-size)
        (bytevector-u16-native-set! bv (+ ix 4) 1)
        (values msg-size control)))))

Here is an example of an auto-coded event decoder:

      (lambda (obj-id bv ix cm)
        "event decoder for global"
        (let*-values
          (((name ix) (dec-u32 bv ix))
           ((interface ix) (dec-string bv ix))
           ((version ix) (dec-u32 bv ix)))
          (values obj-id name interface version)))

With the event decoder and user-supplied handler I have this dispatch:

(define (dispatch obj-id opcode bv ix cm)
  (let* ((decoder (vector-ref (vector-ref object-decoders-vec obj-id) opcode))
         (handler (vector-ref (vector-ref object-handlers-vec obj-id) opcode)))
    (call-with-values
        (lambda () (decoder obj-id bv ix cm))
      handler)))


The code below sets up the interface with the compositor and obtains
the list of global objects and prints them.  The output is as follows:

global: 1       wl_compositor
global: 2       wl_drm
global: 3       wl_shm
global: 4       wl_output
global: 5       zxdg_output_manager_v1
global: 6       wl_data_device_manager
global: 7       zwp_primary_selection_device_manager_v1
global: 8       gtk_primary_selection_device_manager
global: 9       wl_subcompositor
global: 10      xdg_wm_base
global: 11      zxdg_shell_v6
global: 12      gtk_shell1
global: 13      wp_viewporter
global: 14      zwp_pointer_gestures_v1
global: 15      zwp_tablet_manager_v2
global: 16      wl_seat
global: 17      zwp_relative_pointer_manager_v1
global: 18      zwp_pointer_constraints_v1
global: 19      zxdg_exporter_v1
global: 20      zxdg_importer_v1
global: 21      zwp_linux_dmabuf_v1
global: 22      zwp_keyboard_shortcuts_inhibit_manager_v1
global: 23      zwp_text_input_manager_v3
global: 24      wp_presentation
global: 25      xdg_activation_v1


CODE:

;; per-interface vectors of handlers by opcode
(define wl-handler-vec-vec (make-wl-handler-vec-vec))

;; number of objects
(define user-obj-count (make-parameter 0))
(define (incr-obj-count) (user-obj-count (1+ (user-obj-count))))

;; vector of object-id => ref into wl-handler-vec (handler by opcode)
(define object-decoders-vec (make-vector 1000))

;; vector of object-id => ref into wl-handler-vec (handler by opcode)
(define object-handlers-vec (make-vector 1000))

;; vector of objec-id => user-defined value
(define object-value-vec (make-vector 1000))

;; set-event-handler 'wl_displaly 'get_registry proc => prev-proc
(define (set-event-handler interface event proc)
  (let* ((if-indx (assq-ref wayland-index-dict interface))
         (opcode (assq-ref (vector-ref wayland-opcode-dict-vec if-indx) event))
         (if-handlers (vector-ref wl-handler-vec-vec if-indx))
         (evt-handler (vector-ref if-handlers opcode)))
    (vector-set! if-handlers opcode proc)
    evt-handler))

(define (dispatch obj-id opcode bv ix cm)
  (let* ((decoder (vector-ref (vector-ref object-decoders-vec obj-id) opcode))
         (handler (vector-ref (vector-ref object-handlers-vec obj-id) opcode)))
    (call-with-values
        (lambda () (decoder obj-id bv ix cm))
      handler)))

(define null-id 0)
(define display-id 1)
(define registry-id 2)

;; wl_display:error
(define (handle-error obj-id code message)
  (sf "error: ~S\n" message))

;; wl_display:delete_id
(define (handle-delete_id obj-id id)
  (sf "delete-id: ~S\n" id))

(define (handle-global obj-id name interface version)
  (sf "global: ~A\t~A\n" name interface)
  #f)

(define (setup)

  (set-event-handler 'wl_display 'error handle-error)
  (set-event-handler 'wl_display 'delete_id handle-delete_id)
  (set-event-handler 'wl_registry 'global handle-global)
  
  ;; display
  (set! display-id 1)
  (let* ((ob-indx display-id)
         (if-indx (assq-ref wayland-index-dict 'wl_display))
         (if-decoders (vector-ref wl-decoder-vec-vec if-indx))
         (if-handlers (vector-ref wl-handler-vec-vec if-indx)))
    (vector-set! object-decoders-vec ob-indx if-decoders)
    (vector-set! object-handlers-vec ob-indx if-handlers))

  ;; registry object
  (set! registry-id 2)
  (let* ((ob-indx registry-id)
         (if-indx (assq-ref wayland-index-dict 'wl_registry))
         (if-decoders (vector-ref wl-decoder-vec-vec if-indx))
         (if-handlers (vector-ref wl-handler-vec-vec if-indx)))
    (vector-set! object-decoders-vec ob-indx if-decoders)
    (vector-set! object-handlers-vec ob-indx if-handlers))
  
  (user-obj-count 3))


(define socket-path
  (let ((dir (getenv "XDG_RUNTIME_DIR"))
        (dpy (getenv "WAYLAND_DISPLAY")))
    (and dir dpy (string-append dir "/" dpy))))

(define wl-display-id 1)
(define wl-registry-id 2)

(define (main)
  (let* ((path socket-path)
         (style (logior SOCK_STREAM SOCK_CLOEXEC))
         (sock (socket PF_UNIX SOCK_STREAM 0))
         (conn (connect sock AF_UNIX path))
         (iobuf (make-bytevector 72)))

    (setvbuf sock 'none)
    (setup)
    
    ;; request: wl_display:get_registry 2
    (call-with-values
        (lambda () (encode-wl_display:get_registry 1 iobuf 0 2))
      (lambda (ln ctl)
        (sendmsg sock iobuf 0 ln ctl)))
    
    (let loop ((n-have 0) (object-id #f) (msg-size 8) (opcode #f) (control #f))
      (usleep 20000)
      (cond
       ((< n-have msg-size)
        (let* ((res (recvmsg! sock iobuf n-have))
               (n-have (+ n-have (vector-ref res 0)))
               (control (or control (vector-ref res 1))))
          (loop n-have object-id msg-size opcode control)))
       ((not object-id)
        (let* ((object-id (bytevector-u32-native-ref iobuf 0))
               (word1 (bytevector-u32-native-ref iobuf 4))
               (msg-size (bytevector-u16-native-ref iobuf msg-size-offset))
               (opcode (bytevector-u16-native-ref iobuf opcode-offset)))
          (loop n-have object-id msg-size opcode control)))
       (else
        (dispatch object-id opcode iobuf 8 control)
        (if (> n-have msg-size)
            (bytevector-copy! iobuf msg-size iobuf 0 (- n-have msg-size)))
        (loop (- n-have msg-size) #f 8 opcode control))))

    0))

(main)