1 files changed, 97 insertions, 0 deletions
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