bug#63516: [PATCH Guile-Netlink 04/11] connection: Add support for suspendable sockets.

["Ludovic Courtès" <ludo@gnu.org>]

* 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).
---
 netlink/connection.scm | 45 ++++++++++++++++++++++++++++--------------
 1 file changed, 30 insertions(+), 15 deletions(-)

diff --git a/netlink/connection.scm b/netlink/connection.scm
index f4a5cc6..42f7dbb 100644
--- a/netlink/connection.scm
+++ b/netlink/connection.scm
@@ -26,6 +26,8 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-71)
+  #:autoload   (ice-9 suspendable-ports) (current-read-waiter
+                                          current-write-waiter)
   #:export (connect
             connect-route
             close-socket
@@ -36,27 +38,40 @@
 
 (define libc (dynamic-link))
 
-(define (syscall->procedure return-type function
-                            argument-types)
+(define* (syscall->procedure return-type function
+                             argument-types
+                             #:key waiter)
   "Return a procedure that calls FUNCTION, a syscall wrapper from the C library
-with the given RETURN-TYPE and ARGUMENT-TYPES."
+with the given RETURN-TYPE and ARGUMENT-TYPES.  When WAITER is true and the
+first argument is a port, call it upon EAGAIN or EWOULDBLOCK."
   (let ((proc (pointer->procedure return-type
                                   (dynamic-func function libc)
                                   argument-types
                                   #:return-errno? #t)))
-    (lambda args
-      (let ((ret errno (apply proc args)))
-        (when (< ret 0)
-          (throw 'system-error function "~A"
-                 (list (strerror errno)) (list errno)))
-        ret))))
+    (lambda (first . rest)
+      (let loop ()
+        (let ((ret errno (apply proc
+                                (if (port? first) (fileno first) first)
+                                rest)))
+          (if (< ret 0)
+              (if (and (memv errno (list EAGAIN EWOULDBLOCK))
+                       (port? first) waiter)
+                  (begin
+                    ((waiter) first)
+                    (loop))
+                  (throw 'system-error function "~A"
+                         (list (strerror errno)) (list errno)))
+              ret))))))
 
 (define ffi-sendto
-  (syscall->procedure int "sendto" (list int '* size_t int '* int)))
+  (syscall->procedure int "sendto" (list int '* size_t int '* int)
+                      #:waiter (lambda () (current-write-waiter))))
 (define ffi-recvmsg
-  (syscall->procedure int "recvmsg" (list int '* int)))
+  (syscall->procedure int "recvmsg" (list int '* int)
+                      #:waiter (lambda () (current-read-waiter))))
 (define ffi-bind
-  (syscall->procedure int "bind" (list int '* int)))
+  (syscall->procedure int "bind" (list int '* int)
+                      #:waiter (lambda () (current-read-waiter))))
 
 ;; define simple functions to open/close sockets
 (define (open-socket proto)
@@ -89,7 +104,7 @@ such as 'bind' cannot handle."
 
 (define* (connect proto addr)
   (let ((sock (open-socket proto)))
-    (ffi-bind (fileno sock)
+    (ffi-bind sock
               (bytevector->pointer addr)
               12)
     sock))
@@ -105,7 +120,7 @@ such as 'bind' cannot handle."
   (let* ((len (data-size msg))
          (bv (make-bytevector len)))
     (serialize msg 0 bv)
-    (ffi-sendto (fileno sock) (bytevector->pointer bv) len 0 %null-pointer 0)))
+    (ffi-sendto sock (bytevector->pointer bv) len 0 %null-pointer 0)))
 
 (define* (receive-msg sock #:key (addr (get-addr AF_NETLINK 0 0)))
   (let* ((len (* 1024 32))
@@ -115,7 +130,7 @@ such as 'bind' cannot handle."
                              iovec 1
                              %null-pointer 0
                              0))
-         (size (ffi-recvmsg (fileno sock) msghdr 0))
+         (size (ffi-recvmsg sock msghdr 0))
          (answer (make-bytevector size)))
     (when (> size (* 1024 32))
       (raise (condition (&netlink-answer-too-big-error (size size)))))
-- 
2.40.1