From c9501414957e04106531e53ee7a06b0d07ff4ac3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 8 Apr 2014 13:48:30 +0200
Subject: [PATCH] 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(-)

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~%"