ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

offload: Prevent the '.drv' and build result from being GC'd.

Browse source 
Before that, there was a small time window during which the GC could
wipe the .drv (before 'guix build' has been called), or the build
result (before 'retrieve-files' has started.)

* guix/scripts/offload.scm (remote-pipe): Add #:quote? parameter and
  honor it.
  (%gc-root-file): New variable.
  (register-gc-root, remove-gc-root): New procedures.
  (offload): Adjust comment.  Run 'guix build' with '-r %GC-ROOT-FILE'.
  (transfer-and-offload): Call 'register-gc-root' before
  sending (derivation-file-name DRV).  Call 'remove-gc-root' after the
  call to 'offload' or 'retrieve-files'.
  (send-files): Call 'remote-pipe' with #:quote? #f.
  (retrieve-files): Likewise.
This commit is contained in:
Ludovic Courtès 2014-04-03 23:41:16 +02:00
parent 50322c847d
commit 4b00f3434e
1 changed files with 70 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

76
guix/scripts/offload.scm
View file

@ -174,8 +174,17 @@ (define-syntax with-error-to-port
(set-current-error-port old)))))))
(define* (remote-pipe machine mode command
#:key (error-port (current-error-port)))
"Run COMMAND on MACHINE, assuming an lsh gateway has been set up."
#:key (error-port (current-error-port)) (quote? #t))
"Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been
set up. When QUOTE? is true, perform shell-quotation of all the elements of
COMMAND."
(define (shell-quote str)
;; Sort-of shell-quote STR so it can be passed as an argument to the
;; shell.
(with-output-to-string
(lambda ()
(write str))))
(catch 'system-error
(lambda ()
;; Let the child inherit ERROR-PORT.
@ -188,7 +197,9 @@ (define* (remote-pipe machine mode command
"-i" (build-machine-private-key machine)
(build-machine-name machine)
command)))
(if quote?
(map shell-quote command)
command))))
(lambda args
(warning (_ "failed to execute '~a': ~a~%")
%lshg-command (strerror (system-error-errno args)))
@ -283,6 +294,52 @@ (define (build-log-port)
(set-port-revealed! port 1)
port))
(define %gc-root-file
;; File name of the temporary GC root we install.
(format #f "offload-~a-~a" (gethostname) (getpid)))
(define (register-gc-root file machine)
"Mark FILE, a store item, as a garbage collector root on MACHINE."
(define script
`(begin
(use-modules (guix config))
;; Note: we can't use 'add-indirect-root' because dangling links under
;; gcroots/auto are automatically deleted by the GC. This strategy
;; doesn't have this problem, but it requires write access to that
;; directory.
(let ((root-directory (string-append %state-directory
"/gcroots/tmp")))
(false-if-exception (mkdir root-directory))
(symlink ,file
(string-append root-directory "/" ,%gc-root-file)))))
(let ((pipe (remote-pipe machine OPEN_READ
`("guile" "-c" ,(object->string script)))))
(get-string-all pipe)
(close-pipe pipe)))
(define (remove-gc-root machine)
"Remove from MACHINE the GC root previously installed with
'register-gc-root'."
(define script
`(begin
(use-modules (guix config))
(let ((root-directory (string-append %state-directory
"/gcroots/tmp")))
(false-if-exception
(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)))))
(let ((pipe (remote-pipe machine OPEN_READ
`("guile" "-c" ,(object->string script)))))
(get-string-all pipe)
(close-pipe pipe)))
(define* (offload drv machine
#:key print-build-trace? (max-silent-time 3600)
build-timeout (log-port (build-log-port)))
@ -293,9 +350,11 @@ (define* (offload drv machine
(format (current-error-port) "@ build-remote ~a ~a~%"
(derivation-file-name drv) (build-machine-name machine))
;; FIXME: Protect DRV from garbage collection on MACHINE.
;; Normally DRV has already been protected from GC when it was transferred.
;; The '-r' flag below prevents the build result from being GC'd.
(let ((pipe (remote-pipe machine OPEN_READ
`("guix" "build"
"-r" ,%gc-root-file
,(format #f "--max-silent-time=~a"
max-silent-time)
,@(if build-timeout
@ -329,6 +388,7 @@ (define* (transfer-and-offload drv machine
;; a given direction to/from MACHINE in the presence of several 'offload'
;; hook instance.
(when (with-machine-lock machine 'upload
(register-gc-root (derivation-file-name drv) machine)
(send-files (cons (derivation-file-name drv) inputs)
machine))
(let ((status (offload drv machine
@ -340,10 +400,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))
(format (current-error-port)
"done with offloaded '~a'~%"
(derivation-file-name drv)))
(begin
(false-if-exception (remove-gc-root machine))
(format (current-error-port)
"derivation '~a' offloaded to '~a' failed \
with exit code ~a~%"
@ -386,7 +448,8 @@ (define (missing-files files)
(let* ((files (missing-files (topologically-sorted store files)))
(pipe (remote-pipe machine OPEN_WRITE
'("xz" "-dc" "|"
"guix" "archive" "--import"))))
"guix" "archive" "--import")
#:quote? #f)))
(format #t (_ "sending ~a store files to '~a'...~%")
(length files) (build-machine-name machine))
(call-with-compressed-output-port 'xz pipe
@ -407,7 +470,8 @@ (define host
(let ((pipe (remote-pipe machine OPEN_READ
`("guix" "archive" "--export" ,@files
"|" "xz" "-c"))))
"|" "xz" "-c")
#:quote? #f)))
(and pipe
(with-store store
(guard (c ((nix-protocol-error? c)