;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (test-store)
#:use-module (guix tests)
+ #:use-module (guix config)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix monads)
"/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
(not (direct-store-path? (%store-prefix)))))
-(test-skip (if %store 0 13))
+(test-skip (if %store 0 15))
+
+(test-equal "profiles/per-user exists and is not writable"
+ #o755
+ (stat:perms (stat (string-append %state-directory "/profiles/per-user"))))
+
+(test-equal "profiles/per-user/$USER exists"
+ (list (getuid) #o755)
+ (let ((s (stat (string-append %state-directory "/profiles/per-user/"
+ (passwd:name (getpwuid (getuid)))))))
+ (list (stat:uid s) (stat:perms s))))
(test-equal "add-data-to-store"
#vu8(1 2 3 4 5)
(equal? (valid-derivers %store o)
(list (derivation-file-name d))))))
+(test-equal "with-build-handler"
+ 'success
+ (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
+ (s (add-to-store %store "bash" #t "sha256"
+ (search-bootstrap-binary "bash"
+ (%current-system))))
+ (d1 (derivation %store "the-thing"
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text)))
+ #:sources (list b s)))
+ (d2 (derivation %store "the-thing"
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text))
+ ("bar" . "baz"))
+ #:sources (list b s)))
+ (o1 (derivation->output-path d1))
+ (o2 (derivation->output-path d2)))
+ (with-build-handler
+ (let ((counter 0))
+ (lambda (continue store things mode)
+ (match things
+ ((drv)
+ (set! counter (+ 1 counter))
+ (if (string=? drv (derivation-file-name d1))
+ (continue #t)
+ (and (string=? drv (derivation-file-name d2))
+ (= counter 2)
+ 'success))))))
+ (build-derivations %store (list d1))
+ (build-derivations %store (list d2))
+ 'fail)))
+
+(test-equal "with-build-handler + with-store"
+ 'success
+ ;; Check that STORE remains valid when the build handler invokes CONTINUE,
+ ;; even though 'with-build-handler' is outside the dynamic extent of
+ ;; 'with-store'.
+ (with-build-handler (lambda (continue store things mode)
+ (match things
+ ((drv)
+ (and (string-suffix? "thingie.drv" drv)
+ (not (port-closed?
+ (store-connection-socket store)))
+ (continue #t)))))
+ (with-store store
+ (let* ((b (add-text-to-store store "build" "echo $foo > $out" '()))
+ (s (add-to-store store "bash" #t "sha256"
+ (search-bootstrap-binary "bash"
+ (%current-system))))
+ (d (derivation store "thingie"
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text)))
+ #:sources (list b s))))
+ (build-derivations store (list d))
+
+ ;; Here STORE's socket should still be open.
+ (and (valid-path? store (derivation->output-path d))
+ 'success)))))
+
+(test-assert "map/accumulate-builds"
+ (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
+ (s (add-to-store %store "bash" #t "sha256"
+ (search-bootstrap-binary "bash"
+ (%current-system))))
+ (d1 (derivation %store "the-thing"
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text)))
+ #:sources (list b s)))
+ (d2 (derivation %store "the-thing"
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text))
+ ("bar" . "baz"))
+ #:sources (list b s))))
+ (with-build-handler (lambda (continue store things mode)
+ (equal? (map derivation-file-name (list d1 d2))
+ things))
+ (map/accumulate-builds %store
+ (lambda (drv)
+ (build-derivations %store (list drv))
+ (add-to-store %store "content-addressed"
+ #t "sha256"
+ (derivation->output-path drv)))
+ (list d1 d2)))))
+
+(test-assert "mapm/accumulate-builds"
+ (let* ((d1 (run-with-store %store
+ (gexp->derivation "foo" #~(mkdir #$output))))
+ (d2 (run-with-store %store
+ (gexp->derivation "bar" #~(mkdir #$output)))))
+ (with-build-handler (lambda (continue store things mode)
+ (equal? (map derivation-file-name (pk 'zz (list d1 d2)))
+ (pk 'XX things)))
+ (run-with-store %store
+ (mapm/accumulate-builds built-derivations `((,d1) (,d2)))))))
+
(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)))
(valid-path? s o)
(equal? c (call-with-input-file o get-string-all)))))))
+(test-assert "substitute + build-things with specific output"
+ (with-store s
+ (let* ((c (random-text)) ;contents of the output
+ (d (build-expression->derivation
+ s "substitute-me" `(begin ,c (exit 1)) ;would fail
+ #:outputs '("out" "one" "two")
+ #:guile-for-build
+ (package-derivation s %bootstrap-guile (%current-system))))
+ (o (derivation->output-path d)))
+ (with-derivation-substitute d c
+ (set-build-options s #:use-substitutes? #t
+ #:substitute-urls (%test-substitute-urls))
+ (and (has-substitutes? s o)
+
+ ;; Ask for nothing but the "out" output of D.
+ (build-things s `((,(derivation-file-name d) . "out")))
+
+ (valid-path? s o)
+ (equal? c (call-with-input-file o get-string-all)))))))
+
(test-assert "substitute, corrupt output hash"
;; Tweak the substituter into installing a substitute whose hash doesn't
;; match the one announced in the narinfo. The daemon must notice this and
(build-mode check))
#f))))))))
+(test-assert "build-succeeded trace in check mode"
+ (string-contains
+ (call-with-output-string
+ (lambda (port)
+ (let ((d (build-expression->derivation
+ %store "foo" '(mkdir (assoc-ref %outputs "out"))
+ #:guile-for-build
+ (package-derivation %store %bootstrap-guile))))
+ (build-derivations %store (list d))
+ (parameterize ((current-build-output-port port))
+ (build-derivations %store (list d) (build-mode check))))))
+ "@ build-succeeded"))
+
(test-assert "build multiple times"
(with-store store
;; Ask to build twice.