;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:renamer (lambda (name)
(cond ((eq? name 'location) 'make-location)
(else name))))
- #:use-module (guix hash)
+ #:use-module (gcrypt hash)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix grafts)
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module (gnu packages bootstrap)
+ #:use-module (gnu packages version-control)
#:use-module (gnu packages xml)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-64)
#:use-module (rnrs io ports)
+ #:use-module (ice-9 vlist)
#:use-module (ice-9 regex)
#:use-module (ice-9 match))
(and (hidden-package? (hidden-package (dummy-package "foo")))
(not (hidden-package? (dummy-package "foo")))))
+(test-assert "package-superseded"
+ (let* ((new (dummy-package "bar"))
+ (old (deprecated-package "foo" new)))
+ (and (eq? (package-superseded old) new)
+ (mock ((gnu packages) find-best-packages-by-name (const (list old)))
+ (specification->package "foo")
+ (and (eq? new (specification->package "foo"))
+ (eq? new (specification->package+output "foo")))))))
+
+(test-assert "transaction-upgrade-entry, zero upgrades"
+ (let* ((old (dummy-package "foo" (version "1")))
+ (tx (mock ((gnu packages) find-newest-available-packages
+ (const vlist-null))
+ ((@@ (guix scripts package) transaction-upgrade-entry)
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (item (string-append (%store-prefix) "/"
+ (make-string 32 #\e) "-foo-1")))
+ (manifest-transaction)))))
+ (manifest-transaction-null? tx)))
+
+(test-assert "transaction-upgrade-entry, one upgrade"
+ (let* ((old (dummy-package "foo" (version "1")))
+ (new (dummy-package "foo" (version "2")))
+ (tx (mock ((gnu packages) find-newest-available-packages
+ (const (vhash-cons "foo" (list "2" new) vlist-null)))
+ ((@@ (guix scripts package) transaction-upgrade-entry)
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (item (string-append (%store-prefix) "/"
+ (make-string 32 #\e) "-foo-1")))
+ (manifest-transaction)))))
+ (and (match (manifest-transaction-install tx)
+ ((($ <manifest-entry> "foo" "2" "out" item))
+ (eq? item new)))
+ (null? (manifest-transaction-remove tx)))))
+
+(test-assert "transaction-upgrade-entry, superseded package"
+ (let* ((old (dummy-package "foo" (version "1")))
+ (new (dummy-package "bar" (version "2")))
+ (dep (deprecated-package "foo" new))
+ (tx (mock ((gnu packages) find-newest-available-packages
+ (const (vhash-cons "foo" (list "2" dep) vlist-null)))
+ ((@@ (guix scripts package) transaction-upgrade-entry)
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (item (string-append (%store-prefix) "/"
+ (make-string 32 #\e) "-foo-1")))
+ (manifest-transaction)))))
+ (and (match (manifest-transaction-install tx)
+ ((($ <manifest-entry> "bar" "2" "out" item))
+ (eq? item new)))
+ (match (manifest-transaction-remove tx)
+ (((? manifest-pattern? pattern))
+ (and (string=? (manifest-pattern-name pattern) "foo")
+ (string=? (manifest-pattern-version pattern) "1")
+ (string=? (manifest-pattern-output pattern) "out")))))))
+
(test-assert "package-field-location"
(let ()
(define (goto port line column)
(unless (network-reachable?) (test-skip 1))
(test-equal "package-source-derivation, snippet"
"OK"
- (let* ((file (search-bootstrap-binary (match (%current-system)
- ("armhf-linux"
- "guile-2.0.11.tar.xz")
- (_
- "guile-2.0.9.tar.xz"))
- (%current-system)))
- (sha256 (call-with-input-file file port-sha256))
- (fetch (lambda* (url hash-algo hash
- #:optional name #:key system)
- (pk 'fetch url hash-algo hash name system)
- (interned-file url)))
- (source (bootstrap-origin
+ (let* ((source (bootstrap-origin
(origin
- (method fetch)
- (uri file)
- (sha256 sha256)
+ (inherit (bootstrap-guile-origin (%current-system)))
(patch-inputs
`(("tar" ,%bootstrap-coreutils&co)
("xz" ,%bootstrap-coreutils&co)
(%current-system)))))
(arguments
`(#:guile ,%bootstrap-guile
+ #:modules ((guix build utils))
#:builder
- (let ((tar (assoc-ref %build-inputs "tar"))
- (xz (assoc-ref %build-inputs "xz"))
- (source (assoc-ref %build-inputs "source")))
- (and (zero? (system* tar "xvf" source
- "--use-compress-program" xz))
- (string=? "guile" (readlink "bin/guile-rocks"))
- (file-exists? "bin/scripts/compile.scm")
- (let ((out (assoc-ref %outputs "out")))
- (call-with-output-file out
- (lambda (p)
- (display "OK" p))))))))))
+ (begin
+ (use-modules (guix build utils))
+ (let ((tar (assoc-ref %build-inputs "tar"))
+ (xz (assoc-ref %build-inputs "xz"))
+ (source (assoc-ref %build-inputs "source")))
+ (invoke tar "xvf" source
+ "--use-compress-program" xz)
+ (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
+ (file-exists? "bin/scripts/compile.scm"))
+ (error "the snippet apparently failed"))
+ (let ((out (assoc-ref %outputs "out")))
+ (call-with-output-file out
+ (lambda (p)
+ (display "OK" p))))
+ #t))))))
(drv (package-derivation %store package))
(out (derivation->output-path drv)))
(and (build-derivations %store (list (pk 'snippet-drv drv)))
(package-derivation %store p)
#f)))
+(let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
+ (test-equal "&package-input-error"
+ (list dummy (current-module))
+ (guard (c ((package-input-error? c)
+ (list (package-error-package c)
+ (package-error-invalid-input c))))
+ (package-derivation %store dummy))))
+
(test-assert "reference to non-existent output"
;; See <http://bugs.gnu.org/19630>.
(parameterize ((%graft? #f))
(mkdir %output)
(call-with-output-file (string-append %output "/test")
(lambda (p)
- (display '(hello guix) p))))))))
+ (display '(hello guix) p)))
+ #t)))))
(d (package-derivation %store p)))
(and (build-derivations %store (list d))
(let ((p (pk 'drv d (derivation->output-path d))))
(source #f)
(arguments
`(#:guile ,%bootstrap-guile
- #:builder (copy-file (assoc-ref %build-inputs "input")
- %output)))
+ #:builder (begin
+ (copy-file (assoc-ref %build-inputs "input")
+ %output)
+ #t)))
(inputs `(("input" ,i)))))
(d (package-derivation %store p)))
(and (build-derivations %store (list d))
(source i)
(arguments
`(#:guile ,%bootstrap-guile
- #:builder (copy-file (assoc-ref %build-inputs "source")
- %output)))))
+ #:builder (begin
+ (copy-file (assoc-ref %build-inputs "source")
+ %output)
+ #t)))))
(d (package-derivation %store p)))
(and (build-derivations %store (list d))
(let ((p (derivation->output-path d)))
(source #f)
(arguments
`(#:guile ,%bootstrap-guile
+ #:modules ((guix build utils))
#:builder
- (let ((out (assoc-ref %outputs "out"))
- (bash (assoc-ref %build-inputs "bash")))
- (zero? (system* bash "-c"
- (format #f "echo hello > ~a" out))))))
+ (begin
+ (use-modules (guix build utils))
+ (let ((out (assoc-ref %outputs "out"))
+ (bash (assoc-ref %build-inputs "bash")))
+ (invoke bash "-c"
+ (format #f "echo hello > ~a" out))))))
(inputs `(("bash" ,(search-bootstrap-binary "bash"
(%current-system)))))))
(d (package-derivation %store p)))
(let ((p (pk 'drv d (derivation->output-path d))))
(eq? 'hello (call-with-input-file p read))))))
+(test-assert "trivial with #:allowed-references"
+ (let* ((p (package
+ (inherit (dummy-package "trivial"))
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:allowed-references (,%bootstrap-guile)
+ #:builder
+ (begin
+ (mkdir %output)
+ ;; The reference to itself isn't allowed so building it
+ ;; should fail.
+ (symlink %output (string-append %output "/self"))
+ #t)))))
+ (d (package-derivation %store p)))
+ (guard (c ((nix-protocol-error? c) #t))
+ (build-derivations %store (list d))
+ #f)))
+
(test-assert "search paths"
(let* ((p (make-prompt-tag "return-search-paths"))
(s (build-system
(origin (package-derivation %store dep))
(replacement (package-derivation %store new)))))))
-(test-assert "package-grafts, indirect grafts, cross"
- (let* ((new (dummy-package "dep"
- (arguments '(#:implicit-inputs? #f))))
- (dep (package (inherit new) (version "0.0")))
- (dep* (package (inherit dep) (replacement new)))
- (dummy (dummy-package "dummy"
- (arguments '(#:implicit-inputs? #f))
- (inputs `(("dep" ,dep*)))))
- (target "mips64el-linux-gnu"))
- ;; XXX: There might be additional grafts, for instance if the distro
- ;; defines replacements for core packages like Perl.
- (member (graft
- (origin (package-cross-derivation %store dep target))
- (replacement
- (package-cross-derivation %store new target)))
- (package-grafts %store dummy #:target target))))
+;; XXX: This test would require building the cross toolchain just to see if it
+;; needs grafting, which is obviously too expensive, and thus disabled.
+;;
+;; (test-assert "package-grafts, indirect grafts, cross"
+;; (let* ((new (dummy-package "dep"
+;; (arguments '(#:implicit-inputs? #f))))
+;; (dep (package (inherit new) (version "0.0")))
+;; (dep* (package (inherit dep) (replacement new)))
+;; (dummy (dummy-package "dummy"
+;; (arguments '(#:implicit-inputs? #f))
+;; (inputs `(("dep" ,dep*)))))
+;; (target "mips64el-linux-gnu"))
+;; ;; XXX: There might be additional grafts, for instance if the distro
+;; ;; defines replacements for core packages like Perl.
+;; (member (graft
+;; (origin (package-cross-derivation %store dep target))
+;; (replacement
+;; (package-cross-derivation %store new target)))
+;; (package-grafts %store dummy #:target target))))
(test-assert "package-grafts, indirect grafts, propagated inputs"
(let* ((new (dummy-package "dep"
(replacement #f))))
(replacement (package-derivation %store new)))))))
+(test-assert "replacement also grafted"
+ ;; We build a DAG as below, where dotted arrows represent replacements and
+ ;; solid arrows represent dependencies:
+ ;;
+ ;; P1 ·············> P1R
+ ;; |\__________________.
+ ;; v v
+ ;; P2 ·············> P2R
+ ;; |
+ ;; v
+ ;; P3
+ ;;
+ ;; We want to make sure that:
+ ;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
+ ;; where:
+ ;; (A,B) is a graft to replace A by B
+ ;; grafted(DRV,G) denoted DRV with graft G applied
+ (let* ((p1r (dummy-package "P1"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (call-with-output-file
+ (string-append out "/replacement")
+ (const #t)))))))
+ (p1 (package
+ (inherit p1r) (name "p1") (replacement p1r)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (begin
+ (mkdir (assoc-ref %outputs "out"))
+ #t)))))
+ (p2r (dummy-package "P2"
+ (build-system trivial-build-system)
+ (inputs `(("p1" ,p1)))
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p1") "p1")
+ (call-with-output-file (string-append out "/replacement")
+ (const #t)))))))
+ (p2 (package
+ (inherit p2r) (name "p2") (replacement p2r)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p1")
+ "p1")
+ #t)))))
+ (p3 (dummy-package "p3"
+ (build-system trivial-build-system)
+ (inputs `(("p2" ,p2)))
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p2")
+ "p2")
+ #t))))))
+ (lset= equal?
+ (package-grafts %store p3)
+ (list (graft
+ (origin (package-derivation %store p1 #:graft? #f))
+ (replacement (package-derivation %store p1r)))
+ (graft
+ (origin (package-derivation %store p2 #:graft? #f))
+ (replacement
+ (package-derivation %store p2r #:graft? #t)))))))
+
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
;;; find out about their run-time dependencies, so this test is no longer
;;; applicable since it would trigger a full rebuild.
(and (build-derivations %store (list drv))
(file-exists? (string-append out "/bin/make")))))))
+(test-equal "package-mapping"
+ 42
+ (let* ((dep (dummy-package "chbouib"
+ (native-inputs `(("x" ,grep)))))
+ (p0 (dummy-package "example"
+ (inputs `(("foo" ,coreutils)
+ ("bar" ,grep)
+ ("baz" ,dep)))))
+ (transform (lambda (p)
+ (package (inherit p) (source 42))))
+ (rewrite (package-mapping transform))
+ (p1 (rewrite p0)))
+ (and (eq? p1 (rewrite p0))
+ (eqv? 42 (package-source p1))
+ (match (package-inputs p1)
+ ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+ (and (eq? dep1 (rewrite coreutils)) ;memoization
+ (eq? dep2 (rewrite grep))
+ (eq? dep3 (rewrite dep))
+ (eqv? 42
+ (package-source dep1) (package-source dep2)
+ (package-source dep3))
+ (match (package-native-inputs dep3)
+ ((("x" dep))
+ (and (eq? dep (rewrite grep))
+ (package-source dep))))))))))
+
+(test-assert "package-input-rewriting"
+ (let* ((dep (dummy-package "chbouib"
+ (native-inputs `(("x" ,grep)))))
+ (p0 (dummy-package "example"
+ (inputs `(("foo" ,coreutils)
+ ("bar" ,grep)
+ ("baz" ,dep)))))
+ (rewrite (package-input-rewriting `((,coreutils . ,sed)
+ (,grep . ,findutils))
+ (cut string-append "r-" <>)))
+ (p1 (rewrite p0))
+ (p2 (rewrite p0)))
+ (and (not (eq? p1 p0))
+ (eq? p1 p2) ;memoization
+ (string=? "r-example" (package-name p1))
+ (match (package-inputs p1)
+ ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+ (and (eq? dep1 sed)
+ (eq? dep2 findutils)
+ (string=? (package-name dep3) "r-chbouib")
+ (eq? dep3 (rewrite dep)) ;memoization
+ (match (package-native-inputs dep3)
+ ((("x" dep))
+ (eq? dep findutils)))))))))
+
+(test-equal "package-patched-vulnerabilities"
+ '(("CVE-2015-1234")
+ ("CVE-2016-1234" "CVE-2018-4567")
+ ())
+ (let ((p1 (dummy-package "pi"
+ (source (dummy-origin
+ (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
+ (p2 (dummy-package "pi"
+ (source (dummy-origin
+ (patches (list
+ "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
+ (p3 (dummy-package "pi" (source (dummy-origin)))))
+ (map package-patched-vulnerabilities
+ (list p1 p2 p3))))
+
(test-eq "fold-packages" hello
(fold-packages (lambda (p r)
(if (string=? (package-name p) "hello")
r))
#f))
+(test-assert "fold-packages, hidden package"
+ ;; There are two public variables providing "guile@2.0" ('guile-final' in
+ ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
+ ;; should show up.
+ (match (fold-packages (lambda (p r)
+ (if (and (string=? (package-name p) "guile")
+ (string-prefix? "2.0"
+ (package-version p)))
+ (cons p r)
+ r))
+ '())
+ ((one)
+ (eq? one guile-2.0))))
+
(test-assert "find-packages-by-name"
(match (find-packages-by-name "hello")
(((? (cut eq? hello <>))) #t)
(call-with-output-file
(string-append out "/xml/bar/baz/catalog.xml")
(lambda (port)
- (display "xml? wat?!" port)))))))
+ (display "xml? wat?!" port)))
+ #t))))
(synopsis #f) (description #f)
(home-page #f) (license #f)))
(p2 (package
(build-system trivial-build-system)
(arguments
`(#:guile ,%bootstrap-guile
- #:builder (mkdir (assoc-ref %outputs "out"))))
+ #:builder (begin
+ (mkdir (assoc-ref %outputs "out"))
+ #t)))
(native-search-paths (package-native-search-paths libxml2))
(synopsis #f) (description #f)
(home-page #f) (license #f)))
(profile-derivation
(manifest (map package->manifest-entry
(list p1 p2)))
- #:hooks '())
+ #:hooks '()
+ #:locales? #f)
#:guile-for-build (%guile-for-build))))
(build-derivations %store (list prof))
(string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
(guix-package "-p" (derivation->output-path prof)
"--search-paths"))))))
+(test-assert "--search-paths with single-item search path"
+ ;; Make sure 'guix package --search-paths' correctly reports environment
+ ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
+ ;; separator, meaning that the first match wins.
+ (let* ((p1 (dummy-package "foo"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:modules ((guix build utils))
+ #:builder (begin
+ (use-modules (guix build utils))
+ (let ((out (assoc-ref %outputs "out")))
+ (mkdir-p (string-append out "/etc/ssl/certs"))
+ (call-with-output-file
+ (string-append
+ out "/etc/ssl/certs/ca-certificates.crt")
+ (const #t))))))))
+ (p2 (package (inherit p1) (name "bar")))
+ (p3 (dummy-package "git"
+ ;; Provide a fake Git to avoid building the real one.
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (begin
+ (mkdir (assoc-ref %outputs "out"))
+ #t)))
+ (native-search-paths (package-native-search-paths git))))
+ (prof1 (run-with-store %store
+ (profile-derivation
+ (packages->manifest (list p1 p3))
+ #:hooks '()
+ #:locales? #f)
+ #:guile-for-build (%guile-for-build)))
+ (prof2 (run-with-store %store
+ (profile-derivation
+ (packages->manifest (list p2 p3))
+ #:hooks '()
+ #:locales? #f)
+ #:guile-for-build (%guile-for-build))))
+ (build-derivations %store (list prof1 prof2))
+ (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
+ (regexp-quote (derivation->output-path prof1)))
+ (with-output-to-string
+ (lambda ()
+ (guix-package "-p" (derivation->output-path prof1)
+ "-p" (derivation->output-path prof2)
+ "--search-paths"))))))
+
(test-equal "specification->package when not found"
'quit
(catch 'quit
HCoop / jackhill / guix / guix.git / blobdiff