diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/gexp.scm | 86 | ||||
| -rw-r--r-- | tests/graph.scm | 4 | ||||
| -rw-r--r-- | tests/guix-build.sh | 21 | ||||
| -rw-r--r-- | tests/guix-pack.sh | 24 | ||||
| -rw-r--r-- | tests/guix-package.sh | 8 | ||||
| -rw-r--r-- | tests/guix-system.sh | 13 | ||||
| -rw-r--r-- | tests/pack.scm | 15 | ||||
| -rw-r--r-- | tests/packages.scm | 92 | ||||
| -rw-r--r-- | tests/profiles.scm | 63 | ||||
| -rw-r--r-- | tests/records.scm | 30 | ||||
| -rw-r--r-- | tests/store-database.scm | 54 | ||||
| -rw-r--r-- | tests/store-deduplication.scm | 64 | ||||
| -rw-r--r-- | tests/system.scm | 6 | ||||
| -rw-r--r-- | tests/union.scm | 18 | ||||
| -rw-r--r-- | tests/utils.scm | 8 | ||||
| -rw-r--r-- | tests/uuid.scm | 9 |
16 files changed, 447 insertions, 68 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm index 3c8b4624da..a560adfc5c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -23,6 +23,7 @@ #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix build-system trivial) #:use-module (guix tests) #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module ((guix utils) #:select (call-with-temporary-directory)) @@ -66,6 +67,27 @@ (run-with-store %store exp #:guile-for-build (%guile-for-build)))) +(define %extension-package + ;; Example of a package to use when testing 'with-extensions'. + (dummy-package "extension" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils)) + (let* ((out (string-append (assoc-ref %outputs "out") + "/share/guile/site/" + (effective-version)))) + (mkdir-p out) + (call-with-output-file (string-append out "/hg2g.scm") + (lambda (port) + (write '(define-module (hg2g) + #:export (the-answer)) + port) + (write '(define the-answer 42) port))))))))) + (test-begin "gexp") @@ -739,6 +761,54 @@ (built-derivations (list drv)) (return (= 42 (call-with-input-file out read)))))) +(test-equal "gexp-extensions & ungexp" + (list sed grep) + ((@@ (guix gexp) gexp-extensions) + #~(foo #$(with-extensions (list grep) #~+) + #+(with-extensions (list sed) #~-)))) + +(test-equal "gexp-extensions & ungexp-splicing" + (list grep sed) + ((@@ (guix gexp) gexp-extensions) + #~(foo #$@(list (with-extensions (list grep) #~+) + (with-imported-modules '((foo)) + (with-extensions (list sed) #~-)))))) + +(test-equal "gexp-extensions and literal Scheme object" + '() + ((@@ (guix gexp) gexp-extensions) #t)) + +(test-assertm "gexp->derivation & with-extensions" + ;; Create a fake Guile extension and make sure it is accessible both to the + ;; imported modules and to the derivation build script. + (mlet* %store-monad + ((extension -> %extension-package) + (module -> (scheme-file "x" #~( ;; splice! + (define-module (foo) + #:use-module (hg2g) + #:export (multiply)) + + (define (multiply x) + (* the-answer x))) + #:splice? #t)) + (build -> (with-extensions (list extension) + (with-imported-modules `((guix build utils) + ((foo) => ,module)) + #~(begin + (use-modules (guix build utils) + (hg2g) (foo)) + (call-with-output-file #$output + (lambda (port) + (write (list the-answer (multiply 2)) + port))))))) + (drv (gexp->derivation "thingie" build + ;; %BOOTSTRAP-GUILE is 2.0. + #:effective-version "2.0")) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (equal? '(42 84) (call-with-input-file out read)))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) @@ -948,6 +1018,22 @@ (return (and (zero? (close-pipe pipe)) (string=? text str)))))))))) +(test-assertm "program-file & with-extensions" + (let* ((exp (with-extensions (list %extension-package) + (gexp (begin + (use-modules (hg2g)) + (display the-answer))))) + (file (program-file "program" exp + #:guile %bootstrap-guile))) + (mlet* %store-monad ((drv (lower-object file)) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (= 42 (string->number str))))))))) + (test-assertm "scheme-file" (let* ((text (plain-file "foo" "Hello, world!")) (scheme (scheme-file "bar" #~(list "foo" #$text)))) diff --git a/tests/graph.scm b/tests/graph.scm index 5faa19298a..4799d3bd0c 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -134,7 +134,7 @@ edges." (map (lambda (destination) (list "p-0.drv" (string-append - (package-full-name destination) + (package-full-name destination "-") ".drv"))) implicit))))))) @@ -293,7 +293,7 @@ edges." (run-with-store %store (let ((packages (fold-packages cons '()))) (mlet %store-monad ((edges (node-edges %package-node-type packages))) - (return (and (null? (edges sed)) + (return (and (null? (edges hello)) (lset= eq? (edges guile-2.0) (match (package-direct-inputs guile-2.0) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index b84723fa43..92e7299321 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2012, 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -138,6 +138,25 @@ test `guix build -d --sources=transitive foo \ | grep -e 'foo\.tar\.gz' -e 'bar\.tar\.gz' -e 'bar\.dat' \ | wc -l` -eq 3 + +# Unbound variables. +cat > "$module_dir/foo.scm"<<EOF +(define-module (foo) + #:use-module (guix tests) + #:use-module (guix build-system trivial)) + +(define-public foo + (dummy-package "package-with-something-wrong" + (build-system trivial-build-system) + (inputs (quasiquote (("sed" ,sed)))))) ;unbound variable +EOF + +if guix build package-with-something-wrong -n; then false; else true; fi +guix build package-with-something-wrong -n 2> "$module_dir/err" || true +grep "unbound" "$module_dir/err" # actual error +grep "forget.*(gnu packages base)" "$module_dir/err" # hint +rm -f "$module_dir"/* + # Should all return valid log files. drv="`guix build -d -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`" out="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`" diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index 1b63b957be..917d52451c 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -35,18 +35,23 @@ export GUIX_BUILD_OPTIONS # Build a tarball with no compression. guix pack --compression=none --bootstrap guile-bootstrap -# Build a tarball (with compression). -guix pack --bootstrap guile-bootstrap +# Build a tarball (with compression). Check that '-e' works as well. +out1="`guix pack --bootstrap guile-bootstrap`" +out2="`guix pack --bootstrap -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`" +test -n "$out1" +test "$out1" = "$out2" # Build a tarball with a symlink. the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`" -# Try to extract it. +# Try to extract it. Note: we cannot test whether /opt/gnu/bin/guile itself +# exists because /opt/gnu/bin may be an absolute symlink to a store item that +# has been GC'd. test_directory="`mktemp -d`" trap 'rm -rf "$test_directory"' EXIT cd "$test_directory" tar -xf "$the_pack" -test -x opt/gnu/bin/guile +test -L opt/gnu/bin is_available () { # Use the "type" shell builtin to see if the program is on PATH. @@ -81,3 +86,14 @@ guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap # Build a tarball pack of cross-compiled software. Use coreutils because # guile-bootstrap is not intended to be cross-compiled. guix pack --dry-run --bootstrap --target=arm-unknown-linux-gnueabihf coreutils + +# Likewise, 'guix pack -R' requires a full-blown toolchain (because +# 'glibc-bootstrap' lacks 'libc.a'), hence '--dry-run'. +guix pack -R --dry-run --bootstrap -S /mybin=bin guile-bootstrap + +# Make sure package transformation options are honored. +mkdir -p "$test_directory" +drv1="`guix pack -n guile 2>&1 | grep pack.*\.drv`" +drv2="`guix pack -n --with-source=guile=$test_directory guile 2>&1 | grep pack.*\.drv`" +test -n "$drv1" +test "$drv1" != "$drv2" diff --git a/tests/guix-package.sh b/tests/guix-package.sh index aa5eaa66e7..3b3fa35cd8 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -60,12 +60,12 @@ test -L "$profile" && test -L "$profile-1-link" ! test -f "$profile-2-link" test -f "$profile/bin/guile" -# Collisions are properly flagged (in this case, 'python-wrapper' propagates -# python@3, which conflicts with python@2.) -if guix package --bootstrap -n -p "$profile" -i python@2 python-wrapper +# Collisions are properly flagged (in this case, 'g-wrap' propagates +# guile@2.2, which conflicts with guile@2.0.) +if guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0 then false; else true; fi -guix package --bootstrap -n -p "$profile" -i python@2 python-wrapper \ +guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0 \ --allow-collisions # No search path env. var. here. diff --git a/tests/guix-system.sh b/tests/guix-system.sh index ff9114ab74..36ba5fbd5f 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -111,8 +111,7 @@ cat > "$tmpfile" <<EOF (bootloader (GRUB-config (device "/dev/sdX"))) ; 9 (file-systems (cons (file-system - (device "root") - (title 'label) + (device (file-system-label "root")) (mount-point "/") (type "ext4")) %base-file-systems))) @@ -125,9 +124,9 @@ else then # FIXME: With Guile 2.2.0 the error is reported on line 4. # See <http://bugs.gnu.org/26107>. - grep "$tmpfile:[49]:[0-9]\+: GRUB-config.*[Uu]nbound variable" "$errorfile" + grep "$tmpfile:[49]:[0-9]\+:.*GRUB-config.*[Uu]nbound variable" "$errorfile" else - grep "$tmpfile:9:[0-9]\+: GRUB-config.*[Uu]nbound variable" "$errorfile" + grep "$tmpfile:9:[0-9]\+:.*GRUB-config.*[Uu]nbound variable" "$errorfile" fi fi @@ -140,8 +139,7 @@ OS_BASE=' (bootloader grub-bootloader) (device "/dev/sdX"))) (file-systems (cons (file-system - (device "root") - (title (string->symbol "label")) + (device (file-system-label "root")) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -213,8 +211,7 @@ make_user_config () (bootloader grub-bootloader) (device "/dev/sdX"))) (file-systems (cons (file-system - (device "root") - (title 'label) + (device (file-system-label "root")) (mount-point "/") (type "ext4")) %base-file-systems)) diff --git a/tests/pack.scm b/tests/pack.scm index 3bce715075..d4596f863a 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,20 +62,20 @@ #:symlinks '(("/bin/Guile" -> "bin/guile")) #:compressor %gzip-compressor - #:tar %tar-bootstrap)) + #:archiver %tar-bootstrap)) (check (gexp->derivation "check-tarball" - #~(let ((guile (string-append "." #$profile "/bin"))) + #~(let ((bin (string-append "." #$profile "/bin"))) (setenv "PATH" (string-append #$%tar-bootstrap "/bin")) (system* "tar" "xvf" #$tarball) (mkdir #$output) (exit - (and (file-exists? (string-append guile "/guile")) + (and (file-exists? (string-append bin "/guile")) (string=? (string-append #$%bootstrap-guile "/bin") - (readlink guile)) - (string=? (string-append (string-drop guile 1) - "/guile") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") (readlink "bin/Guile")))))))) (built-derivations (list check)))) diff --git a/tests/packages.scm b/tests/packages.scm index 9e19c3992e..65ccb14889 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -407,18 +407,23 @@ (%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))) @@ -486,7 +491,8 @@ (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)))) @@ -500,8 +506,10 @@ (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)) @@ -516,8 +524,10 @@ (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))) @@ -530,11 +540,14 @@ (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))) @@ -554,7 +567,8 @@ (mkdir %output) ;; The reference to itself isn't allowed so building it ;; should fail. - (symlink %output (string-append %output "/self"))))))) + (symlink %output (string-append %output "/self")) + #t))))) (d (package-derivation %store p))) (guard (c ((nix-protocol-error? c) #t)) (build-derivations %store (list d)) @@ -766,7 +780,9 @@ (inherit p1r) (name "p1") (replacement p1r) (arguments `(#:guile ,%bootstrap-guile - #:builder (mkdir (assoc-ref %outputs "out")))))) + #:builder (begin + (mkdir (assoc-ref %outputs "out")) + #t))))) (p2r (dummy-package "P2" (build-system trivial-build-system) (inputs `(("p1" ,p1))) @@ -786,7 +802,8 @@ (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p1") - "p1")))))) + "p1") + #t))))) (p3 (dummy-package "p3" (build-system trivial-build-system) (inputs `(("p2" ,p2))) @@ -796,7 +813,8 @@ (mkdir out) (chdir out) (symlink (assoc-ref %build-inputs "p2") - "p2"))))))) + "p2") + #t)))))) (lset= equal? (package-grafts %store p3) (list (graft @@ -941,6 +959,21 @@ ((("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") @@ -990,7 +1023,8 @@ (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 @@ -1001,7 +1035,9 @@ (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))) @@ -1043,7 +1079,9 @@ (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 git)))) (prof1 (run-with-store %store (profile-derivation diff --git a/tests/profiles.scm b/tests/profiles.scm index 92eb08cb9e..3a59a0cc4f 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -223,6 +223,52 @@ (string=? (dirname (readlink bindir)) (derivation->output-path guile)))))) +(test-assertm "profile-derivation relative symlinks, one entry" + (mlet* %store-monad + ((entry -> (package->manifest-entry %bootstrap-guile)) + (guile (package->derivation %bootstrap-guile)) + (drv (profile-derivation (manifest (list entry)) + #:relative-symlinks? #t + #:hooks '() + #:locales? #f)) + (profile -> (derivation->output-path drv)) + (bindir -> (string-append profile "/bin")) + (_ (built-derivations (list drv)))) + (return (and (file-exists? (string-append bindir "/guile")) + (string=? (readlink bindir) + (string-append "../" + (basename + (derivation->output-path guile)) + "/bin")))))) + +(unless (network-reachable?) (test-skip 1)) +(test-assertm "profile-derivation relative symlinks, two entries" + (mlet* %store-monad + ((gnu-make-boot0 -> (@@ (gnu packages commencement) gnu-make-boot0)) + (manifest -> (packages->manifest + (list %bootstrap-guile gnu-make-boot0))) + (guile (package->derivation %bootstrap-guile)) + (make (package->derivation gnu-make-boot0)) + (drv (profile-derivation manifest + #:relative-symlinks? #t + #:hooks '() + #:locales? #f)) + (profile -> (derivation->output-path drv)) + (bindir -> (string-append profile "/bin")) + (_ (built-derivations (list drv)))) + (return (and (file-exists? (string-append bindir "/guile")) + (file-exists? (string-append bindir "/make")) + (string=? (readlink (string-append bindir "/guile")) + (string-append "../../" + (basename + (derivation->output-path guile)) + "/bin/guile")) + (string=? (readlink (string-append bindir "/make")) + (string-append "../../" + (basename + (derivation->output-path make)) + "/bin/make")))))) + (test-assertm "profile-derivation, inputs" (mlet* %store-monad ((entry -> (package->manifest-entry packages:glibc "debug")) @@ -242,8 +288,8 @@ #:hooks '() #:locales? #t #:target target))) - (define (find-input name) - (let ((name (string-append name ".drv"))) + (define (find-input package) + (let ((name (string-append (package-full-name package "-") ".drv"))) (any (lambda (input) (let ((input (derivation-input-path input))) (and (string-suffix? name input) input))) @@ -252,12 +298,11 @@ ;; The inputs for grep and sed should be cross-build derivations, but that ;; for the glibc-utf8-locales should be a native build. (return (and (string=? (derivation-system drv) (%current-system)) - (string=? (find-input (package-full-name packages:grep)) + (string=? (find-input packages:grep) (derivation-file-name grep)) - (string=? (find-input (package-full-name packages:sed)) + (string=? (find-input packages:sed) (derivation-file-name sed)) - (string=? (find-input - (package-full-name packages:glibc-utf8-locales)) + (string=? (find-input packages:glibc-utf8-locales) (derivation-file-name locales)))))) (test-assert "package->manifest-entry defaults to \"out\"" @@ -453,7 +498,8 @@ (mkdir (string-append out "/etc")) (call-with-output-file (string-append out "/etc/foo") (lambda (port) - (display "foo!" port)))))))) + (display "foo!" port))) + #t))))) (entry -> (package->manifest-entry thing)) (drv (profile-derivation (manifest (list entry)) #:hooks '() @@ -482,7 +528,8 @@ (symlink "foo" (string-append out "/etc")) (call-with-output-file (string-append out "/etc/bar") (lambda (port) - (display "foo!" port)))))))) + (display "foo!" port))) + #t))))) (entry -> (package->manifest-entry thing)) (drv (profile-derivation (manifest (list entry)) #:hooks '() diff --git a/tests/records.scm b/tests/records.scm index d6d27bb96a..80e08a9a5f 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -1,5 +1,5 @@ ;;; 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, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -288,6 +288,34 @@ (and (string-match "extra.*initializer.*baz" message) (eq? proc 'foo))))) +(test-assert "ABI checks" + (let ((module (test-module))) + (eval '(begin + (define-record-type* <foo> foo make-foo + foo? + (bar foo-bar (default 42))) + + (define (make-me-a-record) (foo))) + module) + (unless (eval '(foo? (make-me-a-record)) module) + (error "what?" (eval '(make-me-a-record) module))) + + ;; Redefine <foo> with an additional field. + (eval '(define-record-type* <foo> foo make-foo + foo? + (baz foo-baz) + (bar foo-bar (default 42))) + module) + + ;; Now 'make-me-a-record' is out of sync because it does an + ;; 'allocate-struct' that corresponds to the previous definition of <foo>. + (catch 'record-abi-mismatch-error + (lambda () + (eval '(foo? (make-me-a-record)) module) + #f) + (lambda (key rtd . _) + (eq? rtd (eval '<foo> module)))))) + (test-equal "recutils->alist" '((("Name" . "foo") ("Version" . "0.1") diff --git a/tests/store-database.scm b/tests/store-database.scm new file mode 100644 index 0000000000..1348a75c26 --- /dev/null +++ b/tests/store-database.scm @@ -0,0 +1,54 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017, 2018 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-store-database) + #:use-module (guix tests) + #:use-module ((guix store) #:hide (register-path)) + #:use-module (guix store database) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64)) + +;; Test the (guix store database) module. + +(define %store + (open-connection-for-tests)) + + +(test-begin "store-database") + +(test-assert "register-path" + (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) + "-fake"))) + (when (valid-path? %store file) + (delete-paths %store (list file))) + (false-if-exception (delete-file file)) + + (let ((ref (add-text-to-store %store "ref-of-fake" (random-text))) + (drv (string-append file ".drv"))) + (call-with-output-file file + (cut display "This is a fake store item.\n" <>)) + (register-path file + #:references (list ref) + #:deriver drv) + + (and (valid-path? %store file) + (equal? (references %store file) (list ref)) + (null? (valid-derivers %store file)) + (null? (referrers %store file)))))) + +(test-end "store-database") diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm new file mode 100644 index 0000000000..04817a193a --- /dev/null +++ b/tests/store-deduplication.scm @@ -0,0 +1,64 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 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-store-deduplication) + #:use-module (guix tests) + #:use-module (guix store deduplication) + #:use-module (guix hash) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (guix build utils) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(test-begin "store-deduplication") + +(test-equal "deduplicate" + (cons* #t #f ;inode comparisons + 2 (make-list 5 6)) ;'nlink' values + + (call-with-temporary-directory + (lambda (store) + (let ((data (string->utf8 "Hello, world!")) + (identical (map (lambda (n) + (string-append store "/" (number->string n))) + (iota 5))) + (unique (string-append store "/unique"))) + (for-each (lambda (file) + (call-with-output-file file + (lambda (port) + (put-bytevector port data)))) + identical) + (call-with-output-file unique + (lambda (port) + (put-bytevector port (string->utf8 "This is unique.")))) + + (for-each (lambda (file) + (deduplicate file (sha256 data) #:store store)) + identical) + (deduplicate unique (nar-sha256 unique) #:store store) + + ;; (system (string-append "ls -lRia " store)) + (cons* (apply = (map (compose stat:ino stat) identical)) + (= (stat:ino (stat unique)) + (stat:ino (stat (car identical)))) + (stat:nlink (stat unique)) + (map (compose stat:nlink stat) identical)))))) + +(test-end "store-deduplication") diff --git a/tests/system.scm b/tests/system.scm index 6a7f45c59c..7d55da7174 100644 --- a/tests/system.scm +++ b/tests/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. @@ -27,8 +27,7 @@ (define %root-fs (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4"))) @@ -114,7 +113,6 @@ (inherit %os-with-mapped-device) (file-systems (cons (file-system (device "/dev/mapper/my-luks-device") - (title 'device) (mount-point "/") (type "ext4")) %base-file-systems))))) diff --git a/tests/union.scm b/tests/union.scm index aa95cae001..5a6a4033fc 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -184,4 +184,22 @@ (file-is-directory? "bin") (eq? 'symlink (stat:type (lstat "bin/guile")))))))) +(letrec-syntax ((test-relative-file-name + (syntax-rules (=>) + ((_ (reference file => expected) rest ...) + (begin + (test-equal (string-append "relative-file-name " + reference " " file) + expected + (relative-file-name reference file)) + (test-relative-file-name rest ...))) + ((_) + #t)))) + (test-relative-file-name + ("/a/b" "/a/c/d" => "../c/d") + ("/a/b" "/a/b" => "") + ("/a/b" "/a" => "..") + ("/a/b" "/a/b/c/d" => "c/d") + ("/a/b/c" "/a/d/e/f" => "../../d/e/f"))) + (test-end) diff --git a/tests/utils.scm b/tests/utils.scm index 035886dd16..3015b21b23 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; @@ -72,6 +72,12 @@ (test-assert "guile-version>? 10.5" (not (guile-version>? "10.5"))) +(test-assert "version-prefix?" + (and (version-prefix? "4.1" "4.1.2") + (version-prefix? "4.1" "4.1") + (not (version-prefix? "4.1" "4.16.2")) + (not (version-prefix? "4.1" "4")))) + (test-equal "string-tokenize*" '(("foo") ("foo" "bar" "baz") diff --git a/tests/uuid.scm b/tests/uuid.scm index 91a3482490..260614f079 100644 --- a/tests/uuid.scm +++ b/tests/uuid.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,6 +57,13 @@ "1234-ABCD" (uuid->string (uuid "1234-abcd" 'fat32))) +(test-assert "uuid, dynamic value" + (let* ((good "4dab5feb-d176-45de-b287-9b0a6e4c01cb") + (bad (string-drop good 3))) + (and (uuid? (uuid good)) + (string=? good (uuid->string (uuid good))) + (not (uuid bad))))) + (test-assert "uuid=?" (and (uuid=? (uuid-bytevector (uuid "1234-abcd" 'fat32)) (uuid "1234-abcd" 'fat32)) |