summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-04-08 13:48:30 +0200
committerLudovic Courtès <ludo@gnu.org>2014-04-08 13:48:30 +0200
commitc9501414957e04106531e53ee7a06b0d07ff4ac3 (patch)
tree0964dd650025efc3cead66ef7a74f273ef659deb
parent5d2933aecc2ed11d8816b2c3eae239b8ece6cbbb (diff)
downloadpatches-c9501414957e04106531e53ee7a06b0d07ff4ac3.tar
patches-c9501414957e04106531e53ee7a06b0d07ff4ac3.tar.gz
offload: Remove all the GC roots in case of multiple-output derivations.
* guix/scripts/offload.scm (remove-gc-root): Rename to... (remove-gc-roots): ... this. [builder]: Use 'scandir' and remove all the files starting with %GC-ROOT-FILE. (transfer-and-offload): Adjust to renaming; remove 'false-if-exception' wraps.
-rw-r--r--guix/scripts/offload.scm20
1 files changed, 13 insertions, 7 deletions
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 0761d68492..c5cae4b07a 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -324,12 +324,13 @@ hook."
(leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%")
file machine status)))))
-(define (remove-gc-root machine)
- "Remove from MACHINE the GC root previously installed with
+(define (remove-gc-roots machine)
+ "Remove from MACHINE the GC roots previously installed with
'register-gc-root'."
(define script
`(begin
- (use-modules (guix config))
+ (use-modules (guix config) (ice-9 ftw)
+ (srfi srfi-1) (srfi srfi-26))
(let ((root-directory (string-append %state-directory
"/gcroots/tmp")))
@@ -337,8 +338,13 @@ hook."
(delete-file
(string-append root-directory "/" ,%gc-root-file)))
- ;; This one is created with 'guix build -r'.
- (false-if-exception (delete-file ,%gc-root-file)))))
+ ;; These ones were created with 'guix build -r' (there can be more
+ ;; than one in case of multiple-output derivations.)
+ (let ((roots (filter (cut string-prefix? ,%gc-root-file <>)
+ (scandir "."))))
+ (for-each (lambda (file)
+ (false-if-exception (delete-file file)))
+ roots)))))
(let ((pipe (remote-pipe machine OPEN_READ
`("guile" "-c" ,(object->string script)))))
@@ -405,12 +411,12 @@ MACHINE."
;; Likewise (see above.)
(with-machine-lock machine 'download
(retrieve-files outputs machine))
- (false-if-exception (remove-gc-root machine))
+ (remove-gc-roots machine)
(format (current-error-port)
"done with offloaded '~a'~%"
(derivation-file-name drv)))
(begin
- (false-if-exception (remove-gc-root machine))
+ (remove-gc-roots machine)
(format (current-error-port)
"derivation '~a' offloaded to '~a' failed \
with exit code ~a~%"