diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/challenge.scm | 96 | ||||
| -rw-r--r-- | tests/guix-archive.sh | 7 | ||||
| -rw-r--r-- | tests/nar.scm | 74 |
3 files changed, 175 insertions, 2 deletions
diff --git a/tests/challenge.scm b/tests/challenge.scm index c962800f3f..bb5633a3eb 100644 --- a/tests/challenge.scm +++ b/tests/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,22 +18,33 @@ (define-module (test-challenge) #:use-module (guix tests) + #:use-module (guix tests http) #:use-module (gcrypt hash) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) + #:use-module (guix serialization) + #:use-module (guix packages) #:use-module (guix gexp) + #:use-module (guix base32) #:use-module (guix scripts challenge) #:use-module (guix scripts substitute) + #:use-module ((guix build utils) #:select (find-files)) + #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) #:use-module (ice-9 match)) (define query-path-hash* (store-lift query-path-hash)) +(define (query-path-size item) + (mlet %store-monad ((info (query-path-info* item))) + (return (path-info-nar-size info)))) + (define* (call-with-derivation-narinfo* drv thunk hash) (lambda (store) (with-derivation-narinfo drv (sha256 => hash) @@ -138,7 +149,90 @@ (bytevector=? (narinfo-hash->sha256 (narinfo-hash narinfo)) hash)))))))))))) +(define (make-narinfo item size hash) + (format #f "StorePath: ~a +Compression: none +URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo +NarSize: ~d +NarHash: sha256:~a +References: ~%" item size (bytevector->nix-base32-string hash))) + +(define (call-mismatch-test proc) + "Pass PROC a <comparison-report> for a mismatch and return its return +value." + + ;; Pretend we have two different results for the same store item, ITEM, with + ;; "/bin/guile" differing between the two nars. + (mlet* %store-monad + ((drv1 (package->derivation %bootstrap-guile)) + (drv2 (gexp->derivation + "broken-guile" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (copy-recursively #$drv1 #$output) + (chmod (string-append #$output "/bin/guile") + #o755) + (call-with-output-file (string-append + #$output + "/bin/guile") + (lambda (port) + (display "corrupt!" port))))))) + (out1 -> (derivation->output-path drv1)) + (out2 -> (derivation->output-path drv2)) + (item -> (string-append (%store-prefix) "/" + (bytevector->nix-base32-string + (random-bytevector 32)) + "-foo" + (number->string (current-time) 16)))) + (mbegin %store-monad + (built-derivations (list drv1 drv2)) + (mlet* %store-monad ((size1 (query-path-size out1)) + (size2 (query-path-size out2)) + (hash1 (query-path-hash* out1)) + (hash2 (query-path-hash* out2)) + (nar1 -> (call-with-bytevector-output-port + (lambda (port) + (write-file out1 port)))) + (nar2 -> (call-with-bytevector-output-port + (lambda (port) + (write-file out2 port))))) + (parameterize ((%http-server-port 9000)) + (with-http-server `((200 ,(make-narinfo item size1 hash1)) + (200 ,nar1)) + (parameterize ((%http-server-port 9001)) + (with-http-server `((200 ,(make-narinfo item size2 hash2)) + (200 ,nar2)) + (mlet* %store-monad ((urls -> (list (%local-url 9000) + (%local-url 9001))) + (reports (compare-contents (list item) + urls))) + (pk 'report reports) + (return (proc (car reports)))))))))))) + +(test-assertm "differing-files" + (call-mismatch-test + (lambda (report) + (equal? (differing-files report) '("/bin/guile"))))) +(test-assertm "call-with-mismatches" + (call-mismatch-test + (lambda (report) + (call-with-mismatches + report + (lambda (directory1 directory2) + (let* ((files1 (find-files directory1)) + (files2 (find-files directory2)) + (files (map (cute string-drop <> (string-length directory1)) + files1))) + (and (equal? files + (map (cute string-drop <> (string-length directory2)) + files2)) + (equal? (remove (lambda (file) + (file=? (string-append directory1 "/" file) + (string-append directory2 "/" file))) + files) + '("/bin/guile"))))))))) (test-end) diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh index fdaeb98ad2..4c5eea05cf 100644 --- a/tests/guix-archive.sh +++ b/tests/guix-archive.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -74,5 +74,10 @@ guix archive -x "$tmpdir" < "$archive" test -x "$tmpdir/bin/guile" test -d "$tmpdir/lib/guile" +# Check '--list'. +guix archive -t < "$archive" | grep "^D /share/guile" +guix archive -t < "$archive" | grep "^x /bin/guile" +guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm" + if echo foo | guix archive --authorize then false; else true; fi diff --git a/tests/nar.scm b/tests/nar.scm index bfc71c69a8..aeff3d3330 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -214,6 +214,80 @@ (lambda () (false-if-exception (rm-rf %test-dir)))))) +(test-equal "write-file-tree + fold-archive" + '(("R" directory #f) + ("R/dir" directory #f) + ("R/dir/exe" executable "1234") + ("R/foo" regular "abcdefg") + ("R/lnk" symlink "foo")) + + (let () + (define-values (port get-bytevector) + (open-bytevector-output-port)) + (write-file-tree "root" port + #:file-type+size + (match-lambda + ("root" + (values 'directory 0)) + ("root/foo" + (values 'regular 7)) + ("root/lnk" + (values 'symlink 0)) + ("root/dir" + (values 'directory 0)) + ("root/dir/exe" + (values 'executable 4))) + #:file-port + (match-lambda + ("root/foo" (open-input-string "abcdefg")) + ("root/dir/exe" (open-input-string "1234"))) + #:symlink-target + (match-lambda + ("root/lnk" "foo")) + #:directory-entries + (match-lambda + ("root" '("foo" "dir" "lnk")) + ("root/dir" '("exe")))) + (close-port port) + + (reverse + (fold-archive (lambda (file type contents result) + (let ((contents (if (memq type '(regular executable)) + (utf8->string + (get-bytevector-n (car contents) + (cdr contents))) + contents))) + (cons `(,file ,type ,contents) + result))) + '() + (open-bytevector-input-port (get-bytevector)) + "R")))) + +(test-equal "write-file-tree + fold-archive, flat file" + '(("R" regular "abcdefg")) + + (let () + (define-values (port get-bytevector) + (open-bytevector-output-port)) + (write-file-tree "root" port + #:file-type+size + (match-lambda + ("root" (values 'regular 7))) + #:file-port + (match-lambda + ("root" (open-input-string "abcdefg")))) + (close-port port) + + (reverse + (fold-archive (lambda (file type contents result) + (let ((contents (utf8->string + (get-bytevector-n (car contents) + (cdr contents))))) + (cons `(,file ,type ,contents) result))) + '() + (open-bytevector-input-port (get-bytevector)) + "R")))) + (test-assert "write-file supports non-file output ports" (let ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) |