Skip to content
Snippets Groups Projects
Commit c9501414 authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

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.
parent 5d2933ae
No related branches found
No related tags found
No related merge requests found
...@@ -324,12 +324,13 @@ (define script ...@@ -324,12 +324,13 @@ (define script
(leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%") (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%")
file machine status))))) file machine status)))))
(define (remove-gc-root machine) (define (remove-gc-roots machine)
"Remove from MACHINE the GC root previously installed with "Remove from MACHINE the GC roots previously installed with
'register-gc-root'." 'register-gc-root'."
(define script (define script
`(begin `(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 (let ((root-directory (string-append %state-directory
"/gcroots/tmp"))) "/gcroots/tmp")))
...@@ -337,8 +338,13 @@ (define script ...@@ -337,8 +338,13 @@ (define script
(delete-file (delete-file
(string-append root-directory "/" ,%gc-root-file))) (string-append root-directory "/" ,%gc-root-file)))
;; This one is created with 'guix build -r'. ;; These ones were created with 'guix build -r' (there can be more
(false-if-exception (delete-file ,%gc-root-file))))) ;; 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 (let ((pipe (remote-pipe machine OPEN_READ
`("guile" "-c" ,(object->string script))))) `("guile" "-c" ,(object->string script)))))
...@@ -405,12 +411,12 @@ (define* (transfer-and-offload drv machine ...@@ -405,12 +411,12 @@ (define* (transfer-and-offload drv machine
;; Likewise (see above.) ;; Likewise (see above.)
(with-machine-lock machine 'download (with-machine-lock machine 'download
(retrieve-files outputs machine)) (retrieve-files outputs machine))
(false-if-exception (remove-gc-root machine)) (remove-gc-roots machine)
(format (current-error-port) (format (current-error-port)
"done with offloaded '~a'~%" "done with offloaded '~a'~%"
(derivation-file-name drv))) (derivation-file-name drv)))
(begin (begin
(false-if-exception (remove-gc-root machine)) (remove-gc-roots machine)
(format (current-error-port) (format (current-error-port)
"derivation '~a' offloaded to '~a' failed \ "derivation '~a' offloaded to '~a' failed \
with exit code ~a~%" with exit code ~a~%"
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment