offload: Send build logs to file descriptor 4.

* guix/scripts/offload.scm (with-error-to-port): New macro.
  (remote-pipe): Add #:error-port parameter.  Use 'with-error-to-port'
  around 'open-pipe*' call.
  (build-log-port): New procedure.
  (offload): Change #:log-port to default to (build-log-port).  Call
  'remote-pipe' with #:error-port LOG-PORT.

1 files changed, 40 insertions, 10 deletions

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 95e35088a1..e078012582 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -159,19 +159,35 @@ determined."
 ;;       (leave (_ "failed to execute '~a': ~a~%")
 ;;              %lsh-command (strerror (system-error-errno args))))))
 
-(define (remote-pipe machine mode command)
+(define-syntax with-error-to-port
+  (syntax-rules ()
+    ((_ port exp0 exp ...)
+     (let ((new port)
+           (old (current-error-port)))
+       (dynamic-wind
+         (lambda ()
+           (set-current-error-port new))
+         (lambda ()
+           exp0 exp ...)
+         (lambda ()
+           (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."
   (catch 'system-error
     (lambda ()
-      (apply open-pipe* mode %lshg-command "-z"
-             "-l" (build-machine-user machine)
-             "-p" (number->string (build-machine-port machine))
+      ;; Let the child inherit ERROR-PORT.
+      (with-error-to-port error-port
+        (apply open-pipe* mode %lshg-command "-z"
+               "-l" (build-machine-user machine)
+               "-p" (number->string (build-machine-port machine))
 
-             ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
-             "-i" (build-machine-private-key machine)
+               ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
+               "-i" (build-machine-private-key machine)
 
-             (build-machine-name machine)
-             command))
+               (build-machine-name machine)
+               command)))
     (lambda args
       (warning (_ "failed to execute '~a': ~a~%")
                %lshg-command (strerror (system-error-errno args)))
@@ -257,9 +273,18 @@ connections allowed to MACHINE."
 ;;; Offloading.
 ;;;
 
+(define (build-log-port)
+  "Return the default port where build logs should be sent.  The default is
+file descriptor 4, which is open by the daemon before running the offload
+hook."
+  (let ((port (fdopen 4 "w0")))
+    ;; Make sure file descriptor 4 isn't closed when PORT is GC'd.
+    (set-port-revealed! port 1)
+    port))
+
 (define* (offload drv machine
                   #:key print-build-trace? (max-silent-time 3600)
-                  build-timeout (log-port (current-output-port)))
+                  build-timeout (log-port (build-log-port)))
   "Perform DRV on MACHINE, assuming DRV and its prerequisites are available
 there, and write the build log to LOG-PORT.  Return the exit status."
   (format (current-error-port) "offloading '~a' to '~a'...~%"
@@ -276,7 +301,11 @@ there, and write the build log to LOG-PORT.  Return the exit status."
                                    (list (format #f "--timeout=~a"
                                                  build-timeout))
                                    '())
-                             ,(derivation-file-name drv)))))
+                             ,(derivation-file-name drv))
+
+                           ;; Since 'guix build' writes the build log to its
+                           ;; stderr, everything will go directly to LOG-PORT.
+                           #:error-port log-port)))
     (let loop ((line (read-line pipe)))
       (unless (eof-object? line)
         (display line log-port)
@@ -597,6 +626,7 @@ This tool is meant to be used internally by 'guix-daemon'.\n"))
 ;;; Local Variables:
 ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
 ;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
+;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
 ;;; End:
 
 ;;; offload.scm ends here