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.
 
 
 
 
 
 

396 lines
16 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013 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 store)
  20. #:use-module (guix utils)
  21. #:use-module (guix hash)
  22. #:use-module (guix base32)
  23. #:use-module (guix packages)
  24. #:use-module (guix derivations)
  25. #:use-module (guix nar)
  26. #:use-module (gnu packages)
  27. #:use-module (gnu packages bootstrap)
  28. #:use-module (ice-9 match)
  29. #:use-module (rnrs bytevectors)
  30. #:use-module (rnrs io ports)
  31. #:use-module (web uri)
  32. #:use-module (srfi srfi-1)
  33. #:use-module (srfi srfi-11)
  34. #:use-module (srfi srfi-26)
  35. #:use-module (srfi srfi-34)
  36. #:use-module (srfi srfi-64))
  37. ;; Test the (guix store) module.
  38. (define %store
  39. (false-if-exception (open-connection)))
  40. (when %store
  41. ;; Make sure we build everything by ourselves.
  42. (set-build-options %store #:use-substitutes? #f))
  43. (define %seed
  44. (seed->random-state (logxor (getpid) (car (gettimeofday)))))
  45. (define (random-text)
  46. (number->string (random (expt 2 256) %seed) 16))
  47. (test-begin "store")
  48. (test-equal "store-path-hash-part"
  49. "283gqy39v3g9dxjy26rynl0zls82fmcg"
  50. (store-path-hash-part
  51. (string-append (%store-prefix)
  52. "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  53. (test-equal "store-path-hash-part #f"
  54. #f
  55. (store-path-hash-part
  56. (string-append (%store-prefix)
  57. "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  58. (test-equal "store-path-package-name"
  59. "guile-2.0.7"
  60. (store-path-package-name
  61. (string-append (%store-prefix)
  62. "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  63. (test-equal "store-path-package-name #f"
  64. #f
  65. (store-path-package-name
  66. "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
  67. (test-assert "direct-store-path?"
  68. (and (direct-store-path?
  69. (string-append (%store-prefix)
  70. "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
  71. (not (direct-store-path?
  72. (string-append
  73. (%store-prefix)
  74. "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))))
  75. (test-skip (if %store 0 10))
  76. (test-assert "dead-paths"
  77. (let ((p (add-text-to-store %store "random-text" (random-text))))
  78. (member p (dead-paths %store))))
  79. ;; FIXME: Find a test for `live-paths'.
  80. ;;
  81. ;; (test-assert "temporary root is in live-paths"
  82. ;; (let* ((p1 (add-text-to-store %store "random-text"
  83. ;; (random-text) '()))
  84. ;; (b (add-text-to-store %store "link-builder"
  85. ;; (format #f "echo ~a > $out" p1)
  86. ;; '()))
  87. ;; (d1 (derivation %store "link"
  88. ;; "/bin/sh" `("-e" ,b)
  89. ;; #:inputs `((,b) (,p1))))
  90. ;; (p2 (derivation->output-path d1)))
  91. ;; (and (add-temp-root %store p2)
  92. ;; (build-derivations %store (list d1))
  93. ;; (valid-path? %store p1)
  94. ;; (member (pk p2) (live-paths %store)))))
  95. (test-assert "dead path can be explicitly collected"
  96. (let ((p (add-text-to-store %store "random-text"
  97. (random-text) '())))
  98. (let-values (((paths freed) (delete-paths %store (list p))))
  99. (and (equal? paths (list p))
  100. (> freed 0)
  101. (not (file-exists? p))))))
  102. (test-assert "references"
  103. (let* ((t1 (add-text-to-store %store "random1"
  104. (random-text)))
  105. (t2 (add-text-to-store %store "random2"
  106. (random-text) (list t1))))
  107. (and (equal? (list t1) (references %store t2))
  108. (equal? (list t2) (referrers %store t1))
  109. (null? (references %store t1))
  110. (null? (referrers %store t2)))))
  111. (test-assert "requisites"
  112. (let* ((t1 (add-text-to-store %store "random1"
  113. (random-text) '()))
  114. (t2 (add-text-to-store %store "random2"
  115. (random-text) (list t1)))
  116. (t3 (add-text-to-store %store "random3"
  117. (random-text) (list t2)))
  118. (t4 (add-text-to-store %store "random4"
  119. (random-text) (list t1 t3))))
  120. (define (same? x y)
  121. (and (= (length x) (length y))
  122. (lset= equal? x y)))
  123. (and (same? (requisites %store t1) (list t1))
  124. (same? (requisites %store t2) (list t1 t2))
  125. (same? (requisites %store t3) (list t1 t2 t3))
  126. (same? (requisites %store t4) (list t1 t2 t3 t4)))))
  127. (test-assert "derivers"
  128. (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
  129. (s (add-to-store %store "bash" #t "sha256"
  130. (search-bootstrap-binary "bash"
  131. (%current-system))))
  132. (d (derivation %store "the-thing"
  133. s `("-e" ,b)
  134. #:env-vars `(("foo" . ,(random-text)))
  135. #:inputs `((,b) (,s))))
  136. (o (derivation->output-path d)))
  137. (and (build-derivations %store (list d))
  138. (equal? (query-derivation-outputs %store (derivation-file-name d))
  139. (list o))
  140. (equal? (valid-derivers %store o)
  141. (list (derivation-file-name d))))))
  142. (test-assert "log-file, derivation"
  143. (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
  144. (s (add-to-store %store "bash" #t "sha256"
  145. (search-bootstrap-binary "bash"
  146. (%current-system))))
  147. (d (derivation %store "the-thing"
  148. s `("-e" ,b)
  149. #:env-vars `(("foo" . ,(random-text)))
  150. #:inputs `((,b) (,s)))))
  151. (and (build-derivations %store (list d))
  152. (file-exists? (pk (log-file %store (derivation-file-name d)))))))
  153. (test-assert "log-file, output file name"
  154. (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
  155. (s (add-to-store %store "bash" #t "sha256"
  156. (search-bootstrap-binary "bash"
  157. (%current-system))))
  158. (d (derivation %store "the-thing"
  159. s `("-e" ,b)
  160. #:env-vars `(("foo" . ,(random-text)))
  161. #:inputs `((,b) (,s))))
  162. (o (derivation->output-path d)))
  163. (and (build-derivations %store (list d))
  164. (file-exists? (pk (log-file %store o)))
  165. (string=? (log-file %store (derivation-file-name d))
  166. (log-file %store o)))))
  167. (test-assert "no substitutes"
  168. (let* ((s (open-connection))
  169. (d1 (package-derivation s %bootstrap-guile (%current-system)))
  170. (d2 (package-derivation s %bootstrap-glibc (%current-system)))
  171. (o (map derivation->output-path (list d1 d2))))
  172. (set-build-options s #:use-substitutes? #f)
  173. (and (not (has-substitutes? s (derivation-file-name d1)))
  174. (not (has-substitutes? s (derivation-file-name d2)))
  175. (null? (substitutable-paths s o))
  176. (null? (substitutable-path-info s o)))))
  177. (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
  178. (test-assert "substitute query"
  179. (let* ((s (open-connection))
  180. (d (package-derivation s %bootstrap-guile (%current-system)))
  181. (o (derivation->output-path d))
  182. (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
  183. (compose uri-path string->uri))))
  184. ;; Create fake substituter data, to be read by `substitute-binary'.
  185. (call-with-output-file (string-append dir "/nix-cache-info")
  186. (lambda (p)
  187. (format p "StoreDir: ~a\nWantMassQuery: 0\n"
  188. (%store-prefix))))
  189. (call-with-output-file (string-append dir "/" (store-path-hash-part o)
  190. ".narinfo")
  191. (lambda (p)
  192. (format p "StorePath: ~a
  193. URL: ~a
  194. Compression: none
  195. NarSize: 1234
  196. References:
  197. System: ~a
  198. Deriver: ~a~%"
  199. o ; StorePath
  200. (string-append dir "/example.nar") ; URL
  201. (%current-system) ; System
  202. (basename
  203. (derivation-file-name d))))) ; Deriver
  204. ;; Remove entry from the local cache.
  205. (false-if-exception
  206. (delete-file (string-append (getenv "XDG_CACHE_HOME")
  207. "/guix/substitute-binary/"
  208. (store-path-hash-part o))))
  209. ;; Make sure `substitute-binary' correctly communicates the above data.
  210. (set-build-options s #:use-substitutes? #t)
  211. (and (has-substitutes? s o)
  212. (equal? (list o) (substitutable-paths s (list o)))
  213. (match (pk 'spi (substitutable-path-info s (list o)))
  214. (((? substitutable? s))
  215. (and (string=? (substitutable-deriver s) (derivation-file-name d))
  216. (null? (substitutable-references s))
  217. (equal? (substitutable-nar-size s) 1234)))))))
  218. (test-assert "substitute"
  219. (let* ((s (open-connection))
  220. (c (random-text)) ; contents of the output
  221. (d (build-expression->derivation
  222. s "substitute-me"
  223. `(call-with-output-file %output
  224. (lambda (p)
  225. (exit 1) ; would actually fail
  226. (display ,c p)))
  227. #:guile-for-build
  228. (package-derivation s %bootstrap-guile (%current-system))))
  229. (o (derivation->output-path d))
  230. (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
  231. (compose uri-path string->uri))))
  232. ;; Create fake substituter data, to be read by `substitute-binary'.
  233. (call-with-output-file (string-append dir "/nix-cache-info")
  234. (lambda (p)
  235. (format p "StoreDir: ~a\nWantMassQuery: 0\n"
  236. (%store-prefix))))
  237. (call-with-output-file (string-append dir "/example.out")
  238. (lambda (p)
  239. (display c p)))
  240. (call-with-output-file (string-append dir "/example.nar")
  241. (lambda (p)
  242. (write-file (string-append dir "/example.out") p)))
  243. (call-with-output-file (string-append dir "/" (store-path-hash-part o)
  244. ".narinfo")
  245. (lambda (p)
  246. (format p "StorePath: ~a
  247. URL: ~a
  248. Compression: none
  249. NarSize: 1234
  250. NarHash: sha256:~a
  251. References:
  252. System: ~a
  253. Deriver: ~a~%"
  254. o ; StorePath
  255. "example.nar" ; relative URL
  256. (call-with-input-file (string-append dir "/example.nar")
  257. (compose bytevector->nix-base32-string sha256
  258. get-bytevector-all))
  259. (%current-system) ; System
  260. (basename
  261. (derivation-file-name d))))) ; Deriver
  262. ;; Make sure we use `substitute-binary'.
  263. (set-build-options s #:use-substitutes? #t)
  264. (and (has-substitutes? s o)
  265. (build-derivations s (list d))
  266. (equal? c (call-with-input-file o get-string-all)))))
  267. (test-assert "substitute --fallback"
  268. (let* ((s (open-connection))
  269. (t (random-text)) ; contents of the output
  270. (d (build-expression->derivation
  271. s "substitute-me-not"
  272. `(call-with-output-file %output
  273. (lambda (p)
  274. (display ,t p)))
  275. #:guile-for-build
  276. (package-derivation s %bootstrap-guile (%current-system))))
  277. (o (derivation->output-path d))
  278. (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
  279. (compose uri-path string->uri))))
  280. ;; Create fake substituter data, to be read by `substitute-binary'.
  281. (call-with-output-file (string-append dir "/nix-cache-info")
  282. (lambda (p)
  283. (format p "StoreDir: ~a\nWantMassQuery: 0\n"
  284. (%store-prefix))))
  285. (call-with-output-file (string-append dir "/" (store-path-hash-part o)
  286. ".narinfo")
  287. (lambda (p)
  288. (format p "StorePath: ~a
  289. URL: ~a
  290. Compression: none
  291. NarSize: 1234
  292. NarHash: sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73
  293. References:
  294. System: ~a
  295. Deriver: ~a~%"
  296. o ; StorePath
  297. "does-not-exist.nar" ; relative URL
  298. (%current-system) ; System
  299. (basename
  300. (derivation-file-name d))))) ; Deriver
  301. ;; Make sure we use `substitute-binary'.
  302. (set-build-options s #:use-substitutes? #t)
  303. (and (has-substitutes? s o)
  304. (guard (c ((nix-protocol-error? c)
  305. ;; The substituter failed as expected. Now make sure that
  306. ;; #:fallback? #t works correctly.
  307. (set-build-options s
  308. #:use-substitutes? #t
  309. #:fallback? #t)
  310. (and (build-derivations s (list d))
  311. (equal? t (call-with-input-file o get-string-all)))))
  312. ;; Should fail.
  313. (build-derivations s (list d))
  314. #f))))
  315. (test-assert "export/import several paths"
  316. (let* ((texts (unfold (cut >= <> 10)
  317. (lambda _ (random-text))
  318. 1+
  319. 0))
  320. (files (map (cut add-text-to-store %store "text" <>) texts))
  321. (dump (call-with-bytevector-output-port
  322. (cut export-paths %store files <>))))
  323. (delete-paths %store files)
  324. (and (every (negate file-exists?) files)
  325. (let* ((source (open-bytevector-input-port dump))
  326. (imported (import-paths %store source)))
  327. (and (equal? imported files)
  328. (every file-exists? files)
  329. (equal? texts
  330. (map (lambda (file)
  331. (call-with-input-file file
  332. get-string-all))
  333. files)))))))
  334. (test-assert "import corrupt path"
  335. (let* ((text (random-text))
  336. (file (add-text-to-store %store "text" text))
  337. (dump (call-with-bytevector-output-port
  338. (cut export-paths %store (list file) <>))))
  339. (delete-paths %store (list file))
  340. ;; Flip a bit in the middle of the stream.
  341. (let* ((index (quotient (bytevector-length dump) 3))
  342. (byte (bytevector-u8-ref dump index)))
  343. (bytevector-u8-set! dump index (logxor #xff byte)))
  344. (and (not (file-exists? file))
  345. (guard (c ((nix-protocol-error? c)
  346. (pk 'c c)
  347. (and (not (zero? (nix-protocol-error-status c)))
  348. (string-contains (nix-protocol-error-message c)
  349. "corrupt"))))
  350. (let* ((source (open-bytevector-input-port dump))
  351. (imported (import-paths %store source)))
  352. (pk 'corrupt-imported imported)
  353. #f)))))
  354. (test-end "store")
  355. (exit (= (test-runner-fail-count (test-runner-current)) 0))