diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/guix-register.sh | 29 | ||||
| -rw-r--r-- | tests/hash.scm | 59 | ||||
| -rw-r--r-- | tests/nar.scm | 103 | ||||
| -rw-r--r-- | tests/store.scm | 54 | ||||
| -rw-r--r-- | tests/utils.scm | 32 |
5 files changed, 272 insertions, 5 deletions
diff --git a/tests/guix-register.sh b/tests/guix-register.sh index ca28fb0d95..ee633af4f9 100644 --- a/tests/guix-register.sh +++ b/tests/guix-register.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -29,6 +29,33 @@ rm -rf "$new_store" exit_hook=":" trap "chmod -R +w $new_store ; rm -rf $new_store $closure ; \$exit_hook" EXIT +# +# Registering items in the current store---i.e., without '--prefix'. +# + +new_file="$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-guix-register-$$" +echo "Fake store file to test registration." > "$new_file" + +# Register the file with zero references and no deriver. +guix-register <<EOF +$new_file + +0 +EOF + +# Make sure it's valid, and delete it. +guile -c " + (use-modules (guix store)) + (define s (open-connection)) + (exit (and (valid-path? s \"$new_file\") + (null? (references s \"$new_file\")) + (pair? (delete-paths s (list \"$new_file\")))))" + + +# +# Registering items in a new store, with '--prefix'. +# + mkdir -p "$new_store/$storedir" new_store_dir="`cd "$new_store/$storedir" ; pwd`" new_store="`cd "$new_store" ; pwd`" diff --git a/tests/hash.scm b/tests/hash.scm index 27751023d3..9bcd69440b 100644 --- a/tests/hash.scm +++ b/tests/hash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,6 +37,14 @@ (base16-string->bytevector "b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9")) +(define (supports-unbuffered-cbip?) + "Return #t if unbuffered custom binary input ports (CBIPs) are supported. +In Guile <= 2.0.9, CBIPs were always fully buffered, so the +'open-sha256-input-port' does not work there." + (false-if-exception + (setvbuf (make-custom-binary-input-port "foo" pk #f #f #f) _IONBF))) + + (test-begin "hash") (test-equal "sha256, empty" @@ -68,6 +76,55 @@ (equal? (sha256 contents) (call-with-input-file file port-sha256)))) +(test-skip (if (supports-unbuffered-cbip?) 0 4)) + +(test-equal "open-sha256-input-port, empty" + `("" ,%empty-sha256) + (let-values (((port get) + (open-sha256-input-port (open-string-input-port "")))) + (let ((str (get-string-all port))) + (list str (get))))) + +(test-equal "open-sha256-input-port, hello" + `("hello world" ,%hello-sha256) + (let-values (((port get) + (open-sha256-input-port + (open-bytevector-input-port + (string->utf8 "hello world"))))) + (let ((str (get-string-all port))) + (list str (get))))) + +(test-equal "open-sha256-input-port, hello, one two" + (list (string->utf8 "hel") (string->utf8 "lo") + (base16-string->bytevector ; echo -n hello | sha256sum + "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824") + " world") + (let-values (((port get) + (open-sha256-input-port + (open-bytevector-input-port (string->utf8 "hello world"))))) + (let* ((one (get-bytevector-n port 3)) + (two (get-bytevector-n port 2)) + (hash (get)) + (three (get-string-all port))) + (list one two hash three)))) + +(test-equal "open-sha256-input-port, hello, read from wrapped port" + (list (string->utf8 "hello") + (base16-string->bytevector ; echo -n hello | sha256sum + "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824") + " world") + (let*-values (((wrapped) + (open-bytevector-input-port (string->utf8 "hello world"))) + ((port get) + (open-sha256-input-port wrapped))) + (let* ((hello (get-bytevector-n port 5)) + (hash (get)) + + ;; Now read from WRAPPED to make sure its current position is + ;; correct. + (world (get-string-all wrapped))) + (list hello hash world)))) + (test-end) diff --git a/tests/nar.scm b/tests/nar.scm index 6493d76876..9f21f990c8 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,11 +18,17 @@ (define-module (test-nar) #:use-module (guix nar) + #:use-module (guix store) + #:use-module ((guix hash) #:select (open-sha256-input-port)) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (ice-9 ftw) + #:use-module (ice-9 regex) #:use-module (ice-9 match)) ;; Test the (guix nar) module. @@ -156,6 +162,24 @@ (string-append (dirname (search-path %load-path "pre-inst-env")) "/test-nar-" (number->string (getpid)))) +;; XXX: Factorize. +(define %seed + (seed->random-state (logxor (getpid) (car (gettimeofday))))) + +(define (random-text) + (number->string (random (expt 2 256) %seed) 16)) + +(define-syntax-rule (let/ec k exp...) + ;; This one appeared in Guile 2.0.9, so provide a copy here. + (let ((tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () + (let ((k (lambda args + (apply abort-to-prompt tag args)))) + exp...)) + (lambda (_ . args) + (apply values args))))) + (test-begin "nar") @@ -201,6 +225,83 @@ (lambda () (rmdir input))))) +;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn +;; relies on a Guile 2.0.10+ feature. +(test-skip (if (false-if-exception + (open-sha256-input-port (%make-void-port "r"))) + 0 + 3)) + +(test-assert "restore-file-set (signed, valid)" + (with-store store + (let* ((texts (unfold (cut >= <> 10) + (lambda _ (random-text)) + 1+ + 0)) + (files (map (cut add-text-to-store store "text" <>) texts)) + (dump (call-with-bytevector-output-port + (cut export-paths store files <>)))) + (delete-paths store files) + (and (every (negate file-exists?) files) + (let* ((source (open-bytevector-input-port dump)) + (imported (restore-file-set source))) + (and (equal? imported files) + (every (lambda (file) + (and (file-exists? file) + (valid-path? store file))) + files) + (equal? texts + (map (lambda (file) + (call-with-input-file file + get-string-all)) + files)))))))) + +(test-assert "restore-file-set (missing signature)" + (let/ec return + (with-store store + (let* ((file (add-text-to-store store "foo" "Hello, world!")) + (dump (call-with-bytevector-output-port + (cute export-paths store (list file) <> + #:sign? #f)))) + (delete-paths store (list file)) + (and (not (file-exists? file)) + (let ((source (open-bytevector-input-port dump))) + (guard (c ((nar-signature-error? c) + (let ((message (condition-message c)) + (port (nar-error-port c))) + (return + (and (string-match "lacks.*signature" message) + (string=? file (nar-error-file c)) + (eq? source port)))))) + (restore-file-set source)) + #f)))))) + +(test-assert "restore-file-set (corrupt)" + (let/ec return + (with-store store + (let* ((file (add-text-to-store store "foo" + (random-text))) + (dump (call-with-bytevector-output-port + (cute export-paths store (list file) <>)))) + (delete-paths store (list file)) + + ;; Flip a byte in the file contents. + (let* ((index 120) + (byte (bytevector-u8-ref dump index))) + (bytevector-u8-set! dump index (logxor #xff byte))) + + (and (not (file-exists? file)) + (let ((source (open-bytevector-input-port dump))) + (guard (c ((nar-invalid-hash-error? c) + (let ((message (condition-message c)) + (port (nar-error-port c))) + (return + (and (string-contains message "hash") + (string=? file (nar-error-file c)) + (eq? source port)))))) + (restore-file-set source)) + #f)))))) + (test-end "nar") diff --git a/tests/store.scm b/tests/store.scm index 4bd739e7f6..a61d449fb4 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -162,6 +162,38 @@ (equal? (valid-derivers %store o) (list (derivation-file-name d)))))) +(test-assert "topologically-sorted, one item" + (let* ((a (add-text-to-store %store "a" "a")) + (b (add-text-to-store %store "b" "b" (list a))) + (c (add-text-to-store %store "c" "c" (list b))) + (d (add-text-to-store %store "d" "d" (list c))) + (s (topologically-sorted %store (list d)))) + (equal? s (list a b c d)))) + +(test-assert "topologically-sorted, several items" + (let* ((a (add-text-to-store %store "a" "a")) + (b (add-text-to-store %store "b" "b" (list a))) + (c (add-text-to-store %store "c" "c" (list b))) + (d (add-text-to-store %store "d" "d" (list c))) + (s1 (topologically-sorted %store (list d a c b))) + (s2 (topologically-sorted %store (list b d c a b d)))) + (equal? s1 s2 (list a b c d)))) + +(test-assert "topologically-sorted, more difficult" + (let* ((a (add-text-to-store %store "a" "a")) + (b (add-text-to-store %store "b" "b" (list a))) + (c (add-text-to-store %store "c" "c" (list b))) + (d (add-text-to-store %store "d" "d" (list c))) + (w (add-text-to-store %store "w" "w")) + (x (add-text-to-store %store "x" "x" (list w))) + (y (add-text-to-store %store "y" "y" (list x d))) + (s1 (topologically-sorted %store (list y))) + (s2 (topologically-sorted %store (list c y))) + (s3 (topologically-sorted %store (cons y (references %store y))))) + (and (equal? s1 (list w x a b c d y)) + (equal? s2 (list a b c w x d y)) + (lset= string=? s1 s3)))) + (test-assert "log-file, derivation" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" @@ -389,6 +421,26 @@ Deriver: ~a~%" (pk 'corrupt-imported imported) #f))))) +(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") diff --git a/tests/utils.scm b/tests/utils.scm index 017d9170fa..b5706aa792 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -139,6 +139,36 @@ (append pids1 pids2))) (equal? (get-bytevector-all decompressed) data))))) +(test-equal "fcntl-flock" + 0 ; the child's exit status + (let ((file (open-input-file (search-path %load-path "guix.scm")))) + (fcntl-flock file 'read-lock) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + ;; Taking a read lock should be OK. + (fcntl-flock file 'read-lock) + (fcntl-flock file 'unlock) + + (catch 'flock-error + (lambda () + ;; Taking an exclusive lock should raise an exception. + (fcntl-flock file 'write-lock)) + (lambda args + (primitive-exit 0))) + (primitive-exit 1)) + (lambda () + (primitive-exit 2)))) + (pid + (match (waitpid pid) + ((_ . status) + (let ((result (status:exit-val status))) + (fcntl-flock file 'unlock) + (close-port file) + result))))))) + ;; This is actually in (guix store). (test-equal "store-path-package-name" "bash-4.2-p24" |