diff options
Diffstat (limited to 'guix/tests.scm')
| -rw-r--r-- | guix/tests.scm | 73 |
1 files changed, 71 insertions, 2 deletions
diff --git a/guix/tests.scm b/guix/tests.scm index 34e3e0fc2a..f4948148c4 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,26 +17,32 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix tests) + #:use-module ((guix config) #:select (%storedir %localstatedir)) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix base32) #:use-module (guix serialization) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix build-system gnu) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (web uri) #:export (open-connection-for-tests + with-external-store random-text random-bytevector file=? + canonical-file? network-reachable? shebang-too-long? mock %test-substitute-urls + test-assertm + test-equalm %substitute-directory with-derivation-narinfo with-derivation-substitute @@ -74,6 +80,39 @@ store))) +(define (call-with-external-store proc) + "Call PROC with an open connection to the external store or #f it there is +no external store to talk to." + (parameterize ((%daemon-socket-uri + (string-append %localstatedir + "/guix/daemon-socket/socket")) + (%store-prefix %storedir)) + (define store + (catch #t + (lambda () + (open-connection)) + (const #f))) + + (dynamic-wind + (const #t) + (lambda () + ;; Since we're using a different store we must clear the + ;; package-derivation cache. + (hash-clear! (@@ (guix packages) %derivation-cache)) + + (proc store)) + (lambda () + (when store + (close-connection store)))))) + +(define-syntax-rule (with-external-store store exp ...) + "Evaluate EXP with STORE bound to the external store rather than the +temporary test store, or #f if there is no external store to talk to. + +This is meant to be used for tests that need to build packages that would be +too expensive to build entirely in the test store." + (call-with-external-store (lambda (store) exp ...))) + (define (random-seed) (or (and=> (getenv "GUIX_TESTS_RANDOM_SEED") number->string) @@ -112,6 +151,14 @@ (else (error "what?" (lstat a)))))) +(define (canonical-file? file) + "Return #t if FILE is in the store, is read-only, and its mtime is 1." + (let ((st (lstat file))) + (or (not (string-prefix? (%store-prefix) file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 (stat:mode st))))))) + (define (network-reachable?) "Return true if we can reach the Internet." (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))) @@ -126,6 +173,28 @@ given by REPLACEMENT." (lambda () body ...) (lambda () (module-set! m 'proc original))))) +(define-syntax-rule (test-assertm name exp) + "Like 'test-assert', but EXP is a monadic value. A new connection to the +store is opened." + (test-assert name + (let ((store (open-connection-for-tests))) + (dynamic-wind + (const #t) + (lambda () + (run-with-store store exp + #:guile-for-build (%guile-for-build))) + (lambda () + (close-connection store)))))) + +(define-syntax-rule (test-equalm name value exp) + "Like 'test-equal', but EXP is a monadic value. A new connection to the +store is opened." + (test-equal name + value + (with-store store + (run-with-store store exp + #:guile-for-build (%guile-for-build))))) + ;;; ;;; Narinfo files, as used by the substituter. |