aboutsummaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-03-28 15:17:59 +0200
committerLudovic Courtès <ludo@gnu.org>2022-04-07 00:08:56 +0200
commit28b3763e33cd71fe281cd71a568c54fea7f4cf4f (patch)
tree42b334f239208ca18420cff5320ecdbeeaa311de /gnu/build
parent83121aa85a0237f81c9a3c1dd36f1206c1cae854 (diff)
downloadguix-28b3763e33cd71fe281cd71a568c54fea7f4cf4f.tar
guix-28b3763e33cd71fe281cd71a568c54fea7f4cf4f.tar.gz
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.
Diffstat (limited to 'gnu/build')
-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