nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
guix/scripts/offload.scm
View File

@ -324,12 +324,13 @@ hook."
(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 @@ hook."
(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 @@ 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~%"