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.
This commit is contained in:
Ludovic Courtès 2014-04-08 13:48:30 +02:00
parent 5d2933aecc
commit c950141495
1 changed files with 13 additions and 7 deletions

View File

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