branch: main
commit 6a00f42a76f404f8811b767c92bf923c8428b6c7
Author: Ludovic Courtès <[email protected]>
AuthorDate: Fri Jun 14 10:13:03 2024 +0200
tests: Test the creation of build product GC roots.
* tests/database.scm (%store): New variable.
("set-build-successful! installs GC root for product"): New test.
---
tests/database.scm | 37 +++++++++++++++++++++++++++++++++++--
1 file changed, 35 insertions(+), 2 deletions(-)
diff --git a/tests/database.scm b/tests/database.scm
index c4efb0a..2c740e4 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -26,11 +26,15 @@
(cuirass parameters)
(cuirass remote)
(cuirass specification)
+ ((cuirass store)
+ #:select (%gc-root-directory))
(cuirass utils)
((cuirass logging) #:select (current-logging-level))
(tests common)
(guix channels)
- ((guix build utils) #:select (call-with-temporary-output-file))
+ ((guix store) #:select (open-connection add-text-to-store))
+ ((guix build utils)
+ #:select (call-with-temporary-output-file mkdir-p))
(rnrs io ports)
(squee)
(fibers)
@@ -145,6 +149,10 @@
(raise-exception result)
result)))
+(define %store
+ (false-if-exception (open-connection)))
+
+
(current-logging-level 'debug)
(test-group-with-cleanup "database"
@@ -849,7 +857,32 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(set-build-successful! drv)
(match (build-products (db-get-build name))
((product)
- (equal? (build-product-file product) (getcwd)))))))
+ (and (equal? (build-product-file product) (getcwd))))))))
+
+ (test-skip (if %store 0 1))
+ (test-assert "set-build-successful! installs GC root for product"
+ (with-fibers
+ (parameterize ((%gc-root-directory (mkdtemp "/tmp/cuirass-test-XXXXXX")))
+ (mkdir-p (%gc-root-directory))
+ (let* ((name "/foo6.drv")
+ (item (add-text-to-store %store "build-product.txt"
+ "Hello!"))
+ (build
+ (make-dummy-build name
+ #:outputs
+ (list (output
+ (item item)
+ (derivation "/foo6.drv")))))
+ (drv (build-derivation build)))
+ (db-add-build build)
+ (set-build-successful! drv)
+ (match (build-products (db-get-build name))
+ ((product)
+ (let ((root (string-append (%gc-root-directory) "/"
+ (basename
+ (build-product-file product)))))
+ (string=? (readlink root) item
+ (build-product-file product)))))))))
(test-assert "db-worker-current-builds"
(with-fibers
