summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
Diffstat (limited to 'gnu')
-rw-r--r--gnu/build/secret-service.scm54
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