summary refs log tree commit diff
diff options
context:
space:
mode:
-rw-r--r--guix/build/gnu-build-system.scm24
-rw-r--r--guix/build/utils.scm47
-rw-r--r--guix/packages.scm125
-rw-r--r--guix/tests.scm43
-rw-r--r--tests/builders.scm35
-rw-r--r--tests/packages.scm72
6 files changed, 261 insertions, 85 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)
diff --git a/tests/builders.scm b/tests/builders.scm
index fdcf38ded3..624547500a 100644
--- a/tests/builders.scm
+++ b/tests/builders.scm
@@ -17,10 +17,12 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 
-(define-module (test-builders)
+(define-module (tests builders)
   #:use-module (guix download)
   #:use-module (guix build-system)
   #:use-module (guix build-system gnu)
+  #:use-module (guix build gnu-build-system)
+  #:use-module (guix build utils)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix base32)
@@ -32,7 +34,9 @@
                           package-derivation package-native-search-paths))
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 textual-ports)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64))
 
 ;; Test the higher-level builders.
@@ -78,4 +82,33 @@
 (test-assert "gnu-build-system"
   (build-system? gnu-build-system))
 
+(define unpack (assoc-ref %standard-phases 'unpack))
+
+(define compressors '(("gzip"  . "gz")
+                      ("xz"    . "xz")
+                      ("bzip2" . "bz2")
+                      (#f      . #f)))
+
+(for-each
+ (match-lambda
+   ((comp . ext)
+
+    (unless (network-reachable?) (test-skip 1)) ;for bootstrap binaries
+    (test-equal (string-append "gnu-build-system unpack phase, "
+                               "single file (compression: "
+                               (if comp comp "None") ")")
+      "expected text"
+      (let*-values
+          (((name) "test")
+           ((compressed-name) (if ext
+                                  (string-append name "." ext)
+                                  name))
+           ((file hash) (test-file %store compressed-name "expected text")))
+        (call-with-temporary-directory
+         (lambda (dir)
+           (with-directory-excursion dir
+             (unpack #:source file)
+             (call-with-input-file name get-string-all))))))))
+ compressors)
+
 (test-end "builders")
diff --git a/tests/packages.scm b/tests/packages.scm
index a867f2fd6d..b3ccd98e48 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,13 +18,14 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(define-module (test-packages)
+(define-module (tests packages)
   #:use-module (guix tests)
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix grafts)
-  #:use-module ((guix gexp) #:select (local-file local-file-file))
+  #:use-module (guix gexp)
   #:use-module (guix utils)
+  #:use-module ((guix build utils) #:select (tarball?))
   #:use-module ((guix diagnostics)
                 ;; Rename the 'location' binding to allow proper syntax
                 ;; matching when setting the 'location' field of a package.
@@ -32,6 +34,7 @@
                                   (else name))))
   #:use-module ((gcrypt hash) #:prefix gcrypt:)
   #:use-module (guix derivations)
+  #:use-module (guix download)
   #:use-module (guix packages)
   #:use-module (guix grafts)
   #:use-module (guix search-paths)
@@ -50,6 +53,7 @@
   #:use-module (gnu packages version-control)
   #:use-module (gnu packages xml)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -576,6 +580,11 @@
     (build-derivations %store (list drv))
     (call-with-input-file output get-string-all)))
 
+
+;;;
+;;; Source derivation with snippets.
+;;;
+
 (unless (network-reachable?) (test-skip 1))
 (test-equal "package-source-derivation, snippet"
   "OK"
@@ -631,6 +640,63 @@
     (and (build-derivations %store (list (pk 'snippet-drv drv)))
          (call-with-input-file out get-string-all))))
 
+;; Note: lzip is not part of bootstrap-coreutils&co, so is not included to
+;; avoid having to rebuild the world.
+(define compressors '(("gzip"  . "gz")
+                      ("xz"    . "xz")
+                      ("bzip2" . "bz2")
+                      (#f      . #f)))
+
+(for-each
+ (match-lambda
+   ((comp . ext)
+    (unless (network-reachable?) (test-skip 1))
+    (test-equal (string-append "origin->derivation, single file with snippet "
+                               "(compression: " (if comp comp "None") ")")
+      "2 + 2 = 4"
+      (let*-values
+          (((name) "maths")
+           ((compressed-name) (if comp
+                                  (string-append name "." ext)
+                                  name))
+           ((file hash) (test-file %store compressed-name "2 + 2 = 5"))
+           ;; Create an origin using the above computed file and its hash.
+           ((source) (origin
+                       (method url-fetch)
+                       (uri (string-append "file://" file))
+                       (file-name compressed-name)
+                       (patch-inputs `(("tar"   ,%bootstrap-coreutils&co)
+                                       ("xz"    ,%bootstrap-coreutils&co)
+                                       ("bzip2" ,%bootstrap-coreutils&co)
+                                       ("gzip"  ,%bootstrap-coreutils&co)))
+                       (patch-guile %bootstrap-guile)
+                       (modules '((guix build utils)))
+                       (snippet `(substitute* ,name
+                                   (("5") "4")))
+                       (hash (content-hash hash))))
+           ;; Build origin.
+           ((drv) (run-with-store %store (origin->derivation source)))
+           ((out) (derivation->output-path drv)))
+        ;; Decompress the resulting tar.xz and return its content.
+        (and (build-derivations %store (list drv))
+             (if (tarball? out)
+                 (let* ((bin #~(string-append #+%bootstrap-coreutils&co
+                                              "/bin"))
+                        (f (computed-file
+                            name
+                            (with-imported-modules '((guix build utils))
+                              #~(begin
+                                  (use-modules (guix build utils))
+                                  (setenv "PATH" #+bin)
+                                  (invoke "tar" "xvf" #+out)
+                                  (copy-file #+name #$output)))))
+                        (drv (run-with-store %store (lower-object f)))
+                        (_ (build-derivations %store (list drv))))
+                   (call-with-input-file (derivation->output-path drv)
+                     get-string-all))
+                 (call-with-input-file out get-string-all)))))))
+ compressors)
+
 (test-assert "return value"
   (let ((drv (package-derivation %store (dummy-package "p"))))
     (and (derivation? drv)