summaryrefslogtreecommitdiff
path: root/guix/build/graft.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-05-24 23:49:26 +0200
committerLudovic Courtès <ludo@gnu.org>2016-05-24 23:52:14 +0200
commit007c20b61c84af11289f96d43374e2e688838a26 (patch)
tree5ea3e1da76a2d8239798e4e7e0d734b2eeed4a44 /guix/build/graft.scm
parent92ed837a1eaa0e921e17497e262a6da510323726 (diff)
downloadguix-patches-007c20b61c84af11289f96d43374e2e688838a26.tar
guix-patches-007c20b61c84af11289f96d43374e2e688838a26.tar.gz
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.
Diffstat (limited to 'guix/build/graft.scm')
-rw-r--r--guix/build/graft.scm21
1 files changed, 19 insertions, 2 deletions
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index b61982dd64..fb21fc3af3 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