From a6a93d2d0a49332b08c53480f3f6e5d0bbb846c0 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 25 Apr 2020 16:42:48 +0100
Subject: Support sending and storing log files for builds

---
 guix-build-coordinator/agent-messaging/http.scm | 50 +++++++++++++++++++++++++
 guix-build-coordinator/agent.scm                |  6 +++
 guix-build-coordinator/config.scm.in            |  7 ++++
 guix-build-coordinator/coordinator.scm          | 10 +++++
 4 files changed, 73 insertions(+)

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 669981f..8fba5c2 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -44,6 +44,7 @@
   #:export (http-agent-messaging-start-server
 
             submit-status
+            submit-log-file
             submit-build-result
             report-setup-failure
             submit-output
@@ -214,6 +215,25 @@ port. Also, the port used can be changed by passing the --port option.\n"
              (render-json
               "access denied"
               #:code 403))))
+      (('PUT "build" uuid "log" format)
+       (let ((agent-id-for-build
+              (datastore-agent-for-build datastore uuid)))
+         (if (authenticated? agent-id-for-build request)
+             (let ((output-file-name
+                    (build-log-file-location datastore uuid format)))
+               (mkdir-p (dirname output-file-name))
+               (call-with-output-file output-file-name
+                 (lambda (output-port)
+                   (let loop ((line (get-line body)))
+                     (unless (eof-object? line)
+                       (base64-decode line
+                                      base64-alphabet
+                                      output-port)
+                       (loop (get-line body))))))
+               (no-content))
+             (render-json
+              "access denied"
+              #:code 403))))
       (('PUT "build" uuid "output" output-name)
        (let ((agent-id-for-build
               (datastore-agent-for-build datastore uuid)))
@@ -309,6 +329,36 @@ port. Also, the port used can be changed by passing the --port option.\n"
        #:level 9))
    #:headers `((Authorization . ,auth-value))))
 
+(define (submit-log-file coordinator-uri agent-uuid password
+                         build-id file)
+  (define auth-value
+    (string-append
+     "Basic "
+     (base64-encode
+      (string->utf8
+       (string-append agent-uuid ":" password)))))
+
+  (define format
+    (cond
+     ((string-suffix? ".bz2" file) "bzip2")
+     ((string-suffix? ".gz" file)  "gzip")
+     (else
+      (error "unsupported log format for" file))))
+
+  (define uri
+    (coordinator-uri-for-path
+     coordinator-uri
+     (string-append "/build/" build-id "/log/" format)))
+
+  (call-with-streaming-http-request
+   uri
+   (lambda (request-port)
+     (call-with-input-file file
+       (lambda (file-port)
+         (dump-port file-port request-port))
+       #:binary #t))
+   #:headers `((Authorization . ,auth-value))))
+
 (define (submit-build-result coordinator-uri agent-uuid password
                              build-id result)
   (define auth-value
diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index ac89db6..780f7d5 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -47,6 +47,12 @@
                     (let ((pre-build-status (pre-build-process derivation-name)))
                       (if (eq? (assq-ref pre-build-status 'result) 'success)
                           (let ((result (perform-build derivation-name)))
+                            (and=> (derivation-log-file derivation-name)
+                                   (lambda (log-file)
+                                     (submit-log-file
+                                      coordinator-uri uuid password
+                                      (assoc-ref build "uuid")
+                                      log-file)))
                             ((if result
                                  post-build-success
                                  post-build-failure)
diff --git a/guix-build-coordinator/config.scm.in b/guix-build-coordinator/config.scm.in
index 69cc98e..de65835 100644
--- a/guix-build-coordinator/config.scm.in
+++ b/guix-build-coordinator/config.scm.in
@@ -33,6 +33,13 @@
                                (if (file-exists? install-dir)
                                    install-dir
                                    dev-dir)))
+           (build-logs-dir . ,(let ((install-dir
+                                     "/var/lib/guix-build-coordinator/build-logs")
+                                    (dev-dir
+                                     (string-append (getcwd) "/data/build-logs")))
+                                (if (file-exists? install-dir)
+                                    install-dir
+                                    dev-dir)))
 
            (sqitch        . "@sqitch@")
            (sqitch-psql   . "@psql@")
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 6bbae04..f641ca8 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -38,6 +38,7 @@
             make-hook-channel
 
             build-output-file-location
+            build-log-file-location
             handle-build-result
             handle-setup-failure-report))
 
@@ -201,6 +202,15 @@
                    (basename output)
                    ".nar.lz")))
 
+(define (build-log-file-location datastore build-id format)
+  (string-append (%config 'build-logs-dir) "/"
+                 build-id "/"
+                 (cond
+                  ((string=? format "bzip2") "log.bz2")
+                  ((string=? format "gzip")  "log.gz")
+                  (else
+                   (error "unknown log format" format)))))
+
 (define (handle-build-result datastore hook-channel
                              agent-id build-id result-json)
   (let* ((result (assoc-ref result-json "result"))
-- 
cgit v1.2.3