From c96863bc7cc019661dc3235bbb3fbdb870b3d474 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 23 Oct 2019 14:22:36 +0200
Subject: base: Write to 'evaluate' output to /var/log/cuirass.

This fixes a longstanding issue where evalution output would splatter
over the /var/log/cuirass.log and be inscrutable.

* src/cuirass/base.scm (%cuirass-state-directory): New variable.
(evaluation-log-file): New procedure.
(evaluate)[log-file, log-pipe]: New variables.
Call 'spawn-fiber' with a logging fiber.  Wrap 'open-pipe*' call into
'with-error-to-port'.  Close 'log-pipe'.
---
 build-aux/pre-inst-env.in |  3 +++
 src/cuirass/base.scm      | 49 ++++++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 49 insertions(+), 3 deletions(-)

diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in
index e8d9487..e876661 100644
--- a/build-aux/pre-inst-env.in
+++ b/build-aux/pre-inst-env.in
@@ -27,6 +27,9 @@ export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
 CUIRASS_DATADIR="$abs_top_srcdir/src"
 export CUIRASS_DATADIR
 
+CUIRASS_STATE_DIRECTORY="${TMPDIR:-/tmp}/cuirass-tests/var"
+export CUIRASS_STATE_DIRECTORY
+
 PATH="$abs_top_builddir/bin:$PATH"
 export PATH
 
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 2c568c9..00b1daa 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -25,12 +25,14 @@
   #:use-module (cuirass logging)
   #:use-module (cuirass database)
   #:use-module (cuirass utils)
+  #:use-module ((cuirass config) #:select (%localstatedir))
   #:use-module (gnu packages)
   #:use-module (guix build utils)
   #:use-module (guix derivations)
   #:use-module (guix store)
   #:use-module (guix git)
   #:use-module (guix cache)
+  #:use-module (guix zlib)
   #:use-module ((guix config) #:select (%state-directory))
   #:use-module (git)
   #:use-module (ice-9 binary-ports)
@@ -286,6 +288,17 @@ fibers."
                    (logior (@ (fibers epoll) EPOLLERR)
                            (@ (fibers epoll) EPOLLHUP)))))
 
+(define %cuirass-state-directory
+  ;; Directory where state files are stored, usually "/var".
+  (make-parameter (or (getenv "CUIRASS_STATE_DIRECTORY")
+                      %localstatedir)))
+
+(define (evaluation-log-file eval-id)
+  "Return the name of the file containing the output of evaluation EVAL-ID."
+  (string-append (%cuirass-state-directory)
+                 "/log/cuirass/evaluations/"
+                 (number->string eval-id) ".gz"))
+
 (define (evaluate store spec eval-id checkouts)
   "Evaluate and build package derivations defined in SPEC, using CHECKOUTS.
 Return a list of jobs that are associated to EVAL-ID."
@@ -297,20 +310,50 @@ Return a list of jobs that are associated to EVAL-ID."
         (#:system . ,(derivation-system drv))
         ,@job)))
 
+  (define log-file
+    (evaluation-log-file eval-id))
+
+  (define log-pipe
+    (pipe))
+
+  (mkdir-p (dirname log-file))
+
+  ;; Spawn a fiber that reads standard error from 'evaluate' and writes it to
+  ;; LOG-FILE.
+  (spawn-fiber
+   (lambda ()
+     (define input
+       (non-blocking-port (car log-pipe)))
+
+     (define output
+       ;; Note: Don't use 'call-with-gzip-output-port' as it doesn't play well
+       ;; with fibers (namely, its dynamic-wind handler would close the output
+       ;; port as soon as a context switch occurs.)
+       (make-gzip-output-port (open-output-file log-file)
+                              #:level 8 #:buffer-size 16384))
+
+     (dump-port input output)
+     (close-port input)
+     (close-port output)))
+
   (let* ((port (non-blocking-port
-                (open-pipe* OPEN_READ "evaluate"
-                            (object->string spec)
-                            (object->string checkouts))))
+                (with-error-to-port (cdr log-pipe)
+                  (lambda ()
+                    (open-pipe* OPEN_READ "evaluate"
+                                (object->string spec)
+                                (object->string checkouts))))))
          (result (match (read/non-blocking port)
                    ;; If an error occured during evaluation report it,
                    ;; otherwise, suppose that data read from port are
                    ;; correct and keep things going.
                    ((? eof-object?)
                     (db-set-evaluation-done eval-id) ;failed!
+                    (close-port (cdr log-pipe))
                     (raise (condition
                             (&evaluation-error
                              (name (assq-ref spec #:name))))))
                    (data data))))
+    (close-port (cdr log-pipe))
     (close-pipe port)
     (match result
       (('evaluation jobs)
-- 
cgit v1.2.3