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.

1 files 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