diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/gexp.scm | 86 | ||||
| -rw-r--r-- | tests/pack.scm | 12 | ||||
| -rw-r--r-- | tests/store-database.scm | 54 | ||||
| -rw-r--r-- | tests/store-deduplication.scm | 64 |
4 files changed, 210 insertions, 6 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/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 <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. @@ -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)))) 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") |