From 44057a461b1fa8102938c4e0f54d7cbc9dd09b03 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 30 May 2018 09:55:28 +0200 Subject: tests: Fix arguments in pack test. This is a follow-up to commit 5ffac538aa604b71814ac74579626f0d3110b96e. * tests/pack.scm (self-contained-tarball): Adjust arguments to "self-contained-tarball". --- tests/pack.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/pack.scm b/tests/pack.scm index 3bce715075..fcc53d12ef 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 +;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,7 +62,7 @@ #: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"))) -- cgit v1.2.3 From ccc951cab3172adfdaf6fd2dfa8f8cdb98358a69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jun 2018 15:17:41 +0200 Subject: pack: Adjust test to expect relative symlinks. Reported by Chris Marusich . Fixes . * tests/pack.scm ("self-contained-tarball"): Rename 'guile' to 'bin'. Expect 'bin/Guile' to be a relative symlink. --- tests/pack.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/tests/pack.scm b/tests/pack.scm index fcc53d12ef..d4596f863a 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -65,17 +65,17 @@ #: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)))) -- cgit v1.2.3 From 838e17d8050236a6d3ffde991fb0035412eb3046 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 May 2018 18:14:37 +0200 Subject: gexp: Add 'with-extensions'. * guix/gexp.scm ()[extensions]: New field. (gexp-attribute): New procedure. (gexp-modules): Write in terms of 'gexp-attribute'. (gexp-extensions): New procedure. (gexp->derivation): Add #:effective-version. [extension-flags]: New procedure. Honor extensions of EXP. (current-imported-extensions): New syntax parameter. (with-extensions): New macro. (gexp): Honor CURRENT-IMPORTED-EXTENSIONS. (compiled-modules): Add #:extensions and honor it. (load-path-expression): Likewise. (gexp->script, gexp->file): Honor extensions. * tests/gexp.scm (%extension-package): New variable. ("gexp-extensions & ungexp") ("gexp-extensions & ungexp-splicing") ("gexp-extensions and literal Scheme object") ("gexp->derivation & with-extensions") ("program-file & with-extensions"): New tests. * doc/guix.texi (G-Expressions): Document 'with-extensions'. --- tests/gexp.scm | 86 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 86 insertions(+) (limited to 'tests') 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)))) -- cgit v1.2.3 From 7f9d184d9b688d13ce76eefabaddcfa76bdde2b5 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sun, 27 May 2018 19:19:30 +0200 Subject: Add (gnu store database). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/config.scm.in (%store-database-directory): New variable. * guix/store/database.scm: New file. * tests/store-database.scm: New file. * Makefile.am (STORE_MODULES): New variable. (MODULES, MODULES_NOT_COMPILED): Adjust accordingly. (SCM_TESTS) [HAVE_GUILE_SQLITE3]: Add tests/store-database.scm. Co-authored-by: Ludovic Courtès --- tests/store-database.scm | 54 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 tests/store-database.scm (limited to 'tests') 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 +;;; +;;; 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-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") -- cgit v1.2.3 From bf5bf5778cb7c3a2475c6acd707abc925b1819aa Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sun, 27 May 2018 23:20:54 +0200 Subject: Add (guix store deduplication). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/store/database.scm (register-path): Add #:deduplicate? and call 'deduplicate' when it's true. (counting-wrapper-port, nar-sha256): Move to... * guix/store/deduplication.scm: ... here. New file. * tests/store-deduplication.scm: New file. * Makefile.am (STORE_MODULES): Add deduplication.scm. (SCM_TESTS) [HAVE_GUILE_SQLITE3]: Add store-deduplication.scm. Co-authored-by: Ludovic Courtès --- tests/store-deduplication.scm | 64 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 64 insertions(+) create mode 100644 tests/store-deduplication.scm (limited to 'tests') 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 +;;; +;;; 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-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") -- cgit v1.2.3