build-systems/gnu: Allow unpacking/repacking more kind of files.

Before this change, only plain directories, tar or zip archives were supported
as the source of a package for the GNU build system; anything else would cause
the unpack phase to fail.  Origins relying on snippets would suffer from the
same problem.

This change adds the support to use files of the following extensions: .gz,
.Z, .bz2, .lz, and .xz, even when they are not tarballs.  Files of unknown
extensions are treated as uncompressed files and supported as well.

* guix/packages.scm (patch-and-repack): Only add the compressor utility to the
PATH when the file is compressed.  Bind more inputs in the mlet, and use them
for decompressing single files.  Adjust the decompression and compression
routines.
[decompression-type]: Remove nested variable.
* guix/build/utils.scm (compressor, tarball?): New procedures.  Move
%xz-parallel-args to the new 'compression helpers' section.
* tests/packages.scm: Add tests.  Add missing copyright year for Jan.
* guix/build/gnu-build-system.scm (first-subdirectory): Return #f when no
sub-directory was found.
(unpack): Support more file types, including uncompressed plain files.

4 files changed, 158 insertions, 81 deletions

diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index f8e8a46854..66edd2de2d 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -60,13 +61,15 @@ See https://reproducible-builds.org/specs/source-date-epoch/."
   (setenv "SOURCE_DATE_EPOCH" "1"))
 
 (define (first-subdirectory directory)
-  "Return the file name of the first sub-directory of DIRECTORY."
+  "Return the file name of the first sub-directory of DIRECTORY or false, when
+there are none."
   (match (scandir directory
                   (lambda (file)
                     (and (not (member file '("." "..")))
                          (file-is-directory? (string-append directory "/"
                                                             file)))))
-    ((first . _) first)))
+    ((first . _) first)
+    (_ #f)))
 
 (define* (set-paths #:key target inputs native-inputs
                     (search-paths '()) (native-search-paths '())
@@ -155,10 +158,19 @@ working directory."
         (copy-recursively source "."
                           #:keep-mtime? #t))
       (begin
-        (if (string-suffix? ".zip" source)
-            (invoke "unzip" source)
-            (invoke "tar" "xvf" source))
-        (chdir (first-subdirectory ".")))))
+        (cond
+         ((string-suffix? ".zip" source)
+          (invoke "unzip" source))
+         ((tarball? source)
+          (invoke "tar" "xvf" source))
+         (else
+          (let ((name (strip-store-file-name source))
+                (command (compressor source)))
+            (copy-file source name)
+            (when command
+              (invoke command "--decompress" name)))))
+        ;; Attempt to change into child directory.
+        (and=> (first-subdirectory ".") chdir))))
 
 (define* (bootstrap #:key bootstrap-scripts
                     #:allow-other-keys)
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 6c40d70e21..6c37021673 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -6,7 +6,7 @@
 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
-;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -51,6 +51,10 @@
             package-name->name+version
             parallel-job-count
 
+            compressor
+            tarball?
+            %xz-parallel-args
+
             directory-exists?
             executable-file?
             symbolic-link?
@@ -113,9 +117,7 @@
 
             make-desktop-entry-file
 
-            locale-category->string
-
-            %xz-parallel-args))
+            locale-category->string))
 
 
 ;;;
@@ -139,6 +141,32 @@
 
 
 ;;;
+;;; Compression helpers.
+;;;
+
+(define (compressor file-name)
+  "Return the name of the compressor package/binary used to compress or
+decompress FILE-NAME, based on its file extension, else false."
+  (cond ((string-suffix? "gz"  file-name)  "gzip")
+        ((string-suffix? "Z"   file-name)  "gzip")
+        ((string-suffix? "bz2" file-name)  "bzip2")
+        ((string-suffix? "lz"  file-name)  "lzip")
+        ((string-suffix? "zip" file-name)  "unzip")
+        ((string-suffix? "xz"  file-name)  "xz")
+        (else #f)))                ;no compression used/unknown file extension
+
+(define (tarball? file-name)
+  "True when FILE-NAME has a tar file extension."
+  (string-match "\\.(tar(\\..*)?|tgz|tbz)$" file-name))
+
+(define (%xz-parallel-args)
+  "The xz arguments required to enable bit-reproducible, multi-threaded
+compression."
+  (list "--memlimit=50%"
+        (format #f "--threads=~a" (max 2 (parallel-job-count)))))
+
+
+;;;
 ;;; Directories.
 ;;;
 
@@ -1537,17 +1565,6 @@ returned."
              LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE
              LC_TIME)))
 
-
-;;;
-;;; Others.
-;;;
-
-(define (%xz-parallel-args)
-  "The xz arguments required to enable bit-reproducible, multi-threaded
-compression."
-  (list "--memlimit=50%"
-        (format #f "--threads=~a" (max 2 (parallel-job-count)))))
-
 ;;; Local Variables:
 ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
 ;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1)
diff --git a/guix/packages.scm b/guix/packages.scm
index cd2cded9ee..67ef6ea146 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -5,7 +5,7 @@
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
-;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +23,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix packages)
+  #:use-module ((guix build utils) #:select (compressor tarball?
+                                                        strip-store-file-name))
   #:use-module (guix utils)
   #:use-module (guix records)
   #:use-module (guix store)
@@ -609,20 +611,7 @@ specifies modules in scope when evaluating SNIPPET."
           ((package) package)
           (#f        #f)))))
 
-  (define decompression-type
-    (cond ((string-suffix? "gz" source-file-name)  "gzip")
-          ((string-suffix? "Z" source-file-name)  "gzip")
-          ((string-suffix? "bz2" source-file-name) "bzip2")
-          ((string-suffix? "lz" source-file-name)  "lzip")
-          ((string-suffix? "zip" source-file-name) "unzip")
-          (else "xz")))
-
-  (define original-file-name
-    ;; Remove the store prefix plus the slash, hash, and hyphen.
-    (let* ((sans (string-drop source-file-name
-                              (+ (string-length (%store-prefix)) 1)))
-           (dash (string-index sans #\-)))
-      (string-drop sans (+ 1 dash))))
+  (define original-file-name (strip-store-file-name source-file-name))
 
   (define (numeric-extension? file-name)
     ;; Return true if FILE-NAME ends with digits.
@@ -651,17 +640,24 @@ specifies modules in scope when evaluating SNIPPET."
        (lower-object patch system))))
 
   (mlet %store-monad ((tar ->     (lookup-input "tar"))
+                      (gzip ->    (lookup-input "gzip"))
+                      (bzip2 ->   (lookup-input "bzip2"))
+                      (lzip ->    (lookup-input "lzip"))
                       (xz ->      (lookup-input "xz"))
                       (patch ->   (lookup-input "patch"))
                       (locales -> (lookup-input "locales"))
-                      (decomp ->  (lookup-input decompression-type))
+                      (comp ->    (and=> (compressor source-file-name)
+                                         lookup-input))
                       (patches    (sequence %store-monad
                                             (map instantiate-patch patches))))
     (define build
       (with-imported-modules '((guix build utils))
         #~(begin
             (use-modules (ice-9 ftw)
+                         (ice-9 match)
+                         (ice-9 regex)
                          (srfi srfi-1)
+                         (srfi srfi-26)
                          (guix build utils))
 
             ;; The --sort option was added to GNU tar in version 1.28, released
@@ -723,54 +719,67 @@ specifies modules in scope when evaluating SNIPPET."
                                              (package-version locales)))))
               (setlocale LC_ALL "en_US.utf8"))
 
-            (setenv "PATH" (string-append #+xz "/bin" ":"
-                                          #+decomp "/bin"))
+            (setenv "PATH"
+                    (string-append #+xz "/bin"
+                                   (if #+comp
+                                       (string-append ":" #+comp "/bin")
+                                       "")))
 
             (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args)))
 
-            ;; SOURCE may be either a directory or a tarball.
-            (if (file-is-directory? #+source)
-                (let* ((store     (%store-directory))
-                       (len       (+ 1 (string-length store)))
-                       (base      (string-drop #+source len))
-                       (dash      (string-index base #\-))
-                       (directory (string-drop base (+ 1 dash))))
-                  (mkdir directory)
-                  (copy-recursively #+source directory))
-                #+(if (string=? decompression-type "unzip")
-                      #~(invoke "unzip" #+source)
-                      #~(invoke (string-append #+tar "/bin/tar")
-                                "xvf" #+source)))
-
-            (let ((directory (first-file ".")))
-              (format (current-error-port)
-                      "source is under '~a'~%" directory)
-              (chdir directory)
-
-              (for-each apply-patch '#+patches)
-
-              #+(if snippet
-                    #~(let ((module (make-fresh-user-module)))
-                        (module-use-interfaces!
-                         module
-                         (map resolve-interface '#+modules))
-                        ((@ (system base compile) compile)
-                         '#+snippet
-                         #:to 'value
-                         #:opts %auto-compilation-options
-                         #:env module))
-                    #~#t)
-
-              (chdir "..")
+            ;; SOURCE may be either a directory, a tarball or a simple file.
+            (let ((name (strip-store-file-name #+source))
+                  (command (and=> #+comp (cut string-append <> "/bin/"
+                                              (compressor #+source)))))
+              (if (file-is-directory? #+source)
+                  (copy-recursively #+source name)
+                  (cond
+                   ((tarball? #+source)
+                    (invoke (string-append #+tar "/bin/tar") "xvf" #+source))
+                   ((and=> (compressor #+source) (cut string= "unzip" <>))
+                    ;; Note: Referring to the store unzip here (#+unzip)
+                    ;; would introduce a cycle.
+                    ("unzip" (invoke "unzip" #+source)))
+                   (else
+                    (copy-file #+source name)
+                    (when command
+                      (invoke command "--decompress" name))))))
+
+            (let* ((file (first-file "."))
+                   (directory (if (file-is-directory? file)
+                                  file
+                                  ".")))
+              (format (current-error-port) "source is at '~a'~%" file)
+
+              (with-directory-excursion directory
+
+                (for-each apply-patch '#+patches)
+
+                #+(if snippet
+                      #~(let ((module (make-fresh-user-module)))
+                          (module-use-interfaces!
+                           module
+                           (map resolve-interface '#+modules))
+                          ((@ (system base compile) compile)
+                           '#+snippet
+                           #:to 'value
+                           #:opts %auto-compilation-options
+                           #:env module))
+                      #~#t))
 
               ;; If SOURCE is a directory (such as a checkout), return a
               ;; directory.  Otherwise create a tarball.
-              (if (file-is-directory? #+source)
-                  (copy-recursively directory #$output
-                                    #:log (%make-void-port "w"))
-                  (repack directory #$output))))))
-
-    (let ((name (if (checkout? original-file-name)
+              (cond
+               ((file-is-directory? #+source)
+                (copy-recursively directory #$output
+                                  #:log (%make-void-port "w")))
+               ((not #+comp)
+                (copy-file file #$output))
+               (else
+                (repack directory #$output)))))))
+
+    (let ((name (if (or (checkout? original-file-name)
+                        (not (compressor original-file-name)))
                     original-file-name
                     (tarxz-name original-file-name))))
       (gexp->derivation name build
diff --git a/guix/tests.scm b/guix/tests.scm
index fc3d521163..da75835099 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -20,12 +20,13 @@
   #:use-module ((guix config) #:select (%storedir %localstatedir))
   #:use-module (guix store)
   #:use-module (guix derivations)
+  #:use-module (guix gexp)
   #:use-module (guix packages)
   #:use-module (guix base32)
   #:use-module (guix serialization)
   #:use-module (guix monads)
   #:use-module ((guix utils) #:select (substitute-keyword-arguments))
-  #:use-module ((guix build utils) #:select (mkdir-p))
+  #:use-module ((guix build utils) #:select (mkdir-p compressor))
   #:use-module ((gcrypt hash) #:hide (sha256))
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages base)
@@ -60,7 +61,9 @@
             dummy-package
             dummy-origin
 
-            gnu-make-for-tests))
+            gnu-make-for-tests
+
+            test-file))
 
 ;;; Commentary:
 ;;;
@@ -435,6 +438,42 @@ default values, and with EXTRA-FIELDS set as specified."
      (native-inputs '())                          ;no need for 'pkg-config'
      (inputs %bootstrap-inputs-for-tests))))
 
+
+;;;
+;;; Test utility procedures.
+
+(define (test-file store name content)
+  "Create a simple file in STORE with CONTENT (a string), compressed according
+to its file name extension.  Return both its file name and its hash."
+  (let* ((ext (string-index-right name #\.))
+         (name-sans-ext (if ext
+                            (string-take name (string-index-right name #\.))
+                            name))
+         (comp (compressor name))
+         (command #~(if #+comp
+                        (string-append #+%bootstrap-coreutils&co
+                                       "/bin/" #+comp)
+                        #f))
+         (f (with-imported-modules '((guix build utils))
+              (computed-file name
+                             #~(begin
+                                 (use-modules (guix build utils)
+                                              (rnrs io simple))
+                                 (with-output-to-file #+name-sans-ext
+                                   (lambda _
+                                     (format #t #+content)))
+                                 (when #+command
+                                   (invoke #+command #+name-sans-ext))
+                                 (copy-file #+name #$output)))))
+         (file-drv (run-with-store store (lower-object f)))
+         (file (derivation->output-path file-drv))
+         (file-drv-outputs (derivation-outputs file-drv))
+         (_ (build-derivations store (list file-drv)))
+         (file-hash (derivation-output-hash
+                     (assoc-ref file-drv-outputs "out"))))
+    (values file file-hash)))
+
+;;;
 ;; Local Variables:
 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
 ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)