fun with wayland

[Matt Wette <matt.wette@gmail.com>]

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)