@@ -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)
@@ -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))
;;;
@@ -137,6 +139,32 @@
(module-replace! (current-module) '(setvbuf)))
(else #f))
+
+;;;
+;;; 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.
@@ -1536,17 +1564,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)
@@ -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,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix packages)
+ #:use-module ((guix build utils) #:select (compressor tarball?))
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix store)
@@ -609,14 +610,6 @@ 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
@@ -653,17 +646,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
@@ -702,45 +702,53 @@ 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))
(unless tar-supports-sort?
(call-with-output-file ".file_list"
@@ -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,39 @@ 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* ((name-sans-ext (string-take name (string-index-right 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)
@@ -17,7 +17,7 @@
;;; 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)
@@ -78,4 +78,42 @@
(test-assert "gnu-build-system"
(build-system? gnu-build-system))
+;;; FIXME: The following fails because the store file names of the test-env
+;;; environment are longer than the real ones, so strip-store-file-name
+;;; doesn't work as intended.
+
+;; (use-modules (guix build gnu-build-system)
+;; (guix build utils)
+;; (ice-9 textual-ports)
+;; (srfi srfi-11))
+
+;; (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")
@@ -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,12 +18,12 @@
;;; 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 diagnostics)
;; Rename the 'location' binding to allow proper syntax
@@ -32,6 +33,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 +52,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 +579,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 +639,61 @@
(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))
+ (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)))))))
+ compressors)
+
(test-assert "return value"
(let ((drv (package-derivation %store (dummy-package "p"))))
(and (derivation? drv)