fun with wayland

[Matt Wette]

I finally got my Wayland demo in guile working.  I thought I'd share 
some bits.
(I started with creating FFI to libwayland, but with all the callbacks 
it was
not worth it.)

Wayland is a display server for Linux (and others?), meant to replace X11.
It uses UNIX socket I/O between the "compositor" (i.e., server) and clients.
I have written  a client app without using libwayland: I've coded down 
to the
socket protocol in Guile Scheme.

Summary:
1) I created sendmsg/recvmsg! wrappers for Guile, in C.  This allows me
   to send file descriptors as shared buffer references to the server.
2) I am using my proposed mmap wrapper for Guile, in C, to create a file-
   mapped shared drawing.
3) I created a "scanner" program in Guile that converts protocol specs
   (e.g., wayland.xml) to scheme.
4) I created "sender", "receiver" and "monitor" tasks within Fibers to
   run the client app
5) I used my ffi-helper generated code to use cairo for drawing.

prototype code is located at https://github.com/mwette/guile-wl-play

Here are some snippets:

;; auto-generated by "scanner" from wayland.xml:
(define-public encode-wl_display:sync
  (lambda (obj-id bv ix callback)
    (define (encode-body)
      (bytevector-u32-native-set! bv (+ ix 8) callback)
      (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) 0)
        (values msg-size control)))))

;; dispatch routine to handle events from socket
(define (dispatch obj-id opcode bv ix cm)
  (let* ((dec-vec (vector-ref object-decoders-vec obj-id))
         (decoder (and (vector-ref dec-vec opcode)))
         (hlr-vec (vector-ref object-handlers-vec obj-id))
         (handler (and (vector-ref hlr-vec opcode))))
    (if (and decoder handler)
        (call-with-values (lambda () (decoder obj-id bv ix cm)) handler)
        (begin
          (sferr "dispatch: missing decoder or handler: id=~S op=~S\n"
                 obj-id opcode)
          (sferr "  dec-vec?=~S decoder?=~S hlr-vec?=~S handler?=~S\n"
                 (and dec-vec #t) (and decoder #t)
                 (and hlr-vec #t) (and handler #t))))))

(define-syntax define-wl-request
  (lambda (x)
    (syntax-case x ()
      ((_ iface meth arg ...)
       #`(define (#,(gen-id x #'iface ":" #'meth) obj-id arg ...)
           (when wl-debug (sferr "=> ~S:~S ...\n" 'iface 'meth))
           (put-message rq-chan
             (lambda ()
               (#,(gen-id x "encode-" #'iface ":" #'meth)
                obj-id rq-iobuf 0 arg ...))))))))

(define-wl-request wl_display sync callback)

(define (handle-wl_callback:done obj-id callback-data)
  (let ((val (vector-ref object-value-vec obj-id)))
    (if (condition? val) (signal-condition! val))
    (vector-set! object-value-vec obj-id #f)))

(define (sync-and-wait)
  (let ((id (alloc-id)) (cd (make-condition)))
    (set-object! id 'wl_callback cd)
    (wl_display:sync display-id id)
    (wait cd)))

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

(define (connect-display)
  (let* ((path socket-path)
         (style (logior SOCK_STREAM SOCK_CLOEXEC))
         (sock (socket PF_UNIX style 0))
         (conn (connect sock AF_UNIX path)))
    (fcntl sock F_SETFL (logior O_NONBLOCK (fcntl sock F_GETFL)))
    (set! rq-iobuf (make-bytevector 1024))
    (set! ev-iobuf (make-bytevector 1024))
    sock))

(define (sender)
  (let loop ((n-sent 0) (n-left 0) (cm #f) (rqq '()))
    (fsleep 0.01)
    (cond
     ((positive? n-left)
      (let ((n (sendmsg wl-sock rq-iobuf n-sent n-left cm)))
        (loop (+ n-sent n) (- n-left n) #f rqq)))
     ((pair? rqq)
      (call-with-values (car rqq)
        (lambda (ln cm)
          (loop 0 ln cm (cdr rqq)))))
     ((get-message rq-chan) =>
      (lambda (req)
        (loop n-sent n-left cm (cons req rqq))))
     (else
      (sferr "sender says wtf\n")))))

(define (receiver)
  (let loop ((n-have 0) (object-id #f) (msg-size 8) (opcode #f) 
(control #f))
    (cond
     ((< n-have msg-size)
      (let* ((res (recvmsg! wl-sock ev-iobuf n-have))
             (n-read (vector-ref res 0))
             (control (or control (vector-ref res 1)))
             (flags (vector-ref res 2)))
        (when (zero? n-read) (fsleep 0.1)) ; SLEEP HERE
        (loop (+ n-have n-read) object-id msg-size opcode control)))
     ((not object-id)
      (let* ((object-id (bytevector-u32-native-ref ev-iobuf 0))
             (word1 (bytevector-u32-native-ref ev-iobuf 4))
             (msg-size (bytevector-u16-native-ref ev-iobuf 
msg-size-offset))
             (opcode (bytevector-u16-native-ref ev-iobuf opcode-offset)))
        (loop n-have object-id msg-size opcode control)))
     (else
      (dispatch object-id opcode ev-iobuf 8 control)
      (if (> n-have msg-size)
          (bytevector-copy! ev-iobuf msg-size ev-iobuf 0 (- n-have 
msg-size)))
      (loop (- n-have msg-size) #f 8 opcode control)))))

(define (monitor)
  (sferr "monitor starting ...\n")
  (let* ((server (spawn-coop-repl-server)))
    (let loop ()
      (poll-coop-repl-server server)
      (yield-current-task)
      (fsleep 0.1)
      (loop))))

(define done-cond #f)

(define (done)
  (and done-cond (signal-condition! done-cond)))

(define (appl-main)
  (run-fibers
   (lambda ()
     (set! wl-sock (connect-display))
     (set! done-cond (make-condition))
     (set! rq-chan (make-channel))
     (install-handlers)
     (init-object-pool)
     ;;
     (spawn-fiber receiver)
     (spawn-fiber sender)
     (get-registry)
     (sync-and-wait)
     (init-globals)
     (sync-and-wait)
     (create-file-buffer)
     (spawn-fiber monitor)
     ;;
     (create-it)
     ;;(wait done-cond)
     (fsleep 3.0)
     (force-output (current-error-port))
     (close-port wl-sock))
   #:hz 0 #:install-suspendable-ports? #f))


(use-modules (ffi ffi-help-rt))
(use-modules (ffi cairo))

(define* (create-file-buffer #:optional (size #x1000000))
  (let* ((port (let ((port (tmpfile))) (truncate-file port size) port))
         (fd (port->fdes port))
         (bv (my-mmap 0 size (logior PROT_READ PROT_WRITE) MAP_SHARED 
fd 0)))
    (set! my-buf-bv bv)
    (set! my-buf-fd fd)
    (if #f #f)))

(define (draw-buffer)
  (let* ((format 'CAIRO_FORMAT_ARGB32)
         (format 'CAIRO_FORMAT_RGB24)
         (buffer my-buf-bv)
         (width 500) (height 300) (stride (* width 4))
         (srf (cairo_image_surface_create_for_data
               buffer format width height stride))
         (cro (cairo_create srf))
         (extents (make-cairo_text_extents_t))
         (text "Hello, world!"))
    (bytevector-fill! buffer #xee)

    (cairo_move_to cro 0.0 0.0)
    (cairo_move_to cro 20.0 20.0)
    (cairo_line_to cro 120.0 120.0)
    (cairo_stroke cro)

    (cairo_select_font_face
     cro "Sans" 'CAIRO_FONT_SLANT_NORMAL 'CAIRO_FONT_WEIGHT_NORMAL)
    (cairo_set_font_size cro 32.0)
    (cairo_text_extents cro text (pointer-to extents))
    (cairo_move_to cro 50.0 50.0)
    (cairo_show_text cro text)

    (if #f #f)))

(appl-main)