From aa9c9b3ef0d779290359a4add681c8e6bb4db6f2 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 11 Oct 2020 13:58:28 +0100
Subject: Add a hook to recomress build log files

---
 configure.ac                         |  1 +
 guix-build-coordinator/config.scm.in |  1 +
 guix-build-coordinator/hooks.scm     | 97 ++++++++++++++++++++++++++++++++++++
 guix-dev.scm                         |  1 +
 4 files changed, 100 insertions(+)

diff --git a/configure.ac b/configure.ac
index 9995c38..73c6ffb 100644
--- a/configure.ac
+++ b/configure.ac
@@ -18,6 +18,7 @@ AC_PATH_PROG([guix], [guix])
 AC_PATH_PROG([sqitch], [sqitch])
 AC_PATH_PROG([sqlite3], [sqlite3])
 AC_PATH_PROG([psql], [psql])
+AC_PATH_PROG([bzip2], [bzip2])
 
 
 AC_CONFIG_FILES([Makefile])
diff --git a/guix-build-coordinator/config.scm.in b/guix-build-coordinator/config.scm.in
index 2aa825f..fa2fa8a 100644
--- a/guix-build-coordinator/config.scm.in
+++ b/guix-build-coordinator/config.scm.in
@@ -39,6 +39,7 @@
             (sqitch        . "@sqitch@")
             (sqitch-psql   . "@psql@")
             (sqitch-sqlite . "@sqlite3@")
+            (bzip2         . "@bzip2@")
             (sqitch-plan
              . ,(let ((installed-plan
                        "@prefix@/share/guix-build-coordinator/sqitch/sqitch.plan")
diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
index c99f291..f4c95f6 100644
--- a/guix-build-coordinator/hooks.scm
+++ b/guix-build-coordinator/hooks.scm
@@ -21,7 +21,10 @@
 (define-module (guix-build-coordinator hooks)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 exceptions)
   #:use-module (gcrypt pk-crypto)
+  #:use-module (zlib)
   #:use-module (guix pki)
   #:use-module (guix config)
   #:use-module (guix build utils)
@@ -37,6 +40,7 @@
             build-success-s3-publish-hook
             default-build-failure-hook
             build-failure-retry-hook
+            build-recompress-log-file-hook
             default-build-missing-inputs-hook
 
             %default-hooks
@@ -223,6 +227,99 @@
                              (assq-ref details 'build-submitted)))))
          (iota retries))))))
 
+(define* (build-recompress-log-file-hook #:key
+                                         recompress-to
+                                         (timeout 60))
+  (define* (call-with-compressed-input-file
+            name
+            compression
+            proc)
+    (cond
+     ((eq? compression 'gzip)
+      (call-with-input-file name
+        (lambda (compressed-input-port)
+          (call-with-gzip-input-port
+              compressed-input-port
+            proc))))
+     ((eq? compression 'bzip2)
+      (let ((pipe (open-pipe* OPEN_READ
+                              (%config 'bzip2)
+                              "-dc"
+                              name)))
+        (dynamic-wind
+          (const #f)
+          (lambda ()
+            (proc pipe))
+          (lambda ()
+            (close-pipe pipe)))))
+     (else
+      (error
+       (simple-format #f "unsupported compression ~A"
+                      compression)))))
+
+  (define* (call-with-compressed-output-file
+            name
+            compression
+            proc
+            #:key (compression-level 9))
+    (cond
+     ((eq? compression 'gzip)
+      (call-with-output-file name
+        (lambda (uncompressed-output-port)
+          (call-with-gzip-output-port
+              uncompressed-output-port
+            proc))))
+     ((eq? compression 'bzip2)
+      (let ((pipe (open-pipe OPEN_WRITE
+                             (simple-format
+                              #f
+                              "~A --compress -~A > ~A"
+                              (%config 'bzip2)
+                              compression-level
+                              name))))
+        (dynamic-wind
+          (const #f)
+          (lambda ()
+            (proc pipe))
+          (lambda ()
+            (close-pipe pipe)))))
+     (else
+      (error
+       (simple-format #f "unsupported compression ~A"
+                      compression)))))
+
+  (lambda (build-coordinator build-id)
+    (let* ((source-log-file
+            (build-log-file-location build-id))
+           (source-compression
+            (cond
+             ((string-suffix? ".gz" source-log-file)  'gzip)
+             ((string-suffix? ".bz2" source-log-file) 'bzip2)
+             (else (error "unknown source compression"))))
+           (output-log-file
+            (build-log-file-destination build-id
+                                        (symbol->string recompress-to)))
+           (tmp-output-log-file
+            (string-append output-log-file ".tmp")))
+      (unless (eq? source-compression recompress-to)
+        (when (file-exists? tmp-output-log-file)
+          (delete-file tmp-output-log-file))
+        (with-timeout timeout
+          (raise-exception
+           (make-exception-with-message "timeout recompressing log file"))
+          (call-with-compressed-input-file
+           source-log-file
+           source-compression
+           (lambda (input-port)
+             (call-with-compressed-output-file
+              tmp-output-log-file
+              recompress-to
+              (lambda (output-port)
+                (dump-port input-port output-port))))))
+        (rename-file tmp-output-log-file
+                     output-log-file)
+        (delete-file source-log-file)))))
+
 (define (default-build-missing-inputs-hook build-coordinator
                                            build-id missing-inputs)
   (define datastore
diff --git a/guix-dev.scm b/guix-dev.scm
index f00eab9..b230bb6 100644
--- a/guix-dev.scm
+++ b/guix-dev.scm
@@ -93,6 +93,7 @@
      ("guile-fibers" ,guile3.0-fibers)
      ("guile-gcrypt" ,guile3.0-gcrypt)
      ("guile-readline" ,guile-readline)
+     ("guile-zlib" ,guile-zlib)
      ("guile-lzlib" ,guile-lzlib)
      ("guile-prometheus" ,guile-prometheus)
      ("guile" ,my-guile)
-- 
cgit v1.2.3