From c9501414957e04106531e53ee7a06b0d07ff4ac3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Apr 2014 13:48:30 +0200 Subject: 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. --- guix/scripts/offload.scm | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) (limited to 'guix/scripts/offload.scm') 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 @@ (define script (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 @@ (define script (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 @@ (define* (transfer-and-offload drv 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~%" -- cgit v1.2.3