diff options
| -rw-r--r-- | gnu/build/secret-service.scm | 54 |
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 |