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)
