01/01: publish: Do not compress already-compressed files.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 089b167812624cc69aac95d5a1b69688e3f97117
Author: Ludovic Courtès <address@hidden>
Date:   Mon Aug 1 17:42:09 2016 +0200

    publish: Do not compress already-compressed files.
    
    * guix/scripts/publish.scm (narinfo-string): Force %NO-COMPRESSION when
    STORE-PATH matches 'compressed-file?'.
    * guix/utils.scm (compressed-file?): New procedure.
    * tests/publish.scm ("/*.narinfo for a compressed file"): New test.
---
 guix/scripts/publish.scm |    4 ++++
 guix/utils.scm           |    6 ++++++
 tests/publish.scm        |   14 ++++++++++++++
 3 files changed, 24 insertions(+)

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 2ca2aee..8404e54 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -50,6 +50,7 @@
   #:use-module (guix zlib)
   #:use-module (guix ui)
   #:use-module (guix scripts)
+  #:use-module ((guix utils) #:select (compressed-file?))
   #:use-module ((guix build utils) #:select (dump-port))
   #:export (guix-publish))
 
@@ -199,6 +200,9 @@ compression disabled~%"))
 if STORE-PATH is invalid.  Produce a URL that corresponds to COMPRESSION.  The
 narinfo is signed with KEY."
   (let* ((path-info  (query-path-info store store-path))
+         (compression (if (compressed-file? store-path)
+                          %no-compression
+                          compression))
          (url        (encode-and-join-uri-path
                       `("nar"
                         ,@(match compression
diff --git a/guix/utils.scm b/guix/utils.scm
index 9e1b8ea..c68094c 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."
diff --git a/tests/publish.scm b/tests/publish.scm
index 4dc8075..7499553 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -200,6 +200,20 @@ References: ~%"
                   (_ #f)))
               (recutils->alist body)))))
 
+(unless (zlib-available?)
+  (test-skip 1))
+(test-equal "/*.narinfo for a compressed file"
+  '("none" "nar")          ;compression-less nar
+  ;; Assume 'guix publish -C' is already running on port 6799.
+  (let* ((item (add-text-to-store %store "fake.tar.gz"
+                                  "This is a fake compressed file."))
+         (url  (string-append "http://localhost:6799/";
+                              (store-path-hash-part item) ".narinfo"))
+         (body (http-get-port url))
+         (info (recutils->alist body)))
+    (list (assoc-ref info "Compression")
+          (dirname (assoc-ref info "URL")))))
+
 (test-equal "/nar/ with properly encoded '+' sign"
   "Congrats!"
   (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))