[no subject]

[Ludovic Courtès]

branch: master
commit 10a5117936bb51c54a362172b6e53ef5150ab909
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Jan 9 17:58:41 2024 +0100

    store: ‘build-derivations&’ makes the store blocking before proceeding.
    
    Fixes <https://issues.guix.gnu.org/68237>.
    
    In non-‘--build-remote’ mode, local builds started by ‘spawn-builds’
    would fail with a backtrace along these lines:
    
      In cuirass/base.scm:
         422:14  5 (_ _)
         267:10  4 (spawn-builds #<store-connection 256.99 7f3a08fd0aa0> _ ?)
      In ice-9/boot-9.scm:
        1752:10  3 (with-exception-handler _ _ #:unwind? _ # _)
        1685:16  2 (raise-exception _ #:continuable? _)
        1683:16  1 (raise-exception _ #:continuable? _)
        1685:16  0 (raise-exception _ #:continuable? _)
      ice-9/boot-9.scm:1685:16: In procedure raise-exception:
      In procedure struct-vtable: Wrong type argument in position 1 (expecting 
struct): #f
    
    The wrong-type-arg exception was re-thrown from the ‘build-derivation&’
    and the backtrace for the actual ‘wrong-type-arg’ exception looked like
    this:
    
      In guix/serialization.scm:
          76:12 12 (read-int #<input-output: socket 46>)
      In ice-9/suspendable-ports.scm:
         307:17 11 (get-bytevector-n #<input-output: socket 46> 8)
         284:18 10 (get-bytevector-n! #<input-output: socket 46> #vu8(0 ?) ?)
          67:33  9 (read-bytes #<input-output: socket 46> #vu8(0 0 0 0 0 ?) ?)
      In fibers/scheduler.scm:
         355:13  8 (suspend-current-task #<procedure 7f1863a10900 at fiber?>)
      In ice-9/boot-9.scm:
        1685:16  7 (raise-exception _ #:continuable? _)
      In cuirass/store.scm:
         158:28  6 (_ #<&compound-exception components: (#<&assertion-fail?>)
      In unknown file:
                 5 (display-backtrace #<stack 7f1860a0dda0> #<output: fil?> ?)
    
    This is because there’s no Fibers scheduler in the thread.  Gnarly.
    
    * src/cuirass/store.scm (blocking-port?, blocking-port)
    (ensure-blocking-store-connection): New procedures.
    (build-derivations&): Call ‘ensure-blocking-store-connection’ in the
    thread and ‘ensure-non-blocking-store-connection’ in finish procedure.
    * tests/store.scm: New file.
    * Makefile.am: Add it.
    
    Reported-by: Collin J. Doering <collin@rekahsoft.ca>
    Reported-by: Kjetil Haugen <Kjetil.Haugen@amd.com>
---
 Makefile.am           |   1 +
 src/cuirass/store.scm |  36 ++++++++++++++++-
 tests/store.scm       | 110 ++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 145 insertions(+), 2 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 671808d..38f392d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -158,6 +158,7 @@ AM_SH_LOG_FLAGS = -x -e
 TESTS = \
   tests/base.scm \
 ## tests/basic.sh # takes too long to execute
+  tests/store.scm \
   tests/database.scm \
   tests/http.scm \
   tests/metrics.scm \
diff --git a/src/cuirass/store.scm b/src/cuirass/store.scm
index 0479134..86e0f49 100644
--- a/src/cuirass/store.scm
+++ b/src/cuirass/store.scm
@@ -1,5 +1,5 @@
 ;;; store.scm -- Fiberized access to the store.
-;;; Copyright © 2016-2019, 2022-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016-2019, 2022-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
 ;;;
 ;;; This file is part of Cuirass.
@@ -91,6 +91,10 @@ any."
 ;;; Fiberized access to the store.
 ;;;
 
+(define (blocking-port? port)
+  "Return true if PORT is blocking--i.e., lacking O_NONBLOCK."
+  (zero? (logand O_NONBLOCK (fcntl port F_GETFL))))
+
 (define (non-blocking-port port)
   "Make PORT non-blocking and return it."
   (let ((flags (fcntl port F_GETFL)))
@@ -106,6 +110,20 @@ O_NONBLOCK."
      (non-blocking-port port))
     (_ #f)))
 
+(define (blocking-port port)
+  "Make PORT as blocking (i.e., ~O_NONBLOCK) and return it."
+  (let ((flags (fcntl port F_GETFL)))
+    (unless (zero? (logand O_NONBLOCK flags))
+      (fcntl port F_SETFL (logand (lognot O_NONBLOCK) flags)))
+    port))
+
+(define (ensure-blocking-store-connection store)
+  "Mark the file descriptor that backs STORE, a <store-connection>, as 
blocking."
+  (match (store-connection-socket store)
+    ((? file-port? port)
+     (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
@@ -145,10 +163,19 @@ Essentially this procedure inverts the 
inversion-of-control that
   (define channel
     (make-channel))
 
+  (define blocking-store?
+    (blocking-port? (store-connection-socket store)))
+
   (match (pipe)
     ((input . output)
      (call-with-new-thread
       (lambda ()
+        ;; We're now in a non-fiberized thread and Fibers'
+        ;; 'current-read-waiter' and 'current-read-writer' would not work here
+        ;; since there's no fiber to suspend.  Thus, make sure to deal with
+        ;; blocking ports.
+        (ensure-blocking-store-connection store)
+
         ;; String I/O primitives are going to be used on PORT so make it
         ;; Unicode-capable and resilient to encoding issues.
         (set-port-encoding! output "UTF-8")
@@ -170,6 +197,11 @@ Essentially this procedure inverts the 
inversion-of-control that
                ;; to avoid blocking the thread that runs the calling fiber.
                (match (get-message channel)
                  ((? exception? c)
+                  (unless blocking-store?
+                    (ensure-non-blocking-store-connection store))
                   (raise-exception c))
-                 (x x)))))))
+                 (x
+                  (unless blocking-store?
+                    (ensure-non-blocking-store-connection store))
+                  x)))))))
 
diff --git a/tests/store.scm b/tests/store.scm
new file mode 100644
index 0000000..554f9c4
--- /dev/null
+++ b/tests/store.scm
@@ -0,0 +1,110 @@
+;;; store.scm -- Helpers to deal with the store.
+;;; Copyright © 2024 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Cuirass is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests store)
+  #:use-module (guix store)
+  #:use-module (guix gexp)
+  #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
+  #:use-module (cuirass store)
+  #:use-module (fibers)
+  #:use-module (fibers channels)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-71))
+
+(define %seed
+  (logxor (cdr (gettimeofday))
+          (car (gettimeofday))
+          (cdr (gettimeofday))))
+
+(define %state
+  (seed->random-state %seed))
+
+(define (trivial-thing)
+  (let ((nonce (random 1e6 %state)))
+    (computed-file "trivial-thing"
+                   #~(begin
+                       (set-port-encoding! (current-output-port) "UTF-8")
+
+                       (display "starting!\n") (force-output)
+                       (display "lambda: λ\n") (force-output)
+
+                       ;; Sleep to give the 'current-read-waiter' a chance to
+                       ;; be invoked.
+                       (sleep 1)
+
+                       #$nonce
+                       (mkdir #$output)
+                       (display "done\n"))
+                   #:guile %bootstrap-guile)))
+
+(define (trivial-derivation store)
+  (run-with-store store
+    (lower-object (trivial-thing))))
+
+
+(test-begin "store")
+
+(test-equal "build-derivations&, non-fiber"
+  '(build-succeeded build-started)
+  (with-store store
+    (set-build-options store #:print-build-trace #t)
+    (let* ((drv (trivial-derivation store))
+           (port finish (build-derivations& store (list drv)))
+           (events (process-build-log port
+                                      (lambda (event result)
+                                        (cons (car event) result))
+                                      '())))
+      (close-port port)
+      (finish)
+      events)))
+
+(test-equal "build-derivations&, fiberized and non-blocking"
+  '(build-succeeded build-started)
+
+  ;; This test used to crash: 'build-derivations&' spawns a non-fiber thread
+  ;; so we need to make sure it uses a blocking store connection or it would
+  ;; end up invoking the Fibers scheduler (via 'current-read-waiter' & co.),
+  ;; which would crash.  See <https://issues.guix.gnu.org/68237>.
+  (run-fibers
+   (lambda ()
+     (define channel
+       (make-channel))
+
+     (spawn-fiber
+      (lambda ()
+        ;; XXX: We cannot use 'with-store/non-blocking' upfront because
+        ;; packages use promises, and 'force' is a continuation barrier as of
+        ;; Guile 3.0.9.
+        (with-store store
+          (with-store/non-blocking store2
+            (set-build-options store #:print-build-trace #t)
+            (set-build-options store2 #:print-build-trace #t)
+            (let* ((drv (trivial-derivation store))
+                   (port finish (build-derivations& store2 (list drv)))
+                   (events (process-build-log port
+                                              (lambda (event result)
+                                                (cons (car event) result))
+                                              '())))
+              (close-port port)
+              (finish)
+              (put-message channel events))))))
+
+     (get-message channel))))
+
+(test-end "store")