[no subject]

[Ludovic Courtès]

branch: master
commit 3bbb5c8447d9b3bad4b3311781636a9a624d62f7
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Oct 25 18:16:28 2023 +0200

    store: ‘build-derivations&’ enforces synchronization with the build.
    
    Previously, it was possible for the user to call the returned thunk
    before ‘build-derivations’ had completed, thereby getting #f (the
    initial value of ‘result’).  This made no sense because
    ‘build-derivations’ always returns #t or raises an exception.
    
    This situation could happen in ‘cuirass remote-worker’ if the
    corresponding ‘cuirass remote-server’ process disappeared in the middle
    of a build, because ‘send-logs’ would return early, leading the finish
    thunk of ‘build-derivations&’ to be called before build completion.
    
    This change uses a channel to enforce synchronization with the thread
    that calls ‘build-derivations’.
    
    Partly fixes <https://issues.guix.gnu.org/66692>.
    
    * src/cuirass/store.scm (build-derivations&): Use
    ‘with-exception-handler’ and ‘put-message’ in the thread.  Use
    ‘get-message’ instead of ‘atomic-box-ref’ in the finalization procedure.
    
    Reported-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
---
 src/cuirass/store.scm | 46 +++++++++++++++++++++++-----------------------
 1 file changed, 23 insertions(+), 23 deletions(-)

diff --git a/src/cuirass/store.scm b/src/cuirass/store.scm
index 07658be..f3661cb 100644
--- a/src/cuirass/store.scm
+++ b/src/cuirass/store.scm
@@ -23,11 +23,10 @@
                                    derivation-path->output-paths)
   #:use-module ((guix config) #:select (%state-directory))
   #:use-module (srfi srfi-34)
-  #:use-module ((srfi srfi-35) #:select (condition?))
-  #:use-module (ice-9 atomic)
   #:use-module (ice-9 match)
   #:autoload   (ice-9 rdelim) (read-line)
   #:use-module (ice-9 threads)
+  #:autoload   (fibers channels) (make-channel put-message get-message)
   #:export (non-blocking-port
             with-store/non-blocking
             process-build-log
@@ -135,40 +134,41 @@ does.  Return the result of the last call to PROC."
 (define (build-derivations& store lst)
   "Like 'build-derivations' but return two values: a file port from which to
 read the build log, and a thunk to call after EOF has been read.  The thunk
-returns the value of the underlying 'build-derivations' call, or raises the
+waits for the build process to complete; it then returns #t or raises the
 exception that 'build-derivations' raised.
 
 Essentially this procedure inverts the inversion-of-control that
 'build-derivations' imposes, whereby 'build-derivations' writes to
 'current-build-output-port'."
   ;; XXX: Make this part of (guix store)?
-  (define result
-    (make-atomic-box #f))
+  (define channel
+    (make-channel))
 
   (match (pipe)
     ((input . output)
      (call-with-new-thread
       (lambda ()
-        (catch #t
-          (lambda ()
-            ;; 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")
-            (set-port-conversion-strategy! output 'substitute)
-
-            (guard (c ((store-error? c)
-                       (atomic-box-set! result c)))
-              (parameterize ((current-build-output-port output))
-                (let ((x (build-derivations store lst)))
-                  (atomic-box-set! result x))))
-            (close-port output))
-          (lambda _
-            (close-port output)))))
+        ;; 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")
+        (set-port-conversion-strategy! output 'substitute)
+
+        (let ((result (with-exception-handler
+                          (lambda (exception) exception)
+                        (lambda ()
+                          (parameterize ((current-build-output-port output))
+                            (build-derivations store lst)))
+                        #:unwind? #t)))
+          (close-port output)
+          (put-message channel result))))
 
      (values (non-blocking-port input)
              (lambda ()
-               (match (atomic-box-ref result)
-                 ((? condition? c)
-                  (raise c))
+               ;; Wait for the build process to complete and return its
+               ;; result.  Note: use 'get-message' rather than 'join-thread'
+               ;; to avoid blocking the thread that runs the calling fiber.
+               (match (get-message channel)
+                 ((? exception? c)
+                  (raise-exception c))
                  (x x)))))))