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.

1253 lines
55 KiB

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