07/07: secret-service: Allow cooperative scheduling when Fibers is used.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 28b3763e33cd71fe281cd71a568c54fea7f4cf4f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Mar 28 15:17:59 2022 +0200

    secret-service: Allow cooperative scheduling when Fibers is used.
    
    This lets the 'childhurd' service start in the background, letting
    shepherd perform other tasks in the meantime, including serving
    clients (such as the 'herd' command).
    
    * gnu/build/secret-service.scm (with-modules): New macro.
    (wait-for-readable-fd): Add cooperative implementation when Fibers is in
    use.
    (secret-service-send-secrets): Define 'sleep' so that it cooperates when
    Fibers is in use.
---
 gnu/build/secret-service.scm | 54 ++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 50 insertions(+), 4 deletions(-)

diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm
index 621c4447dc..1baa058635 100644
--- a/gnu/build/secret-service.scm
+++ b/gnu/build/secret-service.scm
@@ -47,12 +47,51 @@
          ;; to syslog.
          #'(format (current-output-port) fmt args ...))))))
 
+(define-syntax with-modules
+  (syntax-rules ()
+    "Dynamically load the given MODULEs at run time, making the chosen
+bindings available within the lexical scope of BODY."
+    ((_ ((module #:select (bindings ...)) rest ...) body ...)
+     (let* ((iface (resolve-interface 'module))
+            (bindings (module-ref iface 'bindings))
+            ...)
+       (with-modules (rest ...) body ...)))
+    ((_ () body ...)
+     (begin body ...))))
+
 (define (wait-for-readable-fd port timeout)
   "Wait until PORT has data available for reading or TIMEOUT has expired.
 Return #t in the former case and #f in the latter case."
-  (match (select (list port) '() '() timeout)
-    (((_) () ()) #t)
-    ((() () ())  #f)))
+  (match (resolve-module '(fibers) #f)            ;using Fibers?
+    (#f
+     (log "blocking on socket...~%")
+     (match (select (list port) '() '() timeout)
+       (((_) () ()) #t)
+       ((() () ())  #f)))
+    (fibers
+     ;; We're running on the Shepherd 0.9+ with Fibers.  Arrange to make a
+     ;; non-blocking wait so that other fibers can be scheduled in while we
+     ;; wait for PORT.
+     (with-modules (((fibers) #:select (spawn-fiber sleep))
+                    ((fibers channels)
+                     #:select (make-channel put-message get-message)))
+       ;; Make PORT non-blocking.
+       (let ((flags (fcntl port F_GETFL)))
+         (fcntl port F_SETFL (logior O_NONBLOCK flags)))
+
+       (let ((channel (make-channel)))
+         (spawn-fiber
+          (lambda ()
+            (sleep timeout)                       ;suspends the fiber
+            (put-message channel 'timeout)))
+         (spawn-fiber
+          (lambda ()
+            (lookahead-u8 port)                   ;suspends the fiber
+            (put-message channel 'readable)))
+         (log "suspending fiber on socket...~%")
+         (match (get-message channel)
+           ('readable #t)
+           ('timeout  #f)))))))
 
 (define* (secret-service-send-secrets port secret-root
                                       #:key (retry 60)
@@ -81,7 +120,10 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to 
complete.  Return
 
   (log "sending secrets to ~a~%" port)
   (let ((sock (socket AF_INET SOCK_STREAM 0))
-        (addr (make-socket-address AF_INET INADDR_LOOPBACK port)))
+        (addr (make-socket-address AF_INET INADDR_LOOPBACK port))
+        (sleep (if (resolve-module '(fibers) #f)
+                   (module-ref (resolve-interface '(fibers)) 'sleep)
+                   sleep)))
     ;; Connect to QEMU on the forwarded port.  The 'connect' call succeeds as
     ;; soon as QEMU is ready, even if there's no server listening on the
     ;; forward port inside the guest.
@@ -208,4 +250,8 @@ and #f otherwise."
       (close-port port))
     result))
 
+;;; Local Variables:
+;;; eval: (put 'with-modules 'scheme-indent-function 1)
+;;; End:
+
 ;;; secret-service.scm ends here