Simple Racket library to interact with Linux input event devices

evdev.rkt

#lang racket/base

(require ffi/unsafe
         ffi/unsafe/custodian
         ffi/unsafe/define
         ffi/unsafe/schedule
         racket/struct)

(provide evdev-open
         evdev-read
         evdev-close
         
         input-event-time_s
         input-event-time_us
         input-event-type
         input-event-code
         input-event-value)

(define-ffi-definer define-c-fun #f)

(define-cstruct _input-event
  ([time_s  _ulong]
   [time_us _ulong]
   [type    _ushort]
   [code    _ushort]
   [value   _uint])
  #:property prop:custom-write
  (make-constructor-style-printer
   (λ (o) '_input-event)
   (λ (o)
     (list (input-event-time_s o)
           (input-event-time_us o)
           (input-event-type o)
           (input-event-code o)
           (input-event-value o)))))

(define _input-event-size (ctype-sizeof _input-event))

;; Low level interface
;; bind open, read, and close from libc under different names
;; O_RDONLY == 0
(define-c-fun evdev-do-open
  (_fun #:save-errno 'posix
        _string [_int = 0] -> _int)
  #:c-id open)

(define-c-fun evdev-do-close
  (_fun #:save-errno 'posix
        _int -> _int)
  #:c-id close)

(define-c-fun evdev-do-read
  (_fun #:save-errno 'posix
        _int
        [event : (_ptr o _input-event)]
        [_size = _input-event-size]
        ->
        [size : _ssize]
        ->
        (values size event))
  #:c-id read)


;; High level interface

(define (evdev-poller this-evdev wakeups)
  (define fd (evdev-fd this-evdev))
  (define ready? (unsafe-poll-fd fd 'read #f))
  (define (do-read)
    (define-values (rc event) (evdev-do-read fd))
    (list (if (< rc 0) #f event)))
  (cond
    [ready?
     (values (if wakeups null (do-read)) #f)]
    [wakeups
     (unsafe-poll-ctx-fd-wakeup wakeups fd 'read)
     (values #f this-evdev)]
    [else (values #f this-evdev)]))

(struct evdev (fd cancel)
  #:property prop:evt
  (unsafe-poller evdev-poller))

(define (evdev-open filename)
  (define fd (evdev-do-open filename))
  (when (< fd 0)
    (error 'evdev-open "error opening device: ~a" (saved-errno)))
  (define cancel (register-custodian-shutdown fd evdev-do-close #:at-exit? #t))
  (evdev fd cancel))

(define (evdev-read this-evdev)
  (sync this-evdev))

(define (evdev-close this-evdev)
  (define fd (evdev-fd this-evdev))
  (define cancel (evdev-cancel this-evdev))
  (evdev-do-close fd)
  (unregister-custodian-shutdown fd cancel))