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

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.

1 files changed, 70 insertions, 6 deletions

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 187f1d44c1..1d86f99ca8 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -174,8 +174,17 @@ determined."
            (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 @@ determined."
                "-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 @@ hook."
     (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 @@ there, and write the build log to LOG-PORT.  Return the exit status."
   (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 @@ 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 @@ 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 @@ success, #f otherwise."
       (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 @@ success, #f otherwise."
 
   (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)