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