02/02: offload: Compress only uncompressed files.

[Ludovic Courtès]

civodul pushed a commit to branch wip-offload-compression
in repository guix.

commit e3d2b39d9446a12579a7f4cc3cbd4fb0d1bd8593
Author: Ludovic Courtès <address@hidden>
Date:   Mon Aug 1 15:28:38 2016 +0200

    offload: Compress only uncompressed files.
    
    Suggested by Andreas Enge <address@hidden>.
    
    * guix/utils.scm (compressed-file?): New procedure.
    * guix/scripts/offload.scm (retrieve-files): Use xz compression only
    when (any (negate compressed-file?) files).
    (send-files): Likewise.
---
 guix/scripts/offload.scm |   28 +++++++++++++++++-----------
 guix/utils.scm           |    6 ++++++
 2 files changed, 23 insertions(+), 11 deletions(-)

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 7db0c9d..6c31559 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -480,14 +480,17 @@ success, #f otherwise."
       ;; already quite busy, see hydra.gnu.org), compress with gzip rather
       ;; than xz: For a compression ratio 2 times larger, it is 20 times
       ;; faster.
-      (let* ((files (missing-files (topologically-sorted store files)))
-             (pipe  (remote-pipe machine OPEN_WRITE
-                                 '("gzip" "-dc" "|"
-                                   "guix" "archive" "--import")
-                                 #:quote? #f)))
+      (let* ((files     (missing-files (topologically-sorted store files)))
+             (compress? (any (negate compressed-file?) files))
+             (pipe      (remote-pipe machine OPEN_WRITE
+                                     (if compress?
+                                         '("gzip" "-dc" "|"
+                                           "guix" "archive" "--import")
+                                         '("guix archive" "--import"))
+                                     #:quote? #f)))
         (format #t (_ "sending ~a store files to '~a'...~%")
                 (length files) (build-machine-name machine))
-        (call-with-compressed-output-port 'gzip pipe
+        (call-with-compressed-output-port (and compress? 'gzip) pipe
           (lambda (compressed)
             (catch 'system-error
               (lambda ()
@@ -506,10 +509,13 @@ success, #f otherwise."
   (define host
     (build-machine-name machine))
 
-  (let ((pipe (remote-pipe machine OPEN_READ
-                           `("guix" "archive" "--export" ,@files
-                             "|" "xz" "-c")
-                           #:quote? #f)))
+  (let* ((compress? (any (negate compressed-file?) files))
+         (pipe      (remote-pipe machine OPEN_READ
+                                 (if compress?
+                                     `("guix" "archive" "--export" ,@files
+                                       "|" "xz" "-c")
+                                     `("guix" "archive" "--export" ,@files))
+                                 #:quote? #f)))
     (and pipe
          (with-store store
            (guard (c ((nix-protocol-error? c)
@@ -521,7 +527,7 @@ success, #f otherwise."
 
              ;; We cannot use the 'import-paths' RPC here because we already
              ;; hold the locks for FILES.
-             (call-with-decompressed-port 'xz pipe
+             (call-with-decompressed-port (and compress? 'xz) pipe
                (lambda (decompressed)
                  (restore-file-set decompressed
                                    #:log-port (current-error-port)
diff --git a/guix/utils.scm b/guix/utils.scm
index 4c6b331..465686c 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -79,6 +79,7 @@
             arguments-from-environment-variable
             file-extension
             file-sans-extension
+            compressed-file?
             switch-symlinks
             call-with-temporary-output-file
             call-with-temporary-directory
@@ -551,6 +552,11 @@ minor version numbers from version-string."
         (substring file 0 dot)
         file)))
 
+(define (compressed-file? file)
+  "Return true if FILE denotes a compressed file."
+  (->bool (member (file-extension file)
+                  '("gz" "bz2" "xz" "lz" "tgz" "tbz2" "zip"))))
+
 (define (switch-symlinks link target)
   "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
 both when LINK already exists and when it does not."