aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/derivations.scm14
-rw-r--r--tests/store.scm22
-rw-r--r--tests/utils.scm87
3 files changed, 103 insertions, 20 deletions
diff --git a/tests/derivations.scm b/tests/derivations.scm
index f31b00b8a2..e87662a198 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -446,6 +446,20 @@
(build-derivations store (list drv))
#f)))
+(test-assert "build-expression->derivation and timeout"
+ (let* ((store (let ((s (open-connection)))
+ (set-build-options s #:timeout 1)
+ s))
+ (builder '(begin (sleep 100) (mkdir %output) #t))
+ (drv (build-expression->derivation store "slow" builder))
+ (out-path (derivation->output-path drv)))
+ (guard (c ((nix-protocol-error? c)
+ (and (string-contains (nix-protocol-error-message c)
+ "failed")
+ (not (valid-path? store out-path)))))
+ (build-derivations store (list drv))
+ #f)))
+
(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
(let ((drv (build-expression->derivation %store "fail" #f)))
;; The only direct dependency is (%guile-for-build) and it's already
diff --git a/tests/store.scm b/tests/store.scm
index 7b0f3249d2..8a25c7353b 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -190,9 +190,18 @@
(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))))
+ ;; The order in which 'references' returns the references of Y is
+ ;; unspecified, so accommodate.
+ (let* ((x-then-d? (equal? (references %store y) (list x d))))
+ (and (equal? s1
+ (if x-then-d?
+ (list w x a b c d y)
+ (list a b c d w x y)))
+ (equal? s2
+ (if x-then-d?
+ (list a b c w x d y)
+ (list a b c d w x y)))
+ (lset= string=? s1 s3)))))
(test-assert "log-file, derivation"
(let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
@@ -399,7 +408,9 @@ Deriver: ~a~%"
files)))))))
(test-assert "export/import paths, ensure topological order"
- (let* ((file1 (add-text-to-store %store "foo" (random-text)))
+ (let* ((file0 (add-text-to-store %store "baz" (random-text)))
+ (file1 (add-text-to-store %store "foo" (random-text)
+ (list file0)))
(file2 (add-text-to-store %store "bar" (random-text)
(list file1)))
(files (list file1 file2))
@@ -412,9 +423,10 @@ Deriver: ~a~%"
(bytevector=? dump1 dump2)
(let* ((source (open-bytevector-input-port dump1))
(imported (import-paths %store source)))
+ ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
(and (equal? imported (list file1 file2))
(every file-exists? files)
- (null? (references %store file1))
+ (equal? (list file0) (references %store file1))
(equal? (list file1) (references %store file2)))))))
(test-assert "import corrupt path"
diff --git a/tests/utils.scm b/tests/utils.scm
index b5706aa792..adac5d4381 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -27,6 +27,9 @@
#:use-module (rnrs io ports)
#:use-module (ice-9 match))
+(define temp-file
+ (string-append "t-utils-" (number->string (getpid))))
+
(test-begin "utils")
(test-assert "bytevector->base16-string->bytevector"
@@ -139,36 +142,88 @@
(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)
+(false-if-exception (delete-file temp-file))
+(test-equal "fcntl-flock wait"
+ 42 ; the child's exit status
+ (let ((file (open-file temp-file "w0")))
+ ;; Acquire an exclusive lock.
+ (fcntl-flock file 'write-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)))
+ ;; Reopen FILE read-only so we can have a read lock.
+ (let ((file (open-file temp-file "r")))
+ ;; Wait until we can acquire the lock.
+ (fcntl-flock file 'read-lock)
+ (primitive-exit (read file)))
(primitive-exit 1))
(lambda ()
(primitive-exit 2))))
(pid
+ ;; Write garbage and wait.
+ (display "hello, world!" file)
+ (force-output file)
+ (sleep 1)
+
+ ;; Write the real answer.
+ (seek file 0 SEEK_SET)
+ (truncate-file file 0)
+ (write 42 file)
+ (force-output file)
+
+ ;; Unlock, which should let the child continue.
+ (fcntl-flock file 'unlock)
+
(match (waitpid pid)
((_ . status)
(let ((result (status:exit-val status)))
- (fcntl-flock file 'unlock)
(close-port file)
result)))))))
+(test-equal "fcntl-flock non-blocking"
+ EAGAIN ; the child's exit status
+ (match (pipe)
+ ((input . output)
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (close-port output)
+
+ ;; Wait for the green light.
+ (read-char input)
+
+ ;; Open FILE read-only so we can have a read lock.
+ (let ((file (open-file temp-file "w")))
+ (catch 'flock-error
+ (lambda ()
+ ;; This attempt should throw EAGAIN.
+ (fcntl-flock file 'write-lock #:wait? #f))
+ (lambda (key errno)
+ (primitive-exit errno))))
+ (primitive-exit -1))
+ (lambda ()
+ (primitive-exit -2))))
+ (pid
+ (close-port input)
+ (let ((file (open-file temp-file "w")))
+ ;; Acquire an exclusive lock.
+ (fcntl-flock file 'write-lock)
+
+ ;; Tell the child to continue.
+ (write 'green-light output)
+ (force-output output)
+
+ (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"
@@ -178,5 +233,7 @@
(test-end)
+(false-if-exception (delete-file temp-file))
+
(exit (= (test-runner-fail-count (test-runner-current)) 0))