@@ -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.
;;;
@@ -615,7 +615,8 @@ specifies modules in scope when evaluating SNIPPET."
((string-suffix? "bz2" source-file-name) "bzip2")
((string-suffix? "lz" source-file-name) "lzip")
((string-suffix? "zip" source-file-name) "unzip")
- (else "xz")))
+ ((string-suffix? "xz" source-file-name) "xz")
+ (else #f))) ;no compression used
(define original-file-name
;; Remove the store prefix plus the slash, hash, and hyphen.
@@ -653,19 +654,29 @@ 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))
+ (decomp -> (and=> decompression-type 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))
+ (define (tarball? file-name)
+ ;; Return true if FILE-NAME has a tar extension.
+ (string-match "\\.tar(\\..*)?$" file-name))
+
;; The --sort option was added to GNU tar in version 1.28, released
;; 2014-07-28. During bootstrap we must cope with older versions.
(define tar-supports-sort?
@@ -702,12 +713,15 @@ 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 #+decomp
+ (string-append ":" #+decomp "/bin")
+ "")))
(setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args)))
- ;; SOURCE may be either a directory or a tarball.
+ ;; SOURCE may be either a directory, a tarball or a simple file.
(if (file-is-directory? #+source)
(let* ((store (%store-directory))
(len (+ 1 (string-length store)))
@@ -716,31 +730,51 @@ specifies modules in scope when evaluating SNIPPET."
(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 "..")
+ ;; File is *not* a directory.
+ (cond
+ ((tarball? #+source)
+ (invoke (string-append #+tar "/bin/tar")
+ "xvf" #+source))
+ ((and=> #+decompression-type (cut string= "unzip" <>))
+ ("unzip" (invoke "unzip" #+source)))
+ (else
+ ;; A simple file, either compressed or not.
+ (match #+decompression-type
+ ;; Note: Referring to the store unzip here (#+unzip)
+ ;; introduces a cycle.
+ ("unzip" (invoke "unzip" #+source))
+ (else
+ ;; bzip2, gzip, lzip and xz share a common CLI.
+ (let ((name (strip-store-file-name #+source))
+ (command (and=> #+decomp
+ (cut string-append <> "/bin/"
+ #+decompression-type))))
+ (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"
@@ -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)
@@ -576,6 +578,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 +638,80 @@
(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* ((name "maths")
+ (compressed-name (if comp
+ (string-append name "." ext)
+ name))
+ (command #~(if #+comp
+ (string-append #+%bootstrap-coreutils&co
+ "/bin/" #+comp)
+ #f))
+ (f (with-imported-modules '((guix build utils))
+ (computed-file compressed-name
+ #~(begin
+ (use-modules (guix build utils)
+ (rnrs io simple))
+ (with-output-to-file #+name
+ (lambda _
+ (format #t "2 + 2 = 5")))
+ (when #+command
+ (invoke #+command #+name))
+ (copy-file #+compressed-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")))
+ ;; 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 file-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)