You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

1162 lines
51 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (test-store)
  19. #:use-module (guix tests)
  20. #:use-module (guix config)
  21. #:use-module (guix store)
  22. #:use-module (guix utils)
  23. #:use-module (guix monads)
  24. #:use-module (gcrypt hash)
  25. #:use-module (guix base32)
  26. #:use-module (guix packages)
  27. #:use-module (guix derivations)
  28. #:use-module (guix serialization)
  29. #:use-module (guix build utils)
  30. #:use-module (guix gexp)
  31. #:use-module (gnu packages)
  32. #:use-module (gnu packages bootstrap)
  33. #:use-module (ice-9 match)
  34. #:use-module (ice-9 regex)
  35. #:use-module (rnrs bytevectors)
  36. #:use-module (rnrs io ports)
  37. #:use-module (web uri)
  38. #:use-module (srfi srfi-1)
  39. #:use-module (srfi srfi-11)
  40. #:use-module (srfi srfi-26)
  41. #:use-module (srfi srfi-34)
  42. #:use-module (srfi srfi-64))
  43. ;; Test the (guix store) module.
  44. (define %store
  45. (open-connection-for-tests))
  46. (define %shell
  47. (or (getenv "SHELL") (getenv "CONFIG_SHELL")))
  48. (test-begin "store")
  49. (test-assert "open-connection with file:// URI"
  50. (let ((store (open-connection (string-append "file://"
  51. (%daemon-socket-uri)))))
  52. (and (add-text-to-store store "foo" "bar")
  53. (begin
  54. (close-connection store)
  55. #t))))
  56. (test-equal "connection handshake error"
  57. EPROTO
  58. (let ((port (%make-void-port "rw")))
  59. (guard (c ((store-connection-error? c)
  60. (and (eq? port (store-connection-error-file c))
  61. (store-connection-error-code c))))
  62. (open-connection #f #:port port)
  63. 'broken)))
  64. (test-equal "store-path-hash-part"
  65. "283gqy39v3g9dxjy26rynl0zls82fmcg"
  66. (store-path-hash-part
  67. (string-append (%store-prefix)
  68. "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  69. (test-equal "store-path-hash-part #f"
  70. #f
  71. (store-path-hash-part
  72. (string-append (%store-prefix)
  73. "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  74. (test-equal "store-path-package-name"
  75. "guile-2.0.7"
  76. (store-path-package-name
  77. (string-append (%store-prefix)
  78. "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  79. (test-equal "store-path-package-name #f"
  80. #f
  81. (store-path-package-name
  82. "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
  83. (test-assert "direct-store-path?"
  84. (and (direct-store-path?
  85. (string-append (%store-prefix)
  86. "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
  87. (not (direct-store-path?
  88. (string-append
  89. (%store-prefix)
  90. "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
  91. (not (direct-store-path? (%store-prefix)))))
  92. (test-skip (if %store 0 15))
  93. (test-equal "profiles/per-user exists and is not writable"
  94. #o755
  95. (stat:perms (stat (string-append %state-directory "/profiles/per-user"))))
  96. (test-equal "profiles/per-user/$USER exists"
  97. (list (getuid) #o755)
  98. (let ((s (stat (string-append %state-directory "/profiles/per-user/"
  99. (passwd:name (getpwuid (getuid)))))))
  100. (list (stat:uid s) (stat:perms s))))
  101. (test-equal "add-data-to-store"
  102. #vu8(1 2 3 4 5)
  103. (call-with-input-file (add-data-to-store %store "data" #vu8(1 2 3 4 5))
  104. get-bytevector-all))
  105. (test-assert "valid-path? live"
  106. (let ((p (add-text-to-store %store "hello" "hello, world")))
  107. (valid-path? %store p)))
  108. (test-assert "valid-path? false"
  109. (not (valid-path? %store
  110. (string-append (%store-prefix) "/"
  111. (make-string 32 #\e) "-foobar"))))
  112. (test-assert "valid-path? error"
  113. (with-store s
  114. (guard (c ((store-protocol-error? c) #t))
  115. (valid-path? s "foo")
  116. #f)))
  117. (test-assert "valid-path? recovery"
  118. ;; Prior to Nix commit 51800e0 (18 Mar. 2014), the daemon would immediately
  119. ;; close the connection after receiving a 'valid-path?' RPC with a non-store
  120. ;; file name. See
  121. ;; <http://article.gmane.org/gmane.linux.distributions.nixos/12411> for
  122. ;; details.
  123. (with-store s
  124. (let-syntax ((true-if-error (syntax-rules ()
  125. ((_ exp)
  126. (guard (c ((store-protocol-error? c) #t))
  127. exp #f)))))
  128. (and (true-if-error (valid-path? s "foo"))
  129. (true-if-error (valid-path? s "bar"))
  130. (true-if-error (valid-path? s "baz"))
  131. (true-if-error (valid-path? s "chbouib"))
  132. (valid-path? s (add-text-to-store s "valid" "yeah"))))))
  133. (test-assert "hash-part->path"
  134. (let ((p (add-text-to-store %store "hello" "hello, world")))
  135. (equal? (hash-part->path %store (store-path-hash-part p))
  136. p)))
  137. (test-assert "dead-paths"
  138. (let ((p (add-text-to-store %store "random-text" (random-text))))
  139. (->bool (member p (dead-paths %store)))))
  140. ;; FIXME: Find a test for `live-paths'.
  141. ;;
  142. ;; (test-assert "temporary root is in live-paths"
  143. ;; (let* ((p1 (add-text-to-store %store "random-text"
  144. ;; (random-text) '()))
  145. ;; (b (add-text-to-store %store "link-builder"
  146. ;; (format #f "echo ~a > $out" p1)
  147. ;; '()))
  148. ;; (d1 (derivation %store "link"
  149. ;; "/bin/sh" `("-e" ,b)
  150. ;; #:inputs `((,b) (,p1))))
  151. ;; (p2 (derivation->output-path d1)))
  152. ;; (and (add-temp-root %store p2)
  153. ;; (build-derivations %store (list d1))
  154. ;; (valid-path? %store p1)
  155. ;; (member (pk p2) (live-paths %store)))))
  156. (test-assert "permanent root"
  157. (let* ((p (with-store store
  158. (let ((p (add-text-to-store store "random-text"
  159. (random-text))))
  160. (add-permanent-root p)
  161. (add-permanent-root p) ; should not throw
  162. p))))
  163. (and (member p (live-paths %store))
  164. (begin
  165. (remove-permanent-root p)
  166. (->bool (member p (dead-paths %store)))))))
  167. (test-assert "dead path can be explicitly collected"
  168. (let ((p (add-text-to-store %store "random-text"
  169. (random-text) '())))
  170. (let-values (((paths freed) (delete-paths %store (list p))))
  171. (and (equal? paths (list p))
  172. ;; XXX: On some file systems (notably Btrfs), freed
  173. ;; may return 0. See <https://bugs.gnu.org/29363>.
  174. ;;(> freed 0)
  175. (not (file-exists? p))))))
  176. (test-assert "add-text-to-store vs. delete-paths"
  177. ;; Before, 'add-text-to-store' would return PATH2 without noticing that it
  178. ;; is no longer valid.
  179. (with-store store
  180. (let* ((text (random-text))
  181. (path (add-text-to-store store "delete-me" text))
  182. (deleted (delete-paths store (list path)))
  183. (path2 (add-text-to-store store "delete-me" text)))
  184. (and (string=? path path2)
  185. (equal? deleted (list path))
  186. (valid-path? store path)
  187. (file-exists? path)))))
  188. (test-assert "add-to-store vs. delete-paths"
  189. ;; Same as above.
  190. (with-store store
  191. (let* ((file (search-path %load-path "guix.scm"))
  192. (path (add-to-store store "delete-me" #t "sha256" file))
  193. (deleted (delete-paths store (list path)))
  194. (path2 (add-to-store store "delete-me" #t "sha256" file)))
  195. (and (string=? path path2)
  196. (equal? deleted (list path))
  197. (valid-path? store path)
  198. (file-exists? path)))))
  199. (test-equal "add-file-tree-to-store"
  200. `(42
  201. ("." directory #t)
  202. ("./bar" directory #t)
  203. ("./foo" directory #t)
  204. ("./foo/a" regular "file a")
  205. ("./foo/b" symlink "a")
  206. ("./foo/c" directory #t)
  207. ("./foo/c/p" regular "file p")
  208. ("./foo/c/q" directory #t)
  209. ("./foo/c/q/x" regular
  210. ,(string-append "#!" %shell "\nexit 42"))
  211. ("./foo/c/q/y" symlink "..")
  212. ("./foo/c/q/z" directory #t))
  213. (let* ((tree `("file-tree" directory
  214. ("foo" directory
  215. ("a" regular (data "file a"))
  216. ("b" symlink "a")
  217. ("c" directory
  218. ("p" regular (data ,(string->utf8 "file p")))
  219. ("q" directory
  220. ("x" executable
  221. (data ,(string-append "#!" %shell "\nexit 42")))
  222. ("y" symlink "..")
  223. ("z" directory))))
  224. ("bar" directory)))
  225. (result (add-file-tree-to-store %store tree)))
  226. (cons (status:exit-val (system* (string-append result "/foo/c/q/x")))
  227. (with-directory-excursion result
  228. (map (lambda (file)
  229. (let ((type (stat:type (lstat file))))
  230. `(,file ,type
  231. ,(match type
  232. ((or 'regular 'executable)
  233. (call-with-input-file file
  234. get-string-all))
  235. ('symlink (readlink file))
  236. ('directory #t)))))
  237. (find-files "." #:directories? #t))))))
  238. (test-equal "add-file-tree-to-store, flat"
  239. "Hello, world!"
  240. (let* ((tree `("flat-file" regular (data "Hello, world!")))
  241. (result (add-file-tree-to-store %store tree)))
  242. (and (file-exists? result)
  243. (call-with-input-file result get-string-all))))
  244. (test-assert "references"
  245. (let* ((t1 (add-text-to-store %store "random1"
  246. (random-text)))
  247. (t2 (add-text-to-store %store "random2"
  248. (random-text) (list t1))))
  249. (and (equal? (list t1) (references %store t2))
  250. (equal? (list t2) (referrers %store t1))
  251. (null? (references %store t1))
  252. (null? (referrers %store t2)))))
  253. (test-assert "references/substitutes missing reference info"
  254. (with-store s
  255. (set-build-options s #:use-substitutes? #f)
  256. (guard (c ((store-protocol-error? c) #t))
  257. (let* ((b (add-to-store s "bash" #t "sha256"
  258. (search-bootstrap-binary "bash"
  259. (%current-system))))
  260. (d (derivation s "the-thing" b '("--help")
  261. #:inputs `((,b)))))
  262. (references/substitutes s (list (derivation->output-path d) b))
  263. #f))))
  264. (test-assert "references/substitutes with substitute info"
  265. (with-store s
  266. (set-build-options s #:use-substitutes? #t)
  267. (let* ((t1 (add-text-to-store s "random1" (random-text)))
  268. (t2 (add-text-to-store s "random2" (random-text)
  269. (list t1)))
  270. (t3 (add-text-to-store s "build" "echo -n $t2 > $out"))
  271. (b (add-to-store s "bash" #t "sha256"
  272. (search-bootstrap-binary "bash"
  273. (%current-system))))
  274. (d (derivation s "the-thing" b `("-e" ,t3)
  275. #:inputs `((,b) (,t3) (,t2))
  276. #:env-vars `(("t2" . ,t2))))
  277. (o (derivation->output-path d)))
  278. (with-derivation-narinfo d
  279. (sha256 => (sha256 (string->utf8 t2)))
  280. (references => (list t2))
  281. (equal? (references/substitutes s (list o t3 t2 t1))
  282. `((,t2) ;refs of O
  283. () ;refs of T3
  284. (,t1) ;refs of T2
  285. ())))))) ;refs of T1
  286. (test-equal "substitutable-path-info when substitutes are turned off"
  287. '()
  288. (with-store s
  289. (set-build-options s #:use-substitutes? #f)
  290. (let* ((b (add-to-store s "bash" #t "sha256"
  291. (search-bootstrap-binary "bash"
  292. (%current-system))))
  293. (d (derivation s "the-thing" b '("--version")
  294. #:inputs `((,b))))
  295. (o (derivation->output-path d)))
  296. (with-derivation-narinfo d
  297. (substitutable-path-info s (list o))))))
  298. (test-equal "substitutable-paths when substitutes are turned off"
  299. '()
  300. (with-store s
  301. (set-build-options s #:use-substitutes? #f)
  302. (let* ((b (add-to-store s "bash" #t "sha256"
  303. (search-bootstrap-binary "bash"
  304. (%current-system))))
  305. (d (derivation s "the-thing" b '("--version")
  306. #:inputs `((,b))))
  307. (o (derivation->output-path d)))
  308. (with-derivation-narinfo d
  309. (substitutable-paths s (list o))))))
  310. (test-assert "requisites"
  311. (let* ((t1 (add-text-to-store %store "random1"
  312. (random-text) '()))
  313. (t2 (add-text-to-store %store "random2"
  314. (random-text) (list t1)))
  315. (t3 (add-text-to-store %store "random3"
  316. (random-text) (list t2)))
  317. (t4 (add-text-to-store %store "random4"
  318. (random-text) (list t1 t3))))
  319. (define (same? x y)
  320. (and (= (length x) (length y))
  321. (lset= equal? x y)))
  322. (and (same? (requisites %store (list t1)) (list t1))
  323. (same? (requisites %store (list t2)) (list t1 t2))
  324. (same? (requisites %store (list t3)) (list t1 t2 t3))
  325. (same? (requisites %store (list t4)) (list t1 t2 t3 t4))
  326. (same? (requisites %store (list t1 t2 t3 t4))
  327. (list t1 t2 t3 t4)))))
  328. (test-assert "derivers"
  329. (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
  330. (s (add-to-store %store "bash" #t "sha256"
  331. (search-bootstrap-binary "bash"
  332. (%current-system))))
  333. (d (derivation %store "the-thing"
  334. s `("-e" ,b)
  335. #:env-vars `(("foo" . ,(random-text)))
  336. #:inputs `((,b) (,s))))
  337. (o (derivation->output-path d)))
  338. (and (build-derivations %store (list d))
  339. (equal? (query-derivation-outputs %store (derivation-file-name d))
  340. (list o))
  341. (equal? (valid-derivers %store o)
  342. (list (derivation-file-name d))))))
  343. (test-equal "with-build-handler"
  344. 'success
  345. (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
  346. (s (add-to-store %store "bash" #t "sha256"
  347. (search-bootstrap-binary "bash"
  348. (%current-system))))
  349. (d1 (derivation %store "the-thing"
  350. s `("-e" ,b)
  351. #:env-vars `(("foo" . ,(random-text)))
  352. #:sources (list b s)))
  353. (d2 (derivation %store "the-thing"
  354. s `("-e" ,b)
  355. #:env-vars `(("foo" . ,(random-text))
  356. ("bar" . "baz"))
  357. #:sources (list b s)))
  358. (o1 (derivation->output-path d1))
  359. (o2 (derivation->output-path d2)))
  360. (with-build-handler
  361. (let ((counter 0))
  362. (lambda (continue store things mode)
  363. (match things
  364. ((drv)
  365. (set! counter (+ 1 counter))
  366. (if (string=? drv (derivation-file-name d1))
  367. (continue #t)
  368. (and (string=? drv (derivation-file-name d2))
  369. (= counter 2)
  370. 'success))))))
  371. (build-derivations %store (list d1))
  372. (build-derivations %store (list d2))
  373. 'fail)))
  374. (test-assert "topologically-sorted, one item"
  375. (let* ((a (add-text-to-store %store "a" "a"))
  376. (b (add-text-to-store %store "b" "b" (list a)))
  377. (c (add-text-to-store %store "c" "c" (list b)))
  378. (d (add-text-to-store %store "d" "d" (list c)))
  379. (s (topologically-sorted %store (list d))))
  380. (equal? s (list a b c d))))
  381. (test-assert "topologically-sorted, several items"
  382. (let* ((a (add-text-to-store %store "a" "a"))
  383. (b (add-text-to-store %store "b" "b" (list a)))
  384. (c (add-text-to-store %store "c" "c" (list b)))
  385. (d (add-text-to-store %store "d" "d" (list c)))
  386. (s1 (topologically-sorted %store (list d a c b)))
  387. (s2 (topologically-sorted %store (list b d c a b d))))
  388. (equal? s1 s2 (list a b c d))))
  389. (test-assert "topologically-sorted, more difficult"
  390. (let* ((a (add-text-to-store %store "a" "a"))
  391. (b (add-text-to-store %store "b" "b" (list a)))
  392. (c (add-text-to-store %store "c" "c" (list b)))
  393. (d (add-text-to-store %store "d" "d" (list c)))
  394. (w (add-text-to-store %store "w" "w"))
  395. (x (add-text-to-store %store "x" "x" (list w)))
  396. (y (add-text-to-store %store "y" "y" (list x d)))
  397. (s1 (topologically-sorted %store (list y)))
  398. (s2 (topologically-sorted %store (list c y)))
  399. (s3 (topologically-sorted %store (cons y (references %store y)))))
  400. ;; The order in which 'references' returns the references of Y is
  401. ;; unspecified, so accommodate.
  402. (let* ((x-then-d? (equal? (references %store y) (list x d))))
  403. (and (equal? s1
  404. (if x-then-d?
  405. (list w x a b c d y)
  406. (list a b c d w x y)))
  407. (equal? s2
  408. (if x-then-d?
  409. (list a b c w x d y)
  410. (list a b c d w x y)))
  411. (lset= string=? s1 s3)))))
  412. (test-assert "current-build-output-port, UTF-8"
  413. ;; Are UTF-8 strings in the build log properly interpreted?
  414. (string-contains
  415. (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
  416. (call-with-output-string
  417. (lambda (port)
  418. (parameterize ((current-build-output-port port))
  419. (let* ((s "Here’s a Greek letter: λ.")
  420. (d (build-expression->derivation
  421. %store "foo" `(display ,s)
  422. #:guile-for-build
  423. (package-derivation s %bootstrap-guile (%current-system)))))
  424. (guard (c ((store-protocol-error? c) #t))
  425. (build-derivations %store (list d))))))))
  426. "Here’s a Greek letter: λ."))
  427. (test-assert "current-build-output-port, UTF-8 + garbage"
  428. ;; What about a mixture of UTF-8 + garbage?
  429. (string-contains
  430. (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
  431. (call-with-output-string
  432. (lambda (port)
  433. (parameterize ((current-build-output-port port))
  434. (let ((d (build-expression->derivation
  435. %store "foo"
  436. `(begin
  437. (use-modules (rnrs io ports))
  438. (display "garbage: ")
  439. (put-bytevector (current-output-port) #vu8(128))
  440. (display "lambda: λ\n"))
  441. #:guile-for-build
  442. (package-derivation %store %bootstrap-guile))))
  443. (guard (c ((store-protocol-error? c) #t))
  444. (build-derivations %store (list d))))))))
  445. "garbage: �lambda: λ"))
  446. (test-assert "log-file, derivation"
  447. (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
  448. (s (add-to-store %store "bash" #t "sha256"
  449. (search-bootstrap-binary "bash"
  450. (%current-system))))
  451. (d (derivation %store "the-thing"
  452. s `("-e" ,b)
  453. #:env-vars `(("foo" . ,(random-text)))
  454. #:inputs `((,b) (,s)))))
  455. (and (build-derivations %store (list d))
  456. (file-exists? (pk (log-file %store (derivation-file-name d)))))))
  457. (test-assert "log-file, output file name"
  458. (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
  459. (s (add-to-store %store "bash" #t "sha256"
  460. (search-bootstrap-binary "bash"
  461. (%current-system))))
  462. (d (derivation %store "the-thing"
  463. s `("-e" ,b)
  464. #:env-vars `(("foo" . ,(random-text)))
  465. #:inputs `((,b) (,s))))
  466. (o (derivation->output-path d)))
  467. (and (build-derivations %store (list d))
  468. (file-exists? (pk (log-file %store o)))
  469. (string=? (log-file %store (derivation-file-name d))
  470. (log-file %store o)))))
  471. (test-assert "no substitutes"
  472. (with-store s
  473. (let* ((d1 (package-derivation s %bootstrap-guile (%current-system)))
  474. (d2 (package-derivation s %bootstrap-glibc (%current-system)))
  475. (o (map derivation->output-path (list d1 d2))))
  476. (set-build-options s #:use-substitutes? #f)
  477. (and (not (has-substitutes? s (derivation-file-name d1)))
  478. (not (has-substitutes? s (derivation-file-name d2)))
  479. (null? (substitutable-paths s o))
  480. (null? (substitutable-path-info s o))))))
  481. (test-assert "build-things with output path"
  482. (with-store s
  483. (let* ((c (random-text)) ;contents of the output
  484. (d (build-expression->derivation
  485. s "substitute-me"
  486. `(call-with-output-file %output
  487. (lambda (p)
  488. (display ,c p)))
  489. #:guile-for-build
  490. (package-derivation s %bootstrap-guile (%current-system))))
  491. (o (derivation->output-path d)))
  492. (set-build-options s #:use-substitutes? #f)
  493. ;; Pass 'build-things' the output file name, O. However, since there
  494. ;; are no substitutes for O, it will just do nothing.
  495. (build-things s (list o))
  496. (not (valid-path? s o)))))
  497. (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
  498. (test-assert "substitute query"
  499. (with-store s
  500. (let* ((d (package-derivation s %bootstrap-guile (%current-system)))
  501. (o (derivation->output-path d)))
  502. ;; Create fake substituter data, to be read by 'guix substitute'.
  503. (with-derivation-narinfo d
  504. ;; Remove entry from the local cache.
  505. (false-if-exception
  506. (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
  507. "/guix/substitute")))
  508. ;; Make sure 'guix substitute' correctly communicates the above
  509. ;; data.
  510. (set-build-options s #:use-substitutes? #t
  511. #:substitute-urls (%test-substitute-urls))
  512. (and (has-substitutes? s o)
  513. (equal? (list o) (substitutable-paths s (list o)))
  514. (match (pk 'spi (substitutable-path-info s (list o)))
  515. (((? substitutable? s))
  516. (and (string=? (substitutable-deriver s)
  517. (derivation-file-name d))
  518. (null? (substitutable-references s))
  519. (equal? (substitutable-nar-size s) 1234)))))))))
  520. (test-assert "substitute query, alternating URLs"
  521. (let* ((d (with-store s
  522. (package-derivation s %bootstrap-guile (%current-system))))
  523. (o (derivation->output-path d)))
  524. (with-derivation-narinfo d
  525. ;; Remove entry from the local cache.
  526. (false-if-exception
  527. (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
  528. "/guix/substitute")))
  529. ;; Note: We reconnect to the daemon to force a new instance of 'guix
  530. ;; substitute' to be used; otherwise the #:substitute-urls of
  531. ;; 'set-build-options' would have no effect.
  532. (and (with-store s ;the right substitute URL
  533. (set-build-options s #:use-substitutes? #t
  534. #:substitute-urls (%test-substitute-urls))
  535. (has-substitutes? s o))
  536. (with-store s ;the wrong one
  537. (set-build-options s #:use-substitutes? #t
  538. #:substitute-urls (list
  539. "http://does-not-exist"))
  540. (not (has-substitutes? s o)))
  541. (with-store s ;the right one again
  542. (set-build-options s #:use-substitutes? #t
  543. #:substitute-urls (%test-substitute-urls))
  544. (has-substitutes? s o))
  545. (with-store s ;empty list of URLs
  546. (set-build-options s #:use-substitutes? #t
  547. #:substitute-urls '())
  548. (not (has-substitutes? s o)))))))
  549. (test-assert "substitute"
  550. (with-store s
  551. (let* ((c (random-text)) ; contents of the output
  552. (d (build-expression->derivation
  553. s "substitute-me"
  554. `(call-with-output-file %output
  555. (lambda (p)
  556. (exit 1) ; would actually fail
  557. (display ,c p)))
  558. #:guile-for-build
  559. (package-derivation s %bootstrap-guile (%current-system))))
  560. (o (derivation->output-path d)))
  561. (with-derivation-substitute d c
  562. (set-build-options s #:use-substitutes? #t
  563. #:substitute-urls (%test-substitute-urls))
  564. (and (has-substitutes? s o)
  565. (build-derivations s (list d))
  566. (equal? c (call-with-input-file o get-string-all)))))))
  567. (test-assert "substitute + build-things with output path"
  568. (with-store s
  569. (let* ((c (random-text)) ;contents of the output
  570. (d (build-expression->derivation
  571. s "substitute-me"
  572. `(call-with-output-file %output
  573. (lambda (p)
  574. (exit 1) ;would actually fail
  575. (display ,c p)))
  576. #:guile-for-build
  577. (package-derivation s %bootstrap-guile (%current-system))))
  578. (o (derivation->output-path d)))
  579. (with-derivation-substitute d c
  580. (set-build-options s #:use-substitutes? #t
  581. #:substitute-urls (%test-substitute-urls))
  582. (and (has-substitutes? s o)
  583. (build-things s (list o)) ;give the output path
  584. (valid-path? s o)
  585. (equal? c (call-with-input-file o get-string-all)))))))
  586. (test-assert "substitute + build-things with specific output"
  587. (with-store s
  588. (let* ((c (random-text)) ;contents of the output
  589. (d (build-expression->derivation
  590. s "substitute-me" `(begin ,c (exit 1)) ;would fail
  591. #:outputs '("out" "one" "two")
  592. #:guile-for-build
  593. (package-derivation s %bootstrap-guile (%current-system))))
  594. (o (derivation->output-path d)))
  595. (with-derivation-substitute d c
  596. (set-build-options s #:use-substitutes? #t
  597. #:substitute-urls (%test-substitute-urls))
  598. (and (has-substitutes? s o)
  599. ;; Ask for nothing but the "out" output of D.
  600. (build-things s `((,(derivation-file-name d) . "out")))
  601. (valid-path? s o)
  602. (equal? c (call-with-input-file o get-string-all)))))))
  603. (test-assert "substitute, corrupt output hash"
  604. ;; Tweak the substituter into installing a substitute whose hash doesn't
  605. ;; match the one announced in the narinfo. The daemon must notice this and
  606. ;; raise an error.
  607. (with-store s
  608. (let* ((c "hello, world") ; contents of the output
  609. (d (build-expression->derivation
  610. s "corrupt-substitute"
  611. `(mkdir %output)
  612. #:guile-for-build
  613. (package-derivation s %bootstrap-guile (%current-system))))
  614. (o (derivation->output-path d)))
  615. (with-derivation-substitute d c
  616. (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
  617. ;; Make sure we use 'guix substitute'.
  618. (set-build-options s
  619. #:use-substitutes? #t
  620. #:fallback? #f
  621. #:substitute-urls (%test-substitute-urls))
  622. (and (has-substitutes? s o)
  623. (guard (c ((store-protocol-error? c)
  624. ;; XXX: the daemon writes "hash mismatch in downloaded
  625. ;; path", but the actual error returned to the client
  626. ;; doesn't mention that.
  627. (pk 'corrupt c)
  628. (not (zero? (store-protocol-error-status c)))))
  629. (build-derivations s (list d))
  630. #f))))))
  631. (test-assert "substitute --fallback"
  632. (with-store s
  633. (let* ((t (random-text)) ; contents of the output
  634. (d (build-expression->derivation
  635. s "substitute-me-not"
  636. `(call-with-output-file %output
  637. (lambda (p)
  638. (display ,t p)))
  639. #:guile-for-build
  640. (package-derivation s %bootstrap-guile (%current-system))))
  641. (o (derivation->output-path d)))
  642. ;; Create fake substituter data, to be read by 'guix substitute'.
  643. (with-derivation-narinfo d
  644. ;; Make sure we use 'guix substitute'.
  645. (set-build-options s #:use-substitutes? #t
  646. #:substitute-urls (%test-substitute-urls))
  647. (and (has-substitutes? s o)
  648. (guard (c ((store-protocol-error? c)
  649. ;; The substituter failed as expected. Now make
  650. ;; sure that #:fallback? #t works correctly.
  651. (set-build-options s
  652. #:use-substitutes? #t
  653. #:substitute-urls
  654. (%test-substitute-urls)
  655. #:fallback? #t)
  656. (and (build-derivations s (list d))
  657. (equal? t (call-with-input-file o
  658. get-string-all)))))
  659. ;; Should fail.
  660. (build-derivations s (list d))
  661. #f))))))
  662. (test-assert "export/import several paths"
  663. (let* ((texts (unfold (cut >= <> 10)
  664. (lambda _ (random-text))
  665. 1+
  666. 0))
  667. (files (map (cut add-text-to-store %store "text" <>) texts))
  668. (dump (call-with-bytevector-output-port
  669. (cut export-paths %store files <>))))
  670. (delete-paths %store files)
  671. (and (every (negate file-exists?) files)
  672. (let* ((source (open-bytevector-input-port dump))
  673. (imported (import-paths %store source)))
  674. (and (equal? imported files)
  675. (every file-exists? files)
  676. (equal? texts
  677. (map (lambda (file)
  678. (call-with-input-file file
  679. get-string-all))
  680. files)))))))
  681. (test-assert "export/import paths, ensure topological order"
  682. (let* ((file0 (add-text-to-store %store "baz" (random-text)))
  683. (file1 (add-text-to-store %store "foo" (random-text)
  684. (list file0)))
  685. (file2 (add-text-to-store %store "bar" (random-text)
  686. (list file1)))
  687. (files (list file1 file2))
  688. (dump1 (call-with-bytevector-output-port
  689. (cute export-paths %store (list file1 file2) <>)))
  690. (dump2 (call-with-bytevector-output-port
  691. (cute export-paths %store (list file2 file1) <>))))
  692. (delete-paths %store files)
  693. (and (every (negate file-exists?) files)
  694. (bytevector=? dump1 dump2)
  695. (let* ((source (open-bytevector-input-port dump1))
  696. (imported (import-paths %store source)))
  697. ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
  698. (and (equal? imported (list file1 file2))
  699. (every file-exists? files)
  700. (equal? (list file0) (references %store file1))
  701. (equal? (list file1) (references %store file2)))))))
  702. (test-assert "export/import incomplete"
  703. (let* ((file0 (add-text-to-store %store "baz" (random-text)))
  704. (file1 (add-text-to-store %store "foo" (random-text)
  705. (list file0)))
  706. (file2 (add-text-to-store %store "bar" (random-text)
  707. (list file1)))
  708. (dump (call-with-bytevector-output-port
  709. (cute export-paths %store (list file2) <>))))
  710. (delete-paths %store (list file0 file1 file2))
  711. (guard (c ((store-protocol-error? c)
  712. (and (not (zero? (store-protocol-error-status c)))
  713. (string-contains (store-protocol-error-message c)
  714. "not valid"))))
  715. ;; Here we get an exception because DUMP does not include FILE0 and
  716. ;; FILE1, which are dependencies of FILE2.
  717. (import-paths %store (open-bytevector-input-port dump)))))
  718. (test-assert "export/import recursive"
  719. (let* ((file0 (add-text-to-store %store "baz" (random-text)))
  720. (file1 (add-text-to-store %store "foo" (random-text)
  721. (list file0)))
  722. (file2 (add-text-to-store %store "bar" (random-text)
  723. (list file1)))
  724. (dump (call-with-bytevector-output-port
  725. (cute export-paths %store (list file2) <>
  726. #:recursive? #t))))
  727. (delete-paths %store (list file0 file1 file2))
  728. (let ((imported (import-paths %store (open-bytevector-input-port dump))))
  729. (and (equal? imported (list file0 file1 file2))
  730. (every file-exists? (list file0 file1 file2))
  731. (equal? (list file0) (references %store file1))
  732. (equal? (list file1) (references %store file2))))))
  733. (test-assert "write-file & export-path yield the same result"
  734. ;; Here we compare 'write-file' and the daemon's own implementation.
  735. ;; 'write-file' is the reference because we know it sorts file
  736. ;; deterministically. Conversely, the daemon uses 'readdir' and the entries
  737. ;; currently happen to be sorted as a side-effect of some unrelated
  738. ;; operation (search for 'unhacked' in archive.cc.) Make sure we detect any
  739. ;; changes there.
  740. (run-with-store %store
  741. (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile))
  742. (out1 -> (derivation->output-path drv1))
  743. (data -> (unfold (cut >= <> 26)
  744. (lambda (i)
  745. (random-bytevector 128))
  746. 1+ 0))
  747. (build
  748. -> #~(begin
  749. (use-modules (rnrs io ports) (srfi srfi-1))
  750. (let ()
  751. (define letters
  752. (map (lambda (i)
  753. (string
  754. (integer->char
  755. (+ i (char->integer #\a)))))
  756. (iota 26)))
  757. (define (touch file data)
  758. (call-with-output-file file
  759. (lambda (port)
  760. (put-bytevector port data))))
  761. (mkdir #$output)
  762. (chdir #$output)
  763. ;; The files must be different so they have
  764. ;; different inode numbers, and the inode
  765. ;; order must differ from the lexicographic
  766. ;; order.
  767. (for-each touch
  768. (append (drop letters 10)
  769. (take letters 10))
  770. (list #$@data))
  771. #t)))
  772. (drv2 (gexp->derivation "bunch" build))
  773. (out2 -> (derivation->output-path drv2))
  774. (item-info -> (store-lift query-path-info)))
  775. (mbegin %store-monad
  776. (built-derivations (list drv1 drv2))
  777. (foldm %store-monad
  778. (lambda (item result)
  779. (define ref-hash
  780. (let-values (((port get) (open-sha256-port)))
  781. (write-file item port)
  782. (close-port port)
  783. (get)))
  784. ;; 'query-path-info' returns a hash produced by using the
  785. ;; daemon's C++ 'dump' function, which is the implementation
  786. ;; under test.
  787. (>>= (item-info item)
  788. (lambda (info)
  789. (return
  790. (and result
  791. (bytevector=? (path-info-hash info) ref-hash))))))
  792. #t
  793. (list out1 out2))))
  794. #:guile-for-build (%guile-for-build)))
  795. (test-assert "import corrupt path"
  796. (let* ((text (random-text))
  797. (file (add-text-to-store %store "text" text))
  798. (dump (call-with-bytevector-output-port
  799. (cut export-paths %store (list file) <>))))
  800. (delete-paths %store (list file))
  801. ;; Flip a bit in the stream's payload. INDEX here falls in the middle of
  802. ;; the file contents in DUMP, regardless of the store prefix.
  803. (let* ((index #x70)
  804. (byte (bytevector-u8-ref dump index)))
  805. (bytevector-u8-set! dump index (logxor #xff byte)))
  806. (and (not (file-exists? file))
  807. (guard (c ((store-protocol-error? c)
  808. (pk 'c c)
  809. (and (not (zero? (store-protocol-error-status c)))
  810. (string-contains (store-protocol-error-message c)
  811. "corrupt"))))
  812. (let* ((source (open-bytevector-input-port dump))
  813. (imported (import-paths %store source)))
  814. (pk 'corrupt-imported imported)
  815. #f)))))
  816. (test-assert "verify-store"
  817. (let* ((text (random-text))
  818. (file1 (add-text-to-store %store "foo" text))
  819. (file2 (add-text-to-store %store "bar" (random-text)
  820. (list file1))))
  821. (and (pk 'verify1 (verify-store %store)) ;hopefully OK ;
  822. (begin
  823. (delete-file file1)
  824. (not (pk 'verify2 (verify-store %store)))) ;bad! ;
  825. (begin
  826. ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
  827. ;; without actually creating the file. ;
  828. (call-with-output-file file1
  829. (lambda (port)
  830. (display text port)))
  831. (pk 'verify3 (verify-store %store)))))) ;OK again
  832. (test-assert "verify-store + check-contents"
  833. ;; XXX: This test is I/O intensive.
  834. (with-store s
  835. (let* ((text (random-text))
  836. (drv (build-expression->derivation
  837. s "corrupt"
  838. `(let ((out (assoc-ref %outputs "out")))
  839. (call-with-output-file out
  840. (lambda (port)
  841. (display ,text port)))
  842. #t)
  843. #:guile-for-build
  844. (package-derivation s %bootstrap-guile (%current-system))))
  845. (file (derivation->output-path drv)))
  846. (with-derivation-substitute drv text
  847. (and (build-derivations s (list drv))
  848. (verify-store s #:check-contents? #t) ;should be OK
  849. (begin
  850. (chmod file #o644)
  851. (call-with-output-file file
  852. (lambda (port)
  853. (display "corrupt!" port)))
  854. #t)
  855. ;; Make sure the corruption is detected. We don't test repairing
  856. ;; because only "trusted" users are allowed to do it, but we
  857. ;; don't expose that notion of trusted users that nix-daemon
  858. ;; supports because it seems dubious and redundant with what the
  859. ;; OS provides (in Nix "trusted" users have additional
  860. ;; privileges, such as overriding the set of substitute URLs, but
  861. ;; we instead want to allow anyone to modify them, provided
  862. ;; substitutes are signed by a root-approved key.)
  863. (not (verify-store s #:check-contents? #t))
  864. ;; Delete the corrupt item to leave the store in a clean state.
  865. (delete-paths s (list file)))))))
  866. (test-assert "build-things, check mode"
  867. (with-store store
  868. (call-with-temporary-output-file
  869. (lambda (entropy entropy-port)
  870. (write (random-text) entropy-port)
  871. (force-output entropy-port)
  872. (let* ((drv (build-expression->derivation
  873. store "non-deterministic"
  874. `(begin
  875. (use-modules (rnrs io ports))
  876. (let ((out (assoc-ref %outputs "out")))
  877. (call-with-output-file out
  878. (lambda (port)
  879. ;; Rely on the fact that tests do not use the
  880. ;; chroot, and thus ENTROPY is readable.
  881. (display (call-with-input-file ,entropy
  882. get-string-all)
  883. port)))
  884. #t))
  885. #:guile-for-build
  886. (package-derivation store %bootstrap-guile (%current-system))))
  887. (file (derivation->output-path drv)))
  888. (and (build-things store (list (derivation-file-name drv)))
  889. (begin
  890. (write (random-text) entropy-port)
  891. (force-output entropy-port)
  892. (guard (c ((store-protocol-error? c)
  893. (pk 'determinism-exception c)
  894. (and (not (zero? (store-protocol-error-status c)))
  895. (string-contains (store-protocol-error-message c)
  896. "deterministic"))))
  897. ;; This one will produce a different result. Since we're in
  898. ;; 'check' mode, this must fail.
  899. (build-things store (list (derivation-file-name drv))
  900. (build-mode check))
  901. #f))))))))
  902. (test-assert "build-succeeded trace in check mode"
  903. (string-contains
  904. (call-with-output-string
  905. (lambda (port)
  906. (let ((d (build-expression->derivation
  907. %store "foo" '(mkdir (assoc-ref %outputs "out"))
  908. #:guile-for-build
  909. (package-derivation %store %bootstrap-guile))))
  910. (build-derivations %store (list d))
  911. (parameterize ((current-build-output-port port))
  912. (build-derivations %store (list d) (build-mode check))))))
  913. "@ build-succeeded"))
  914. (test-assert "build multiple times"
  915. (with-store store
  916. ;; Ask to build twice.
  917. (set-build-options store #:rounds 2 #:use-substitutes? #f)
  918. (call-with-temporary-output-file
  919. (lambda (entropy entropy-port)
  920. (write (random-text) entropy-port)
  921. (force-output entropy-port)
  922. (let* ((drv (build-expression->derivation
  923. store "non-deterministic"
  924. `(begin
  925. (use-modules (rnrs io ports))
  926. (let ((out (assoc-ref %outputs "out")))
  927. (call-with-output-file out
  928. (lambda (port)
  929. ;; Rely on the fact that tests do not use the
  930. ;; chroot, and thus ENTROPY is accessible.
  931. (display (call-with-input-file ,entropy
  932. get-string-all)
  933. port)
  934. (call-with-output-file ,entropy
  935. (lambda (port)
  936. (write 'foobar port)))))
  937. #t))
  938. #:guile-for-build
  939. (package-derivation store %bootstrap-guile (%current-system))))
  940. (file (derivation->output-path drv)))
  941. (guard (c ((store-protocol-error? c)
  942. (pk 'multiple-build c)
  943. (and (not (zero? (store-protocol-error-status c)))
  944. (string-contains (store-protocol-error-message c)
  945. "deterministic"))))
  946. ;; This one will produce a different result on the second run.
  947. (current-build-output-port (current-error-port))
  948. (build-things store (list (derivation-file-name drv)))
  949. #f))))))
  950. (test-equal "store-lower"
  951. "Lowered."
  952. (let* ((add (store-lower text-file))
  953. (file (add %store "foo" "Lowered.")))
  954. (call-with-input-file file get-string-all)))
  955. (test-equal "current-system"
  956. "bar"
  957. (parameterize ((%current-system "frob"))
  958. (run-with-store %store
  959. (mbegin %store-monad
  960. (set-current-system "bar")
  961. (current-system))
  962. #:system "foo")))
  963. (test-assert "query-path-info"
  964. (let* ((ref (add-text-to-store %store "ref" "foo"))
  965. (item (add-text-to-store %store "item" "bar" (list ref)))
  966. (info (query-path-info %store item)))
  967. (and (equal? (path-info-references info) (list ref))
  968. (equal? (path-info-hash info)
  969. (sha256
  970. (string->utf8
  971. (call-with-output-string (cut write-file item <>))))))))
  972. (test-assert "path-info-deriver"
  973. (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
  974. (s (add-to-store %store "bash" #t "sha256"
  975. (search-bootstrap-binary "bash"
  976. (%current-system))))
  977. (d (derivation %store "the-thing"
  978. s `("-e" ,b)
  979. #:env-vars `(("foo" . ,(random-text)))
  980. #:inputs `((,b) (,s))))
  981. (o (derivation->output-path d)))
  982. (and (build-derivations %store (list d))
  983. (not (path-info-deriver (query-path-info %store b)))
  984. (string=? (derivation-file-name d)
  985. (path-info-deriver (query-path-info %store o))))))
  986. (test-equal "build-cores"
  987. (list 0 42)
  988. (with-store store
  989. (let* ((build (add-text-to-store store "build.sh"
  990. "echo $NIX_BUILD_CORES > $out"))
  991. (bash (add-to-store store "bash" #t "sha256"
  992. (search-bootstrap-binary "bash"
  993. (%current-system))))
  994. (drv1 (derivation store "the-thing" bash
  995. `("-e" ,build)
  996. #:inputs `((,bash) (,build))
  997. #:env-vars `(("x" . ,(random-text)))))
  998. (drv2 (derivation store "the-thing" bash
  999. `("-e" ,build)
  1000. #:inputs `((,bash) (,build))
  1001. #:env-vars `(("x" . ,(random-text))))))
  1002. (and (build-derivations store (list drv1))
  1003. (begin
  1004. (set-build-options store #:build-cores 42)
  1005. (build-derivations store (list drv2)))
  1006. (list (call-with-input-file (derivation->output-path drv1)
  1007. read)
  1008. (call-with-input-file (derivation->output-path drv2)
  1009. read))))))
  1010. (test-equal "multiplexed-build-output"
  1011. '("Hello from first." "Hello from second.")
  1012. (with-store store
  1013. (let* ((build (add-text-to-store store "build.sh"
  1014. "echo Hello from $NAME.; echo > $out"))
  1015. (bash (add-to-store store "bash" #t "sha256"
  1016. (search-bootstrap-binary "bash"
  1017. (%current-system))))
  1018. (drv1 (derivation store "one" bash
  1019. `("-e" ,build)
  1020. #:inputs `((,bash) (,build))
  1021. #:env-vars `(("NAME" . "first")
  1022. ("x" . ,(random-text)))))
  1023. (drv2 (derivation store "two" bash
  1024. `("-e" ,build)
  1025. #:inputs `((,bash) (,build))
  1026. #:env-vars `(("NAME" . "second")
  1027. ("x" . ,(random-text))))))
  1028. (set-build-options store
  1029. #:print-build-trace #t
  1030. #:multiplexed-build-output? #t
  1031. #:max-build-jobs 10)
  1032. (let ((port (open-output-string)))
  1033. ;; Send the build log to PORT.
  1034. (parameterize ((current-build-output-port port))
  1035. (build-derivations store (list drv1 drv2)))
  1036. ;; Retrieve the build log; make sure it contains valid "@ build-log"
  1037. ;; traces that allow us to retrieve each builder's output (we assume
  1038. ;; there's exactly one "build-output" trace for each builder, which is
  1039. ;; reasonable.)
  1040. (let* ((log (get-output-string port))
  1041. (started (fold-matches
  1042. (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)")
  1043. log '() cons))
  1044. (done (fold-matches
  1045. (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)")
  1046. log '() cons))
  1047. (output (fold-matches
  1048. (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n")
  1049. log '() cons))
  1050. (drv-pid (lambda (name)
  1051. (lambda (m)
  1052. (let ((drv (match:substring m 1))
  1053. (pid (string->number
  1054. (match:substring m 4))))
  1055. (and (string-suffix? name drv) pid)))))
  1056. (pid-log (lambda (pid)
  1057. (lambda (m)
  1058. (let ((n (string->number
  1059. (match:substring m 1)))
  1060. (len (string->number
  1061. (match:substring m 2)))
  1062. (str (match:substring m 3)))
  1063. (and (= pid n)
  1064. (= (string-length str) (- len 1))
  1065. str)))))
  1066. (pid1 (any (drv-pid "one.drv") started))
  1067. (pid2 (any (drv-pid "two.drv") started)))
  1068. (list (any (pid-log pid1) output)
  1069. (any (pid-log pid2) output)))))))
  1070. (test-end "store")