05/05: graft: Fail when one of the threads raises an exception.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 007c20b61c84af11289f96d43374e2e688838a26
Author: Ludovic Courtès <address@hidden>
Date:   Tue May 24 23:49:26 2016 +0200

    graft: Fail when one of the threads raises an exception.
    
    Fixes <http://bugs.gnu.org/23581>.
    
    * guix/build/graft.scm (exit-on-exception): New procedure.
    (rewrite-directory): Use it to wrap REWRITE-LEAF.
---
 guix/build/graft.scm |   21 +++++++++++++++++++--
 1 file changed, 19 insertions(+), 2 deletions(-)

diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index b61982d..fb21fc3 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -105,6 +105,19 @@ a list of store file name pairs."
                                (string-append (dirname file) "/" target))))
               matches)))
 
+(define (exit-on-exception proc)
+  "Return a procedure that wraps PROC so that 'primitive-exit' is called when
+an exception is caught."
+  (lambda (arg)
+    (catch #t
+      (lambda ()
+        (proc arg))
+      (lambda (key . args)
+        ;; Since ports are not thread-safe as of Guile 2.0, reopen stderr.
+        (let ((port (fdopen 2 "w0")))
+          (print-exception port #f key args)
+          (primitive-exit 1))))))
+
 (define* (rewrite-directory directory output mapping
                             #:optional (store (%store-directory)))
   "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
@@ -147,9 +160,13 @@ file name pairs."
   ;; #o777.
   (umask #o022)
 
+  ;; Use 'exit-on-exception' to force an exit upon I/O errors, given that
+  ;; 'n-par-for-each' silently swallows exceptions.
+  ;; See <http://bugs.gnu.org/23581>.
   (n-par-for-each (parallel-job-count)
-                  rewrite-leaf (find-files directory (const #t)
-                                           #:directories? #t))
+                  (exit-on-exception rewrite-leaf)
+                  (find-files directory (const #t)
+                              #:directories? #t))
   (rename-matching-files output mapping))
 
 ;;; graft.scm ends here