connection: Add support for suspendable sockets.

Ludovic Court??sTue May 23 20:44:21+0200 2023

cd0d23b

connection: Add support for suspendable sockets. * netlink/connection.scm (syscall->procedure): Add #:waiter. Distinguish first argument and call WAITER upon EWOULDBLOCK or EAGAIN when the first argument is a port. (ffi-sendto, ffi-recvmsg, ffi-bind): Pass #:waiter. (connect, send-msg, receive-msg): Pass SOCK instead of (fileno sock). Signed-off-by: Julien Lepiller <julien@lepiller.eu>

netlink/connection.scm

2626 
  #:use-module (srfi srfi-34)
2727 
  #:use-module (srfi srfi-35)
2828 
  #:use-module (srfi srfi-71)
29+
  #:autoload   (ice-9 suspendable-ports) (current-read-waiter
30+
                                          current-write-waiter)
2931 
  #:export (connect
3032 
            connect-route
3133 
            close-socket

…

3638 
3739 
(define libc (dynamic-link))
3840 
39-
(define (syscall->procedure return-type function
40-
                            argument-types)
41+
(define* (syscall->procedure return-type function
42+
                             argument-types
43+
                             #:key waiter)
4144 
  "Return a procedure that calls FUNCTION, a syscall wrapper from the C library
42-
with the given RETURN-TYPE and ARGUMENT-TYPES."
45+
with the given RETURN-TYPE and ARGUMENT-TYPES.  When WAITER is true and the
46+
first argument is a port, call it upon EAGAIN or EWOULDBLOCK."
4347 
  (let ((proc (pointer->procedure return-type
4448 
                                  (dynamic-func function libc)
4549 
                                  argument-types
4650 
                                  #:return-errno? #t)))
47-
    (lambda args
48-
      (let ((ret errno (apply proc args)))
49-
        (when (< ret 0)
50-
          (throw 'system-error function "~A"
51-
                 (list (strerror errno)) (list errno)))
52-
        ret))))
51+
    (lambda (first . rest)
52+
      (let loop ()
53+
        (let ((ret errno (apply proc
54+
                                (if (port? first) (fileno first) first)
55+
                                rest)))
56+
          (if (< ret 0)
57+
              (if (and (memv errno (list EAGAIN EWOULDBLOCK))
58+
                       (port? first) waiter)
59+
                  (begin
60+
                    ((waiter) first)
61+
                    (loop))
62+
                  (throw 'system-error function "~A"
63+
                         (list (strerror errno)) (list errno)))
64+
              ret))))))
5365 
5466 
(define ffi-sendto
55-
  (syscall->procedure int "sendto" (list int '* size_t int '* int)))
67+
  (syscall->procedure int "sendto" (list int '* size_t int '* int)
68+
                      #:waiter (lambda () (current-write-waiter))))
5669 
(define ffi-recvmsg
57-
  (syscall->procedure int "recvmsg" (list int '* int)))
70+
  (syscall->procedure int "recvmsg" (list int '* int)
71+
                      #:waiter (lambda () (current-read-waiter))))
5872 
(define ffi-bind
59-
  (syscall->procedure int "bind" (list int '* int)))
73+
  (syscall->procedure int "bind" (list int '* int)
74+
                      #:waiter (lambda () (current-read-waiter))))
6075 
6176 
;; define simple functions to open/close sockets
6277 
(define (open-socket proto)
…
89104 
90105 
(define* (connect proto addr)
91106 
  (let ((sock (open-socket proto)))
92-
    (ffi-bind (fileno sock)
107+
    (ffi-bind sock
93108 
              (bytevector->pointer addr)
94109 
              12)
95110 
    sock))
…
105120 
  (let* ((len (data-size msg))
106121 
         (bv (make-bytevector len)))
107122 
    (serialize msg 0 bv)
108-
    (ffi-sendto (fileno sock) (bytevector->pointer bv) len 0 %null-pointer 0)))
123+
    (ffi-sendto sock (bytevector->pointer bv) len 0 %null-pointer 0)))
109124 
110125 
(define* (receive-msg sock #:key (addr (get-addr AF_NETLINK 0 0)))
111126 
  (let* ((len (* 1024 32))
…
115130 
                             iovec 1
116131 
                             %null-pointer 0
117132 
                             0))
118-
         (size (ffi-recvmsg (fileno sock) msghdr 0))
133+
         (size (ffi-recvmsg sock msghdr 0))
119134 
         (answer (make-bytevector size)))
120135 
    (when (> size (* 1024 32))
121136 
      (raise (condition (&netlink-answer-too-big-error (size size)))))