[no subject]

[Ludovic Courtès]

branch: master
commit 6d1757e2498d45336f88ab01a94e253535f842a5
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Jul 15 17:06:25 2023 +0200

    Factorize 'with-store/non-blocking'.
    
    * src/cuirass/base.scm (ensure-non-blocking-store-connection): New 
procedure.
    (with-store/non-blocking): New macro.
    * src/cuirass/scripts/remote-server.scm 
(ensure-non-blocking-store-connection):
    Remove.
    (add-to-store): Use 'with-store/non-blocking' instead of 'with-store'.
    * .dir-locals.el (scheme-mode): Add 'with-store/non-blocking'.
---
 .dir-locals.el                        |  1 +
 src/cuirass/base.scm                  | 18 ++++++++++++++++++
 src/cuirass/scripts/remote-server.scm | 18 ++----------------
 3 files changed, 21 insertions(+), 16 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index d5db807..8c44a82 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -9,6 +9,7 @@
    . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>"))
  (scheme-mode
   (indent-tabs-mode)
+  (eval put 'with-store/non-blocking 'scheme-indent-function 1)
   (eval put 'call-with-time 'scheme-indent-function 1)
   (eval put 'test-error 'scheme-indent-function 1)
   (eval put 'make-parameter 'scheme-indent-function 1)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 87dced7..4fe68ba 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -65,6 +65,7 @@
             register-gc-roots
             read-parameters
             evaluate
+            with-store/non-blocking
             build-derivations&
             set-build-successful!
             clear-build-queue
@@ -191,6 +192,23 @@ any."
       (fcntl port F_SETFL (logior O_NONBLOCK flags)))
     port))
 
+(define (ensure-non-blocking-store-connection store)
+  "Mark the file descriptor that backs STORE, a <store-connection>, as
+O_NONBLOCK."
+  (match (store-connection-socket store)
+    ((? file-port? port)
+     (non-blocking-port port))
+    (_ #f)))
+
+(define-syntax-rule (with-store/non-blocking store exp ...)
+  "Like 'with-store', bind STORE to a connection to the store, but ensure that
+said connection is non-blocking (O_NONBLOCK).  Evaluate EXP... in that
+context."
+  (with-store store
+    (ensure-non-blocking-store-connection store)
+    (let ()
+      exp ...)))
+
 (define %cuirass-state-directory
   ;; Directory where state files are stored, usually "/var".
   (make-parameter (or (getenv "CUIRASS_STATE_DIRECTORY")
diff --git a/src/cuirass/scripts/remote-server.scm 
b/src/cuirass/scripts/remote-server.scm
index 41084b2..580d112 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -41,9 +41,7 @@
   #:use-module ((guix store)
                 #:select (current-build-output-port
                           ensure-path
-                          store-protocol-error?
-                          store-connection-socket
-                          with-store))
+                          store-protocol-error?))
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix workers)
@@ -340,24 +338,12 @@ be used to reply to the worker."
      (lambda (tmp-file port)
        (url-fetch* narinfo-url tmp-file)))))
 
-(define (ensure-non-blocking-store-connection store)
-  "Mark the file descriptor that backs STORE, a <store-connection>, as
-O_NONBLOCK."
-  (match (store-connection-socket store)
-    ((? file-port? port)
-     (let* ((fd (fileno port))
-            (flags (fcntl fd F_GETFL)))
-       (when (zero? (logand flags O_NONBLOCK))
-         (fcntl fd F_SETFL (logior O_NONBLOCK flags)))))
-    (_ #f)))
-
 (define (add-to-store drv outputs url)
   "Add the OUTPUTS that are available from the substitute server at URL to the
 store.  Register GC roots for the matching DRV and trigger a substitute baking
 at URL."
   (parameterize ((current-build-output-port (%make-void-port "w")))
-    (with-store store
-      (ensure-non-blocking-store-connection store)
+    (with-store/non-blocking store
       (set-build-options* store (list url))
       (for-each
        (lambda (output)