;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (test-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 utils) ;; Rename the 'location' binding to allow proper syntax ;; matching when setting the 'location' field of a package. #:renamer (lambda (name) (cond ((eq? name 'location) 'make-location) (else name)))) #:use-module (guix hash) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix grafts) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system trivial) #:use-module (guix build-system gnu) #:use-module (guix profiles) #:use-module (guix scripts package) #:use-module (gnu packages) #: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-modul
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; 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-accounts)
  #:use-module (gnu build accounts)
  #:use-module (gnu system accounts)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match))

(define %passwd-sample
  "\
root:x:0:0:Admin:/root:/bin/sh
charlie:x:1000:998:Charlie:/home/charlie:/bin/sh\n")

(define %group-sample
  "\
root:x:0:
wheel:x:999:alice,bob
hackers:x:65000:alice,charlie\n")

(define %shadow-sample
  (string-append "\
root:" (crypt "secret" "$6$abc") ":17169::::::
charlie:" (crypt "hey!" "$6$abc") ":17169::::::
nobody:!:0::::::\n"))


(test-begin "accounts")

(test-equal "write-passwd"
  %passwd-sample
  (call-with-output-string
    (lambda (port)
      (write-passwd (list (password-entry
                           (name "root")
                           (uid 0) (gid 0)
                           (real-name "Admin")
                           (directory "/root")
                           (shell "/bin/sh"))
                          (password-entry
                           (name "charlie")
                           (uid 1000) (gid 998)
                           (real-name "Charlie")
                           (directory "/home/charlie")
                           (shell "/bin/sh")))
                    port))))

(test-equal "write-passwd with duplicate entry"
  %passwd-sample
  (call-with-output-string
    (lambda (port)
      (let ((charlie (password-entry
                      (name "charlie")
                      (uid 1000) (gid 998)
                      (real-name "Charlie")
                      (directory "/home/charlie")
                      (shell "/bin/sh"))))
        (write-passwd (list (password-entry
                             (name "root")
                             (uid 0) (gid 0)
                             (real-name "Admin")
                             (directory "/root")
                             (shell "/bin/sh"))
                            charlie charlie)
                      port)))))

(test-equal "read-passwd + write-passwd"
  %passwd-sample
  (call-with-output-string
    (lambda (port)
      (write-passwd (call-with-input-string %passwd-sample
                      read-passwd)
                    port))))

(test-equal "write-group"
  %group-sample
  (call-with-output-string
    (lambda (port)
      (write-group (list (group-entry
                          (name "root") (gid 0))
                         (group-entry
                          (name "wheel") (gid 999)
                          (members '("alice" "bob")))
                         (group-entry
                          (name "hackers") (gid 65000)
                          (members '("alice" "charlie"))))
                   port))))

(test-equal "read-group + write-group"
  %group-sample
  (call-with-output-string
    (lambda (port)
      (write-group (call-with-input-string %group-sample
                     read-group)
                   port))))

(test-equal "write-shadow"
  %shadow-sample
  (call-with-output-string
    (lambda (port)
      (write-shadow (list (shadow-entry
                           (name "root")
                           (password (crypt "secret" "$6$abc"))
                           (last-change 17169))
                          (shadow-entry
                           (name "charlie")
                           (password (crypt "hey!" "$6$abc"))
                           (last-change 17169))
                          (shadow-entry
                           (name "nobody")))
                    port))))

(test-equal "read-shadow + write-shadow"
  %shadow-sample
  (call-with-output-string
    (lambda (port)
      (write-shadow (call-with-input-string %shadow-sample
                      read-shadow)
                    port))))


(define allocate-groups (@@ (gnu build accounts) allocate-groups))
(define allocate-passwd (@@ (gnu build accounts) allocate-passwd))

(test-equal "allocate-groups"
  ;; Allocate GIDs in a stateless fashion.
  (list (group-entry (name "s") (gid %system-id-max))
        (group-entry (name "x") (gid 900))
        (group-entry (name "t") (gid 899))
        (group-entry (name "a") (gid %id-min) (password "foo")
                     (members '("alice" "bob")))
        (group-entry (name "b") (gid (+ %id-min 1))
                     (members '("charlie"))))
  (allocate-groups (list (user-group (name "s") (system? #t))
                         (user-group (name "x") (id 900))
                         (user-group (name "t") (system? #t))
                         (user-group (name "a") (password "foo"))
                         (user-group (name "b")))
                   (alist->vhash `(("a" . "bob")
                                   ("a" . "alice")
                                   ("b" . "charlie")))))

(test-equal "allocate-groups with requested GIDs"
  ;; Make sure the requested GID for "b" is honored.
  (list (group-entry (name "a") (gid (+ 1 %id-min)))
        (group-entry (name "b") (gid %id-min))
        (group-entry (name "c") (gid (+ 2 %id-min))))
  (allocate-groups (list (user-group (name "a"))
                         (user-group (name "b") (id %id-min))
                         (user-group (name "c")))
                   vlist-null))

(test-equal "allocate-groups with previous state"
  ;; Make sure bits of state are preserved: password, GID, no reuse of
  ;; previously-used GIDs.
  (list (group-entry (name "s") (gid (- %system-id-max 1)))
        (group-entry (name "t") (gid (- %system-id-max 2)))
        (group-entry (name "a") (gid 30000) (password #f)
                     (members '("alice" "bob")))
        (group-entry (name "b") (gid 30001) (password "bar")
                     (members '("charlie"))))
  (allocate-groups (list (user-group (name "s") (system? #t))
                         (user-group (name "t") (system? #t))
                         (user-group (name "a") (password "foo"))
                         (user-group (name "b")))
                   (alist->vhash `(("a" . "bob")
                                   ("a" . "alice")
                                   ("b" . "charlie")))
                   (list (group-entry (name "a") (gid 30000))
                         (group-entry (name "b") (gid 30001)
                                      (password "bar"))
                         (group-entry (name "removed")
                                      (gid %system-id-max)))))

(test-equal "allocate-groups with previous state, looping"
  ;; Check that allocation starts after the highest previously-used GID, and
  ;; loops back to the lowest GID.
  (list (group-entry (name "a") (gid (- %id-max 1)))
        (group-entry (name "b") (gid %id-min))
        (group-entry (name "c") (gid (+ 1 %id-min))))
  (allocate-groups (list (user-group (name "a"))
                         (user-group (name "b"))
                         (user-group (name "c")))
                   vlist-null
                   (list (group-entry (name "d")
                                      (gid (- %id-max 2))))))

(test-equal "allocate-passwd"
  ;; Allocate UIDs in a stateless fashion.
  (list (password-entry (name "alice") (uid %id-min) (gid 1000)
                        (real-name "Alice") (shell "/bin/sh")
                        (directory "/home/alice"))
        (password-entry (name "bob") (uid (+ 1 %id-min)) (gid 1001)
                        (real-name "Bob") (shell "/bin/gash")
                        (directory "/home/bob"))
        (password-entry (name "sshd") (uid %system-id-max) (gid 500)
                        (real-name "sshd") (shell "/nologin")
                        (directory "/var/empty"))
        (password-entry (name "guix") (uid 30000) (gid 499)
                        (real-name "Guix") (shell "/nologin")
                        (directory "/var/empty")))
  (allocate-passwd (list (user-account (name "alice")
                                       (comment "Alice")
                                       (shell "/bin/sh")
                                       (group "users"))
                         (user-account (name "bob")
                                       (comment "Bob")
                                       (shell "/bin/gash")
                                       (group "wheel"))
                         (user-account (name "sshd") (system? #t)
                                       (comment "sshd")
                                       (home-directory "/var/empty")
                                       (shell "/nologin")
                                       (group "sshd"))
                         (user-account (name "guix") (system? #t)
                                       (comment "Guix")
                                       (home-directory "/var/empty")
                                       (shell "/nologin")
                                       (group "guix")
                                       (uid 30000)))
                   (list (group-entry (name "users") (gid 1000))
                         (group-entry (name "wheel") (gid 1001))
                         (group-entry (name "sshd") (gid 500))
                         (group-entry (name "guix") (gid 499)))))

(test-equal "allocate-passwd with previous state"
  ;; Make sure bits of state are preserved: UID, no reuse of previously-used
  ;; UIDs, and shell.
  (list (password-entry (name "alice") (uid 1234) (gid 1000)
                        (real-name "Alice Smith") (shell "/bin/sh")
                        (directory "/home/alice"))
        (password-entry (name "charlie") (uid 1236) (gid 1000)
                        (real-name "Charlie") (shell "/bin/sh")
                        (directory "/home/charlie")))
  (allocate-passwd (list (user-account (name "alice")
                                       (comment "Alice")
                                       (shell "/bin/sh") ;honored
                                       (group "users"))
                         (user-account (name "charlie")
                                       (comment "Charlie")
                                       (shell "/bin/sh")
                                       (group "users")))
                   (list (group-entry (name "users") (gid 1000)))
                   (list (password-entry (name "alice") (uid 1234) (gid 9999)
                                         (real-name "Alice Smith")
                                         (shell "/gnu/.../bin/gash") ;ignored
                                         (directory "/home/alice"))
                         (password-entry (name "bob") (uid 1235) (gid 1001)
                                         (real-name "Bob") (shell "/bin/sh")
                                         (directory "/home/bob")))))

(test-equal "user+group-databases"
  ;; The whole shebang.
  (list (list (group-entry (name "a") (gid %id-min)
                           (members '("bob")))
              (group-entry (name "b") (gid (+ 1 %id-min))
                           (members '("alice")))
              (group-entry (name "s") (gid %system-id-max)))
        (list (password-entry (name "alice") (real-name "Alice")
                              (uid %id-min) (gid %id-min)
                              (directory "/a"))
              (password-entry (name "bob") (real-name "Bob")
                              (uid (+ 1 %id-min)) (gid (+ 1 %id-min))
                              (directory "/b"))
              (password-entry (name "nobody")
                              (uid 65534) (gid %system-id-max)
                              (directory "/var/empty")))
        (list (shadow-entry (name "alice") (last-change 100)
                            (password (crypt "initial pass" "$6$")))
              (shadow-entry (name "bob") (last-change 50)
                            (password (crypt "foo" "$6$")))
              (shadow-entry (name "nobody") (last-change 100))))
  (call-with-values
      (lambda ()
        (user+group-databases (list (user-account
                                     (name "alice")
                                     (comment "Alice")
                                     (home-directory "/a")
                                     (group "a")
                                     (supplementary-groups '("b"))
                                     (password (crypt "initial pass" "$6$")))
                                    (user-account
                                     (name "bob")
                                     (comment "Bob")
                                     (home-directory "/b")
                                     (group "b")
                                     (supplementary-groups '("a")))
                                    (user-account
                                     (name "nobody")
                                     (group "s")
                                     (uid 65534)
                                     (home-directory "/var/empty")))
                              (list (user-group (name "a"))
                                    (user-group (name "b"))
                                    (user-group (name "s") (system? #t)))
                              #:current-passwd '()
                              #:current-shadow
                              (list (shadow-entry (name "bob")
                                                  (password (crypt "foo" "$6$"))
                                                  (last-change 50)))
                              #:current-groups '()
                              #:current-time
                              (lambda (type)
                                (make-time type 0 (* 24 3600 100)))))
    list))

(test-end "accounts")
generated by cgit
erivation-file-name drv))))) (test-assert "package-output" (let* ((package (dummy-package "p")) (drv (package-derivation %store package))) (and (derivation? drv) (string=? (derivation->output-path drv) (package-output %store package "out"))))) (test-assert "patch not found yields a run-time error" (guard (c ((condition-has-type? c &message) (and (string-contains (condition-message c) "does-not-exist.patch") (string-contains (condition-message c) "not found")))) (let ((p (package (inherit (dummy-package "p")) (source (origin (method (const #f)) (uri "http://whatever") (patches (list (search-patch "does-not-exist.patch"))) (sha256 (base32 "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4"))))))) (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 . (parameterize ((%graft? #f)) (let* ((dep (dummy-package "dep")) (p (dummy-package "p" (inputs `(("dep" ,dep "non-existent")))))) (guard (c ((derivation-missing-output-error? c) (and (string=? (derivation-missing-output c) "non-existent") (equal? (package-derivation %store dep) (derivation-error-derivation c))))) (package-derivation %store p))))) (test-assert "trivial" (let* ((p (package (inherit (dummy-package "trivial")) (build-system trivial-build-system) (source #f) (arguments `(#:guile ,%bootstrap-guile #:builder (begin (mkdir %output) (call-with-output-file (string-append %output "/test") (lambda (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)))) (equal? '(hello guix) (call-with-input-file (string-append p "/test") read)))))) (test-assert "trivial with local file as input" (let* ((i (search-path %load-path "ice-9/boot-9.scm")) (p (package (inherit (dummy-package "trivial-with-input-file")) (build-system trivial-build-system) (source #f) (arguments `(#:guile ,%bootstrap-guile #: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)) (let ((p (pk 'drv d (derivation->output-path d)))) (equal? (call-with-input-file p get-bytevector-all) (call-with-input-file i get-bytevector-all)))))) (test-assert "trivial with source" (let* ((i (search-path %load-path "ice-9/boot-9.scm")) (p (package (inherit (dummy-package "trivial-with-source")) (build-system trivial-build-system) (source i) (arguments `(#:guile ,%bootstrap-guile #: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))) (equal? (call-with-input-file p get-bytevector-all) (call-with-input-file i get-bytevector-all)))))) (test-assert "trivial with system-dependent input" (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input")) (build-system trivial-build-system) (source #f) (arguments `(#:guile ,%bootstrap-guile #:modules ((guix build utils)) #:builder (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))) (and (build-derivations %store (list d)) (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 (name 'raw) (description "Raw build system with direct store access") (lower (lambda* (name #:key source inputs system target #:allow-other-keys) (bag (name name) (system system) (target target) (build-inputs inputs) (build (lambda* (store name inputs #:key outputs system search-paths) search-paths))))))) (x (list (search-path-specification (variable "GUILE_LOAD_PATH") (files '("share/guile/site/2.0"))) (search-path-specification (variable "GUILE_LOAD_COMPILED_PATH") (files '("share/guile/site/2.0"))))) (a (package (inherit (dummy-package "guile")) (build-system s) (native-search-paths x))) (b (package (inherit (dummy-package "guile-foo")) (build-system s) (inputs `(("guile" ,a))))) (c (package (inherit (dummy-package "guile-bar")) (build-system s) (inputs `(("guile" ,a) ("guile-foo" ,b)))))) (let-syntax ((collect (syntax-rules () ((_ body ...) (call-with-prompt p (lambda () body ...) (lambda (k search-paths) search-paths)))))) (and (null? (collect (package-derivation %store a))) (equal? x (collect (package-derivation %store b))) (equal? x (collect (package-derivation %store c))))))) (test-assert "package-transitive-native-search-paths" (let* ((sp (lambda (name) (list (search-path-specification (variable name) (files '("foo/bar")))))) (p0 (dummy-package "p0" (native-search-paths (sp "PATH0")))) (p1 (dummy-package "p1" (native-search-paths (sp "PATH1")))) (p2 (dummy-package "p2" (native-search-paths (sp "PATH2")) (inputs `(("p0" ,p0))) (propagated-inputs `(("p1" ,p1))))) (p3 (dummy-package "p3" (native-search-paths (sp "PATH3")) (native-inputs `(("p0" ,p0))) (propagated-inputs `(("p2" ,p2)))))) (lset= string=? '("PATH1" "PATH2" "PATH3") (map search-path-specification-variable (package-transitive-native-search-paths p3))))) (test-assert "package-cross-derivation" (let ((drv (package-cross-derivation %store (dummy-package "p") "mips64el-linux-gnu"))) (and (derivation? drv) (file-exists? (derivation-file-name drv))))) (test-assert "package-cross-derivation, trivial-build-system" (let ((p (package (inherit (dummy-package "p")) (build-system trivial-build-system) (arguments '(#:builder (exit 1)))))) (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu"))) (derivation? drv)))) (test-assert "package-cross-derivation, no cross builder" (let* ((b (build-system (inherit trivial-build-system) (lower (const #f)))) (p (package (inherit (dummy-package "p")) (build-system b)))) (guard (c ((package-cross-build-system-error? c) (eq? (package-error-package c) p))) (package-cross-derivation %store p "mips64el-linux-gnu") #f))) ;; XXX: The next two tests can trigger builds when the distro defines ;; replacements on core packages, so they're disable for lack of a better ;; solution. ;; (test-equal "package-derivation, direct graft" ;; (package-derivation %store gnu-make #:graft? #f) ;; (let ((p (package (inherit coreutils) ;; (replacement gnu-make)))) ;; (package-derivation %store p #:graft? #t))) ;; (test-equal "package-cross-derivation, direct graft" ;; (package-cross-derivation %store gnu-make "mips64el-linux-gnu" ;; #:graft? #f) ;; (let ((p (package (inherit coreutils) ;; (replacement gnu-make)))) ;; (package-cross-derivation %store p "mips64el-linux-gnu" ;; #:graft? #t))) (test-assert "package-grafts, indirect grafts" (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*)))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) ;; 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" (arguments '(#:implicit-inputs? #f)))) (dep (package (inherit new) (version "0.0"))) (dep* (package (inherit dep) (replacement new))) (prop (dummy-package "propagated" (propagated-inputs `(("dep" ,dep*))) (arguments '(#:implicit-inputs? #f)))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) (inputs `(("prop" ,prop)))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) (test-assert "package-grafts, same replacement twice" (let* ((new (dummy-package "dep" (version "1") (arguments '(#:implicit-inputs? #f)))) (dep (package (inherit new) (version "0") (replacement new))) (p1 (dummy-package "intermediate1" (arguments '(#:implicit-inputs? #f)) (inputs `(("dep" ,dep))))) (p2 (dummy-package "intermediate2" (arguments '(#:implicit-inputs? #f)) ;; Here we copy DEP to have an equivalent package that is not ;; 'eq?' to DEP. This is similar to what happens with ;; 'package-with-explicit-inputs' & co. (inputs `(("dep" ,(package (inherit dep))))))) (p3 (dummy-package "final" (arguments '(#:implicit-inputs? #f)) (inputs `(("p1" ,p1) ("p2" ,p2)))))) (equal? (package-grafts %store p3) (list (graft (origin (package-derivation %store (package (inherit 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. ;; ;; (test-assert "package-derivation, indirect grafts" ;; (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*))))) ;; (guile (package-derivation %store (canonical-package guile-2.0) ;; #:graft? #f))) ;; (equal? (package-derivation %store dummy) ;; (graft-derivation %store ;; (package-derivation %store dummy #:graft? #f) ;; (package-grafts %store dummy) ;; ;; Use the same Guile as 'package-derivation'. ;; #:guile guile)))) (test-equal "package->bag" `("foo86-hurd" #f (,(package-source gnu-make)) (,(canonical-package glibc)) (,(canonical-package coreutils))) (let ((bag (package->bag gnu-make "foo86-hurd"))) (list (bag-system bag) (bag-target bag) (assoc-ref (bag-build-inputs bag) "source") (assoc-ref (bag-build-inputs bag) "libc") (assoc-ref (bag-build-inputs bag) "coreutils")))) (test-equal "package->bag, cross-compilation" `(,(%current-system) "foo86-hurd" (,(package-source gnu-make)) (,(canonical-package glibc)) (,(canonical-package coreutils))) (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd"))) (list (bag-system bag) (bag-target bag) (assoc-ref (bag-build-inputs bag) "source") (assoc-ref (bag-build-inputs bag) "libc") (assoc-ref (bag-build-inputs bag) "coreutils")))) (test-assert "package->bag, propagated inputs" (let* ((dep (dummy-package "dep")) (prop (dummy-package "prop" (propagated-inputs `(("dep" ,dep))))) (dummy (dummy-package "dummy" (inputs `(("prop" ,prop))))) (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f)))) (match (assoc "dep" inputs) (("dep" package) (eq? package dep))))) (test-assert "bag->derivation" (parameterize ((%graft? #f)) (let ((bag (package->bag gnu-make)) (drv (package-derivation %store gnu-make))) (parameterize ((%current-system "foox86-hurd")) ;should have no effect (equal? drv (bag->derivation %store bag)))))) (test-assert "bag->derivation, cross-compilation" (parameterize ((%graft? #f)) (let* ((target "mips64el-linux-gnu") (bag (package->bag gnu-make (%current-system) target)) (drv (package-cross-derivation %store gnu-make target))) (parameterize ((%current-system "foox86-hurd") ;should have no effect (%current-target-system "foo64-linux-gnu")) (equal? drv (bag->derivation %store bag)))))) (when (or (not (network-reachable?)) (shebang-too-long?)) (test-skip 1)) (test-assert "GNU Make, bootstrap" ;; GNU Make is the first program built during bootstrap; we choose it ;; here so that the test doesn't last for too long. (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0))) (and (package? gnu-make) (or (location? (package-location gnu-make)) (not (package-location gnu-make))) (let* ((drv (package-derivation %store gnu-make)) (out (derivation->output-path drv))) (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-eq "fold-packages" hello (fold-packages (lambda (p r) (if (string=? (package-name p) "hello") p 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) (wrong (pk 'find-packages-by-name wrong #f)))) (test-assert "find-packages-by-name with version" (match (find-packages-by-name "hello" (package-version hello)) (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) (test-assert "--search-paths with pattern" ;; Make sure 'guix package --search-paths' correctly reports environment ;; variables when file patterns are used (in particular, it must follow ;; symlinks when looking for 'catalog.xml'.) To do that, we rely on the ;; libxml2 package specification, which contains such a definition. (let* ((p1 (package (name "foo") (version "0") (source #f) (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 "/xml/bar/baz")) (call-with-output-file (string-append out "/xml/bar/baz/catalog.xml") (lambda (port) (display "xml? wat?!" port))) #t)))) (synopsis #f) (description #f) (home-page #f) (license #f))) (p2 (package ;; Provide a fake libxml2 to avoid building the real one. This ;; is OK because 'guix package' gets search path specifications ;; from the same-named package found in the distro. (name "libxml2") (version "0.0.0") (source #f) (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #: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))) (prof (run-with-store %store (profile-derivation (manifest (map package->manifest-entry (list p1 p2))) #: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" (regexp-quote (derivation->output-path prof))) (with-output-to-string (lambda () (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 (lambda () ;; This should call 'leave', producing an error message. (specification->package "this-package-does-not-exist")) (lambda (key . args) key))) (test-end "packages") ;;; Local Variables: ;;; eval: (put 'dummy-package 'scheme-indent-function 1) ;;; End: