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.
 
 
 
 
 
 

1121 lines
49 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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-packages)
  19. #:use-module (guix tests)
  20. #:use-module (guix store)
  21. #:use-module (guix monads)
  22. #:use-module (guix grafts)
  23. #:use-module ((guix gexp) #:select (local-file local-file-file))
  24. #:use-module ((guix utils)
  25. ;; Rename the 'location' binding to allow proper syntax
  26. ;; matching when setting the 'location' field of a package.
  27. #:renamer (lambda (name)
  28. (cond ((eq? name 'location) 'make-location)
  29. (else name))))
  30. #:use-module (gcrypt hash)
  31. #:use-module (guix derivations)
  32. #:use-module (guix packages)
  33. #:use-module (guix grafts)
  34. #:use-module (guix search-paths)
  35. #:use-module (guix build-system)
  36. #:use-module (guix build-system trivial)
  37. #:use-module (guix build-system gnu)
  38. #:use-module (guix profiles)
  39. #:use-module (guix scripts package)
  40. #:use-module (gnu packages)
  41. #:use-module (gnu packages base)
  42. #:use-module (gnu packages guile)
  43. #:use-module (gnu packages bootstrap)
  44. #:use-module (gnu packages version-control)
  45. #:use-module (gnu packages xml)
  46. #:use-module (srfi srfi-1)
  47. #:use-module (srfi srfi-26)
  48. #:use-module (srfi srfi-34)
  49. #:use-module (srfi srfi-35)
  50. #:use-module (srfi srfi-64)
  51. #:use-module (rnrs io ports)
  52. #:use-module (ice-9 vlist)
  53. #:use-module (ice-9 regex)
  54. #:use-module (ice-9 match))
  55. ;; Test the high-level packaging layer.
  56. (define %store
  57. (open-connection-for-tests))
  58. ;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
  59. ;; can trigger builds early.)
  60. (%graft? #f)
  61. (test-begin "packages")
  62. (test-assert "printer with location"
  63. (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
  64. (with-output-to-string
  65. (lambda ()
  66. (write
  67. (dummy-package "foo"
  68. (location (make-location "foo.scm" 42 7))))))))
  69. (test-assert "printer without location"
  70. (string-match "^#<package foo@0 [[:xdigit:]]+>$"
  71. (with-output-to-string
  72. (lambda ()
  73. (write
  74. (dummy-package "foo" (location #f)))))))
  75. (test-assert "hidden-package"
  76. (and (hidden-package? (hidden-package (dummy-package "foo")))
  77. (not (hidden-package? (dummy-package "foo")))))
  78. (test-assert "package-superseded"
  79. (let* ((new (dummy-package "bar"))
  80. (old (deprecated-package "foo" new)))
  81. (and (eq? (package-superseded old) new)
  82. (mock ((gnu packages) find-best-packages-by-name (const (list old)))
  83. (specification->package "foo")
  84. (and (eq? new (specification->package "foo"))
  85. (eq? new (specification->package+output "foo")))))))
  86. (test-assert "transaction-upgrade-entry, zero upgrades"
  87. (let* ((old (dummy-package "foo" (version "1")))
  88. (tx (mock ((gnu packages) find-newest-available-packages
  89. (const vlist-null))
  90. ((@@ (guix scripts package) transaction-upgrade-entry)
  91. (manifest-entry
  92. (inherit (package->manifest-entry old))
  93. (item (string-append (%store-prefix) "/"
  94. (make-string 32 #\e) "-foo-1")))
  95. (manifest-transaction)))))
  96. (manifest-transaction-null? tx)))
  97. (test-assert "transaction-upgrade-entry, one upgrade"
  98. (let* ((old (dummy-package "foo" (version "1")))
  99. (new (dummy-package "foo" (version "2")))
  100. (tx (mock ((gnu packages) find-newest-available-packages
  101. (const (vhash-cons "foo" (list "2" new) vlist-null)))
  102. ((@@ (guix scripts package) transaction-upgrade-entry)
  103. (manifest-entry
  104. (inherit (package->manifest-entry old))
  105. (item (string-append (%store-prefix) "/"
  106. (make-string 32 #\e) "-foo-1")))
  107. (manifest-transaction)))))
  108. (and (match (manifest-transaction-install tx)
  109. ((($ <manifest-entry> "foo" "2" "out" item))
  110. (eq? item new)))
  111. (null? (manifest-transaction-remove tx)))))
  112. (test-assert "transaction-upgrade-entry, superseded package"
  113. (let* ((old (dummy-package "foo" (version "1")))
  114. (new (dummy-package "bar" (version "2")))
  115. (dep (deprecated-package "foo" new))
  116. (tx (mock ((gnu packages) find-newest-available-packages
  117. (const (vhash-cons "foo" (list "2" dep) vlist-null)))
  118. ((@@ (guix scripts package) transaction-upgrade-entry)
  119. (manifest-entry
  120. (inherit (package->manifest-entry old))
  121. (item (string-append (%store-prefix) "/"
  122. (make-string 32 #\e) "-foo-1")))
  123. (manifest-transaction)))))
  124. (and (match (manifest-transaction-install tx)
  125. ((($ <manifest-entry> "bar" "2" "out" item))
  126. (eq? item new)))
  127. (match (manifest-transaction-remove tx)
  128. (((? manifest-pattern? pattern))
  129. (and (string=? (manifest-pattern-name pattern) "foo")
  130. (string=? (manifest-pattern-version pattern) "1")
  131. (string=? (manifest-pattern-output pattern) "out")))))))
  132. (test-assert "package-field-location"
  133. (let ()
  134. (define (goto port line column)
  135. (unless (and (= (port-column port) (- column 1))
  136. (= (port-line port) (- line 1)))
  137. (unless (eof-object? (get-char port))
  138. (goto port line column))))
  139. (define read-at
  140. (match-lambda
  141. (($ <location> file line column)
  142. (call-with-input-file (search-path %load-path file)
  143. (lambda (port)
  144. (goto port line column)
  145. (read port))))))
  146. ;; Until Guile 2.0.6 included, source properties were added only to pairs.
  147. ;; Thus, check against both VALUE and (FIELD VALUE).
  148. (and (member (read-at (package-field-location %bootstrap-guile 'name))
  149. (let ((name (package-name %bootstrap-guile)))
  150. (list name `(name ,name))))
  151. (member (read-at (package-field-location %bootstrap-guile 'version))
  152. (let ((version (package-version %bootstrap-guile)))
  153. (list version `(version ,version))))
  154. (not (package-field-location %bootstrap-guile 'does-not-exist)))))
  155. ;; Make sure we don't change the file name to an absolute file name.
  156. (test-equal "package-field-location, relative file name"
  157. (location-file (package-location %bootstrap-guile))
  158. (with-fluids ((%file-port-name-canonicalization 'absolute))
  159. (location-file (package-field-location %bootstrap-guile 'version))))
  160. (test-assert "package-transitive-inputs"
  161. (let* ((a (dummy-package "a"))
  162. (b (dummy-package "b"
  163. (propagated-inputs `(("a" ,a)))))
  164. (c (dummy-package "c"
  165. (inputs `(("a" ,a)))))
  166. (d (dummy-package "d"
  167. (propagated-inputs `(("x" "something.drv")))))
  168. (e (dummy-package "e"
  169. (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
  170. (and (null? (package-transitive-inputs a))
  171. (equal? `(("a" ,a)) (package-transitive-inputs b))
  172. (equal? `(("a" ,a)) (package-transitive-inputs c))
  173. (equal? (package-propagated-inputs d)
  174. (package-transitive-inputs d))
  175. (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
  176. ("a" ,a) ("x" "something.drv"))
  177. (pk 'x (package-transitive-inputs e))))))
  178. (test-assert "package-transitive-inputs, no duplicates"
  179. (let* ((a (dummy-package "a"))
  180. (b (dummy-package "b"
  181. (inputs `(("a+" ,a)))
  182. (native-inputs `(("a*" ,a)))
  183. (propagated-inputs `(("a" ,a)))))
  184. (c (dummy-package "c"
  185. (propagated-inputs `(("b" ,b)))))
  186. (d (dummy-package "d"
  187. (inputs `(("a" ,a) ("c" ,c)))))
  188. (e (dummy-package "e"
  189. (inputs `(("b" ,b) ("c" ,c))))))
  190. (and (null? (package-transitive-inputs a))
  191. (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a)) ;here duplicates are kept
  192. (package-transitive-inputs b))
  193. (equal? `(("b" ,b) ("a" ,a))
  194. (package-transitive-inputs c))
  195. (equal? `(("a" ,a) ("c" ,c) ("b" ,b)) ;duplicate A removed
  196. (package-transitive-inputs d))
  197. (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
  198. (package-transitive-inputs e))))) ;ditto
  199. (test-equal "package-transitive-supported-systems"
  200. '(("x" "y" "z") ;a
  201. ("x" "y") ;b
  202. ("y") ;c
  203. ("y") ;d
  204. ("y")) ;e
  205. ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
  206. ;; doesn't restrict the set of supported systems.
  207. (let* ((a (dummy-package "a"
  208. (build-system trivial-build-system)
  209. (supported-systems '("x" "y" "z"))))
  210. (b (dummy-package "b"
  211. (build-system trivial-build-system)
  212. (supported-systems '("x" "y"))
  213. (inputs `(("a" ,a)))))
  214. (c (dummy-package "c"
  215. (build-system trivial-build-system)
  216. (supported-systems '("y" "z"))
  217. (inputs `(("b" ,b)))))
  218. (d (dummy-package "d"
  219. (build-system trivial-build-system)
  220. (supported-systems '("x" "y" "z"))
  221. (inputs `(("b" ,b) ("c" ,c)))))
  222. (e (dummy-package "e"
  223. (build-system trivial-build-system)
  224. (supported-systems '("x" "y" "z"))
  225. (inputs `(("d" ,d))))))
  226. (list (package-transitive-supported-systems a)
  227. (package-transitive-supported-systems b)
  228. (package-transitive-supported-systems c)
  229. (package-transitive-supported-systems d)
  230. (package-transitive-supported-systems e))))
  231. (test-equal "origin-actual-file-name"
  232. "foo-1.tar.gz"
  233. (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
  234. (origin-actual-file-name o)))
  235. (test-equal "origin-actual-file-name, file-name"
  236. "foo-1.tar.gz"
  237. (let ((o (dummy-origin
  238. (uri "http://www.example.com/tarball")
  239. (file-name "foo-1.tar.gz"))))
  240. (origin-actual-file-name o)))
  241. (let* ((o (dummy-origin))
  242. (u (dummy-origin))
  243. (i (dummy-origin))
  244. (a (dummy-package "a"))
  245. (b (dummy-package "b"
  246. (inputs `(("a" ,a) ("i" ,i)))))
  247. (c (package (inherit b) (source o)))
  248. (d (dummy-package "d"
  249. (build-system trivial-build-system)
  250. (source u) (inputs `(("c" ,c))))))
  251. (test-assert "package-direct-sources, no source"
  252. (null? (package-direct-sources a)))
  253. (test-equal "package-direct-sources, #f source"
  254. (list i)
  255. (package-direct-sources b))
  256. (test-equal "package-direct-sources, not input source"
  257. (list u)
  258. (package-direct-sources d))
  259. (test-assert "package-direct-sources"
  260. (let ((s (package-direct-sources c)))
  261. (and (= (length (pk 's-sources s)) 2)
  262. (member o s)
  263. (member i s))))
  264. (test-assert "package-transitive-sources"
  265. (let ((s (package-transitive-sources d)))
  266. (and (= (length (pk 'd-sources s)) 3)
  267. (member o s)
  268. (member i s)
  269. (member u s)))))
  270. (test-assert "transitive-input-references"
  271. (let* ((a (dummy-package "a"))
  272. (b (dummy-package "b"))
  273. (c (dummy-package "c"
  274. (inputs `(("a" ,a)))
  275. (propagated-inputs `(("boo" ,b)))))
  276. (d (dummy-package "d"
  277. (inputs `(("c*" ,c)))))
  278. (keys (map (match-lambda
  279. (('assoc-ref 'l key)
  280. key))
  281. (pk 'refs (transitive-input-references
  282. 'l (package-inputs d))))))
  283. (and (= (length keys) 2)
  284. (member "c*" keys)
  285. (member "boo" keys))))
  286. (test-equal "package-transitive-supported-systems, implicit inputs"
  287. %supported-systems
  288. ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
  289. ;; %SUPPORTED-SYSTEMS. Thus the others must be ignored.
  290. (let ((p (dummy-package "foo"
  291. (build-system gnu-build-system)
  292. (supported-systems
  293. `("does-not-exist" "foobar" ,@%supported-systems)))))
  294. (package-transitive-supported-systems p)))
  295. (test-assert "supported-package?"
  296. (let ((p (dummy-package "foo"
  297. (build-system gnu-build-system)
  298. (supported-systems '("x86_64-linux" "does-not-exist")))))
  299. (and (supported-package? p "x86_64-linux")
  300. (not (supported-package? p "does-not-exist"))
  301. (not (supported-package? p "i686-linux")))))
  302. (test-skip (if (not %store) 8 0))
  303. (test-assert "package-source-derivation, file"
  304. (let* ((file (search-path %load-path "guix.scm"))
  305. (package (package (inherit (dummy-package "p"))
  306. (source file)))
  307. (source (package-source-derivation %store
  308. (package-source package))))
  309. (and (store-path? source)
  310. (valid-path? %store source)
  311. (equal? (call-with-input-file source get-bytevector-all)
  312. (call-with-input-file file get-bytevector-all)))))
  313. (test-assert "package-source-derivation, store path"
  314. (let* ((file (add-to-store %store "guix.scm" #t "sha256"
  315. (search-path %load-path "guix.scm")))
  316. (package (package (inherit (dummy-package "p"))
  317. (source file)))
  318. (source (package-source-derivation %store
  319. (package-source package))))
  320. (string=? file source)))
  321. (test-assert "package-source-derivation, indirect store path"
  322. (let* ((dir (add-to-store %store "guix-build" #t "sha256"
  323. (dirname (search-path %load-path
  324. "guix/build/utils.scm"))))
  325. (package (package (inherit (dummy-package "p"))
  326. (source (string-append dir "/utils.scm"))))
  327. (source (package-source-derivation %store
  328. (package-source package))))
  329. (and (direct-store-path? source)
  330. (string-suffix? "utils.scm" source))))
  331. (test-assert "package-source-derivation, local-file"
  332. (let* ((file (local-file "../guix/base32.scm"))
  333. (package (package (inherit (dummy-package "p"))
  334. (source file)))
  335. (source (package-source-derivation %store
  336. (package-source package))))
  337. (and (store-path? source)
  338. (string-suffix? "base32.scm" source)
  339. (valid-path? %store source)
  340. (equal? (call-with-input-file source get-bytevector-all)
  341. (call-with-input-file
  342. (search-path %load-path "guix/base32.scm")
  343. get-bytevector-all)))))
  344. (unless (network-reachable?) (test-skip 1))
  345. (test-equal "package-source-derivation, snippet"
  346. "OK"
  347. (let* ((source (bootstrap-origin
  348. (origin
  349. (inherit (bootstrap-guile-origin (%current-system)))
  350. (patch-inputs
  351. `(("tar" ,%bootstrap-coreutils&co)
  352. ("xz" ,%bootstrap-coreutils&co)
  353. ("patch" ,%bootstrap-coreutils&co)))
  354. (patch-guile %bootstrap-guile)
  355. (modules '((guix build utils)))
  356. (snippet '(begin
  357. ;; We end up in 'bin', because it's the first
  358. ;; directory, alphabetically. Not a very good
  359. ;; example but hey.
  360. (chmod "." #o777)
  361. (symlink "guile" "guile-rocks")
  362. (copy-recursively "../share/guile/2.0/scripts"
  363. "scripts")
  364. ;; Make sure '.file_list' can be created.
  365. (chmod ".." #o777))))))
  366. (package (package (inherit (dummy-package "with-snippet"))
  367. (source source)
  368. (build-system trivial-build-system)
  369. (inputs
  370. `(("tar" ,(search-bootstrap-binary "tar"
  371. (%current-system)))
  372. ("xz" ,(search-bootstrap-binary "xz"
  373. (%current-system)))))
  374. (arguments
  375. `(#:guile ,%bootstrap-guile
  376. #:modules ((guix build utils))
  377. #:builder
  378. (begin
  379. (use-modules (guix build utils))
  380. (let ((tar (assoc-ref %build-inputs "tar"))
  381. (xz (assoc-ref %build-inputs "xz"))
  382. (source (assoc-ref %build-inputs "source")))
  383. (invoke tar "xvf" source
  384. "--use-compress-program" xz)
  385. (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
  386. (file-exists? "bin/scripts/compile.scm"))
  387. (error "the snippet apparently failed"))
  388. (let ((out (assoc-ref %outputs "out")))
  389. (call-with-output-file out
  390. (lambda (p)
  391. (display "OK" p))))
  392. #t))))))
  393. (drv (package-derivation %store package))
  394. (out (derivation->output-path drv)))
  395. (and (build-derivations %store (list (pk 'snippet-drv drv)))
  396. (call-with-input-file out get-string-all))))
  397. (test-assert "return value"
  398. (let ((drv (package-derivation %store (dummy-package "p"))))
  399. (and (derivation? drv)
  400. (file-exists? (derivation-file-name drv)))))
  401. (test-assert "package-output"
  402. (let* ((package (dummy-package "p"))
  403. (drv (package-derivation %store package)))
  404. (and (derivation? drv)
  405. (string=? (derivation->output-path drv)
  406. (package-output %store package "out")))))
  407. (test-assert "patch not found yields a run-time error"
  408. (guard (c ((condition-has-type? c &message)
  409. (and (string-contains (condition-message c)
  410. "does-not-exist.patch")
  411. (string-contains (condition-message c)
  412. "not found"))))
  413. (let ((p (package
  414. (inherit (dummy-package "p"))
  415. (source (origin
  416. (method (const #f))
  417. (uri "http://whatever")
  418. (patches
  419. (list (search-patch "does-not-exist.patch")))
  420. (sha256
  421. (base32
  422. "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
  423. (package-derivation %store p)
  424. #f)))
  425. (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
  426. (test-equal "&package-input-error"
  427. (list dummy (current-module))
  428. (guard (c ((package-input-error? c)
  429. (list (package-error-package c)
  430. (package-error-invalid-input c))))
  431. (package-derivation %store dummy))))
  432. (test-assert "reference to non-existent output"
  433. ;; See <http://bugs.gnu.org/19630>.
  434. (parameterize ((%graft? #f))
  435. (let* ((dep (dummy-package "dep"))
  436. (p (dummy-package "p"
  437. (inputs `(("dep" ,dep "non-existent"))))))
  438. (guard (c ((derivation-missing-output-error? c)
  439. (and (string=? (derivation-missing-output c) "non-existent")
  440. (equal? (package-derivation %store dep)
  441. (derivation-error-derivation c)))))
  442. (package-derivation %store p)))))
  443. (test-assert "trivial"
  444. (let* ((p (package (inherit (dummy-package "trivial"))
  445. (build-system trivial-build-system)
  446. (source #f)
  447. (arguments
  448. `(#:guile ,%bootstrap-guile
  449. #:builder
  450. (begin
  451. (mkdir %output)
  452. (call-with-output-file (string-append %output "/test")
  453. (lambda (p)
  454. (display '(hello guix) p)))
  455. #t)))))
  456. (d (package-derivation %store p)))
  457. (and (build-derivations %store (list d))
  458. (let ((p (pk 'drv d (derivation->output-path d))))
  459. (equal? '(hello guix)
  460. (call-with-input-file (string-append p "/test") read))))))
  461. (test-assert "trivial with local file as input"
  462. (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
  463. (p (package (inherit (dummy-package "trivial-with-input-file"))
  464. (build-system trivial-build-system)
  465. (source #f)
  466. (arguments
  467. `(#:guile ,%bootstrap-guile
  468. #:builder (begin
  469. (copy-file (assoc-ref %build-inputs "input")
  470. %output)
  471. #t)))
  472. (inputs `(("input" ,i)))))
  473. (d (package-derivation %store p)))
  474. (and (build-derivations %store (list d))
  475. (let ((p (pk 'drv d (derivation->output-path d))))
  476. (equal? (call-with-input-file p get-bytevector-all)
  477. (call-with-input-file i get-bytevector-all))))))
  478. (test-assert "trivial with source"
  479. (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
  480. (p (package (inherit (dummy-package "trivial-with-source"))
  481. (build-system trivial-build-system)
  482. (source i)
  483. (arguments
  484. `(#:guile ,%bootstrap-guile
  485. #:builder (begin
  486. (copy-file (assoc-ref %build-inputs "source")
  487. %output)
  488. #t)))))
  489. (d (package-derivation %store p)))
  490. (and (build-derivations %store (list d))
  491. (let ((p (derivation->output-path d)))
  492. (equal? (call-with-input-file p get-bytevector-all)
  493. (call-with-input-file i get-bytevector-all))))))
  494. (test-assert "trivial with system-dependent input"
  495. (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
  496. (build-system trivial-build-system)
  497. (source #f)
  498. (arguments
  499. `(#:guile ,%bootstrap-guile
  500. #:modules ((guix build utils))
  501. #:builder
  502. (begin
  503. (use-modules (guix build utils))
  504. (let ((out (assoc-ref %outputs "out"))
  505. (bash (assoc-ref %build-inputs "bash")))
  506. (invoke bash "-c"
  507. (format #f "echo hello > ~a" out))))))
  508. (inputs `(("bash" ,(search-bootstrap-binary "bash"
  509. (%current-system)))))))
  510. (d (package-derivation %store p)))
  511. (and (build-derivations %store (list d))
  512. (let ((p (pk 'drv d (derivation->output-path d))))
  513. (eq? 'hello (call-with-input-file p read))))))
  514. (test-assert "trivial with #:allowed-references"
  515. (let* ((p (package
  516. (inherit (dummy-package "trivial"))
  517. (build-system trivial-build-system)
  518. (arguments
  519. `(#:guile ,%bootstrap-guile
  520. #:allowed-references (,%bootstrap-guile)
  521. #:builder
  522. (begin
  523. (mkdir %output)
  524. ;; The reference to itself isn't allowed so building it
  525. ;; should fail.
  526. (symlink %output (string-append %output "/self"))
  527. #t)))))
  528. (d (package-derivation %store p)))
  529. (guard (c ((nix-protocol-error? c) #t))
  530. (build-derivations %store (list d))
  531. #f)))
  532. (test-assert "search paths"
  533. (let* ((p (make-prompt-tag "return-search-paths"))
  534. (s (build-system
  535. (name 'raw)
  536. (description "Raw build system with direct store access")
  537. (lower (lambda* (name #:key source inputs system target
  538. #:allow-other-keys)
  539. (bag
  540. (name name)
  541. (system system) (target target)
  542. (build-inputs inputs)
  543. (build
  544. (lambda* (store name inputs
  545. #:key outputs system search-paths)
  546. search-paths)))))))
  547. (x (list (search-path-specification
  548. (variable "GUILE_LOAD_PATH")
  549. (files '("share/guile/site/2.0")))
  550. (search-path-specification
  551. (variable "GUILE_LOAD_COMPILED_PATH")
  552. (files '("share/guile/site/2.0")))))
  553. (a (package (inherit (dummy-package "guile"))
  554. (build-system s)
  555. (native-search-paths x)))
  556. (b (package (inherit (dummy-package "guile-foo"))
  557. (build-system s)
  558. (inputs `(("guile" ,a)))))
  559. (c (package (inherit (dummy-package "guile-bar"))
  560. (build-system s)
  561. (inputs `(("guile" ,a)
  562. ("guile-foo" ,b))))))
  563. (let-syntax ((collect (syntax-rules ()
  564. ((_ body ...)
  565. (call-with-prompt p
  566. (lambda ()
  567. body ...)
  568. (lambda (k search-paths)
  569. search-paths))))))
  570. (and (null? (collect (package-derivation %store a)))
  571. (equal? x (collect (package-derivation %store b)))
  572. (equal? x (collect (package-derivation %store c)))))))
  573. (test-assert "package-transitive-native-search-paths"
  574. (let* ((sp (lambda (name)
  575. (list (search-path-specification
  576. (variable name)
  577. (files '("foo/bar"))))))
  578. (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
  579. (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
  580. (p2 (dummy-package "p2"
  581. (native-search-paths (sp "PATH2"))
  582. (inputs `(("p0" ,p0)))
  583. (propagated-inputs `(("p1" ,p1)))))
  584. (p3 (dummy-package "p3"
  585. (native-search-paths (sp "PATH3"))
  586. (native-inputs `(("p0" ,p0)))
  587. (propagated-inputs `(("p2" ,p2))))))
  588. (lset= string=?
  589. '("PATH1" "PATH2" "PATH3")
  590. (map search-path-specification-variable
  591. (package-transitive-native-search-paths p3)))))
  592. (test-assert "package-cross-derivation"
  593. (let ((drv (package-cross-derivation %store (dummy-package "p")
  594. "mips64el-linux-gnu")))
  595. (and (derivation? drv)
  596. (file-exists? (derivation-file-name drv)))))
  597. (test-assert "package-cross-derivation, trivial-build-system"
  598. (let ((p (package (inherit (dummy-package "p"))
  599. (build-system trivial-build-system)
  600. (arguments '(#:builder (exit 1))))))
  601. (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
  602. (derivation? drv))))
  603. (test-assert "package-cross-derivation, no cross builder"
  604. (let* ((b (build-system (inherit trivial-build-system)
  605. (lower (const #f))))
  606. (p (package (inherit (dummy-package "p"))
  607. (build-system b))))
  608. (guard (c ((package-cross-build-system-error? c)
  609. (eq? (package-error-package c) p)))
  610. (package-cross-derivation %store p "mips64el-linux-gnu")
  611. #f)))
  612. ;; XXX: The next two tests can trigger builds when the distro defines
  613. ;; replacements on core packages, so they're disable for lack of a better
  614. ;; solution.
  615. ;; (test-equal "package-derivation, direct graft"
  616. ;; (package-derivation %store gnu-make #:graft? #f)
  617. ;; (let ((p (package (inherit coreutils)
  618. ;; (replacement gnu-make))))
  619. ;; (package-derivation %store p #:graft? #t)))
  620. ;; (test-equal "package-cross-derivation, direct graft"
  621. ;; (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
  622. ;; #:graft? #f)
  623. ;; (let ((p (package (inherit coreutils)
  624. ;; (replacement gnu-make))))
  625. ;; (package-cross-derivation %store p "mips64el-linux-gnu"
  626. ;; #:graft? #t)))
  627. (test-assert "package-grafts, indirect grafts"
  628. (let* ((new (dummy-package "dep"
  629. (arguments '(#:implicit-inputs? #f))))
  630. (dep (package (inherit new) (version "0.0")))
  631. (dep* (package (inherit dep) (replacement new)))
  632. (dummy (dummy-package "dummy"
  633. (arguments '(#:implicit-inputs? #f))
  634. (inputs `(("dep" ,dep*))))))
  635. (equal? (package-grafts %store dummy)
  636. (list (graft
  637. (origin (package-derivation %store dep))
  638. (replacement (package-derivation %store new)))))))
  639. ;; XXX: This test would require building the cross toolchain just to see if it
  640. ;; needs grafting, which is obviously too expensive, and thus disabled.
  641. ;;
  642. ;; (test-assert "package-grafts, indirect grafts, cross"
  643. ;; (let* ((new (dummy-package "dep"
  644. ;; (arguments '(#:implicit-inputs? #f))))
  645. ;; (dep (package (inherit new) (version "0.0")))
  646. ;; (dep* (package (inherit dep) (replacement new)))
  647. ;; (dummy (dummy-package "dummy"
  648. ;; (arguments '(#:implicit-inputs? #f))
  649. ;; (inputs `(("dep" ,dep*)))))
  650. ;; (target "mips64el-linux-gnu"))
  651. ;; ;; XXX: There might be additional grafts, for instance if the distro
  652. ;; ;; defines replacements for core packages like Perl.
  653. ;; (member (graft
  654. ;; (origin (package-cross-derivation %store dep target))
  655. ;; (replacement
  656. ;; (package-cross-derivation %store new target)))
  657. ;; (package-grafts %store dummy #:target target))))
  658. (test-assert "package-grafts, indirect grafts, propagated inputs"
  659. (let* ((new (dummy-package "dep"
  660. (arguments '(#:implicit-inputs? #f))))
  661. (dep (package (inherit new) (version "0.0")))
  662. (dep* (package (inherit dep) (replacement new)))
  663. (prop (dummy-package "propagated"
  664. (propagated-inputs `(("dep" ,dep*)))
  665. (arguments '(#:implicit-inputs? #f))))
  666. (dummy (dummy-package "dummy"
  667. (arguments '(#:implicit-inputs? #f))
  668. (inputs `(("prop" ,prop))))))
  669. (equal? (package-grafts %store dummy)
  670. (list (graft
  671. (origin (package-derivation %store dep))
  672. (replacement (package-derivation %store new)))))))
  673. (test-assert "package-grafts, same replacement twice"
  674. (let* ((new (dummy-package "dep"
  675. (version "1")
  676. (arguments '(#:implicit-inputs? #f))))
  677. (dep (package (inherit new) (version "0") (replacement new)))
  678. (p1 (dummy-package "intermediate1"
  679. (arguments '(#:implicit-inputs? #f))
  680. (inputs `(("dep" ,dep)))))
  681. (p2 (dummy-package "intermediate2"
  682. (arguments '(#:implicit-inputs? #f))
  683. ;; Here we copy DEP to have an equivalent package that is not
  684. ;; 'eq?' to DEP. This is similar to what happens with
  685. ;; 'package-with-explicit-inputs' & co.
  686. (inputs `(("dep" ,(package (inherit dep)))))))
  687. (p3 (dummy-package "final"
  688. (arguments '(#:implicit-inputs? #f))
  689. (inputs `(("p1" ,p1) ("p2" ,p2))))))
  690. (equal? (package-grafts %store p3)
  691. (list (graft
  692. (origin (package-derivation %store
  693. (package (inherit dep)
  694. (replacement #f))))
  695. (replacement (package-derivation %store new)))))))
  696. (test-assert "replacement also grafted"
  697. ;; We build a DAG as below, where dotted arrows represent replacements and
  698. ;; solid arrows represent dependencies:
  699. ;;
  700. ;; P1 ·············> P1R
  701. ;; |\__________________.
  702. ;; v v
  703. ;; P2 ·············> P2R
  704. ;; |
  705. ;; v
  706. ;; P3
  707. ;;
  708. ;; We want to make sure that:
  709. ;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
  710. ;; where:
  711. ;; (A,B) is a graft to replace A by B
  712. ;; grafted(DRV,G) denoted DRV with graft G applied
  713. (let* ((p1r (dummy-package "P1"
  714. (build-system trivial-build-system)
  715. (arguments
  716. `(#:guile ,%bootstrap-guile
  717. #:builder (let ((out (assoc-ref %outputs "out")))
  718. (mkdir out)
  719. (call-with-output-file
  720. (string-append out "/replacement")
  721. (const #t)))))))
  722. (p1 (package
  723. (inherit p1r) (name "p1") (replacement p1r)
  724. (arguments
  725. `(#:guile ,%bootstrap-guile
  726. #:builder (begin
  727. (mkdir (assoc-ref %outputs "out"))
  728. #t)))))
  729. (p2r (dummy-package "P2"
  730. (build-system trivial-build-system)
  731. (inputs `(("p1" ,p1)))
  732. (arguments
  733. `(#:guile ,%bootstrap-guile
  734. #:builder (let ((out (assoc-ref %outputs "out")))
  735. (mkdir out)
  736. (chdir out)
  737. (symlink (assoc-ref %build-inputs "p1") "p1")
  738. (call-with-output-file (string-append out "/replacement")
  739. (const #t)))))))
  740. (p2 (package
  741. (inherit p2r) (name "p2") (replacement p2r)
  742. (arguments
  743. `(#:guile ,%bootstrap-guile
  744. #:builder (let ((out (assoc-ref %outputs "out")))
  745. (mkdir out)
  746. (chdir out)
  747. (symlink (assoc-ref %build-inputs "p1")
  748. "p1")
  749. #t)))))
  750. (p3 (dummy-package "p3"
  751. (build-system trivial-build-system)
  752. (inputs `(("p2" ,p2)))
  753. (arguments
  754. `(#:guile ,%bootstrap-guile
  755. #:builder (let ((out (assoc-ref %outputs "out")))
  756. (mkdir out)
  757. (chdir out)
  758. (symlink (assoc-ref %build-inputs "p2")
  759. "p2")
  760. #t))))))
  761. (lset= equal?
  762. (package-grafts %store p3)
  763. (list (graft
  764. (origin (package-derivation %store p1 #:graft? #f))
  765. (replacement (package-derivation %store p1r)))
  766. (graft
  767. (origin (package-derivation %store p2 #:graft? #f))
  768. (replacement
  769. (package-derivation %store p2r #:graft? #t)))))))
  770. ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
  771. ;;; find out about their run-time dependencies, so this test is no longer
  772. ;;; applicable since it would trigger a full rebuild.
  773. ;;
  774. ;; (test-assert "package-derivation, indirect grafts"
  775. ;; (let* ((new (dummy-package "dep"
  776. ;; (arguments '(#:implicit-inputs? #f))))
  777. ;; (dep (package (inherit new) (version "0.0")))
  778. ;; (dep* (package (inherit dep) (replacement new)))
  779. ;; (dummy (dummy-package "dummy"
  780. ;; (arguments '(#:implicit-inputs? #f))
  781. ;; (inputs `(("dep" ,dep*)))))
  782. ;; (guile (package-derivation %store (canonical-package guile-2.0)
  783. ;; #:graft? #f)))
  784. ;; (equal? (package-derivation %store dummy)
  785. ;; (graft-derivation %store
  786. ;; (package-derivation %store dummy #:graft? #f)
  787. ;; (package-grafts %store dummy)
  788. ;; ;; Use the same Guile as 'package-derivation'.
  789. ;; #:guile guile))))
  790. (test-equal "package->bag"
  791. `("foo86-hurd" #f (,(package-source gnu-make))
  792. (,(canonical-package glibc)) (,(canonical-package coreutils)))
  793. (let ((bag (package->bag gnu-make "foo86-hurd")))
  794. (list (bag-system bag) (bag-target bag)
  795. (assoc-ref (bag-build-inputs bag) "source")
  796. (assoc-ref (bag-build-inputs bag) "libc")
  797. (assoc-ref (bag-build-inputs bag) "coreutils"))))
  798. (test-equal "package->bag, cross-compilation"
  799. `(,(%current-system) "foo86-hurd"
  800. (,(package-source gnu-make))
  801. (,(canonical-package glibc)) (,(canonical-package coreutils)))
  802. (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
  803. (list (bag-system bag) (bag-target bag)
  804. (assoc-ref (bag-build-inputs bag) "source")
  805. (assoc-ref (bag-build-inputs bag) "libc")
  806. (assoc-ref (bag-build-inputs bag) "coreutils"))))
  807. (test-assert "package->bag, propagated inputs"
  808. (let* ((dep (dummy-package "dep"))
  809. (prop (dummy-package "prop"
  810. (propagated-inputs `(("dep" ,dep)))))
  811. (dummy (dummy-package "dummy"
  812. (inputs `(("prop" ,prop)))))
  813. (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
  814. (match (assoc "dep" inputs)
  815. (("dep" package)
  816. (eq? package dep)))))
  817. (test-assert "bag->derivation"
  818. (parameterize ((%graft? #f))
  819. (let ((bag (package->bag gnu-make))
  820. (drv (package-derivation %store gnu-make)))
  821. (parameterize ((%current-system "foox86-hurd")) ;should have no effect
  822. (equal? drv (bag->derivation %store bag))))))
  823. (test-assert "bag->derivation, cross-compilation"
  824. (parameterize ((%graft? #f))
  825. (let* ((target "mips64el-linux-gnu")
  826. (bag (package->bag gnu-make (%current-system) target))
  827. (drv (package-cross-derivation %store gnu-make target)))
  828. (parameterize ((%current-system "foox86-hurd") ;should have no effect
  829. (%current-target-system "foo64-linux-gnu"))
  830. (equal? drv (bag->derivation %store bag))))))
  831. (when (or (not (network-reachable?)) (shebang-too-long?))
  832. (test-skip 1))
  833. (test-assert "GNU Make, bootstrap"
  834. ;; GNU Make is the first program built during bootstrap; we choose it
  835. ;; here so that the test doesn't last for too long.
  836. (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0)))
  837. (and (package? gnu-make)
  838. (or (location? (package-location gnu-make))
  839. (not (package-location gnu-make)))
  840. (let* ((drv (package-derivation %store gnu-make))
  841. (out (derivation->output-path drv)))
  842. (and (build-derivations %store (list drv))
  843. (file-exists? (string-append out "/bin/make")))))))
  844. (test-equal "package-mapping"
  845. 42
  846. (let* ((dep (dummy-package "chbouib"
  847. (native-inputs `(("x" ,grep)))))
  848. (p0 (dummy-package "example"
  849. (inputs `(("foo" ,coreutils)
  850. ("bar" ,grep)
  851. ("baz" ,dep)))))
  852. (transform (lambda (p)
  853. (package (inherit p) (source 42))))
  854. (rewrite (package-mapping transform))
  855. (p1 (rewrite p0)))
  856. (and (eq? p1 (rewrite p0))
  857. (eqv? 42 (package-source p1))
  858. (match (package-inputs p1)
  859. ((("foo" dep1) ("bar" dep2) ("baz" dep3))
  860. (and (eq? dep1 (rewrite coreutils)) ;memoization
  861. (eq? dep2 (rewrite grep))
  862. (eq? dep3 (rewrite dep))
  863. (eqv? 42
  864. (package-source dep1) (package-source dep2)
  865. (package-source dep3))
  866. (match (package-native-inputs dep3)
  867. ((("x" dep))
  868. (and (eq? dep (rewrite grep))
  869. (package-source dep))))))))))
  870. (test-assert "package-input-rewriting"
  871. (let* ((dep (dummy-package "chbouib"
  872. (native-inputs `(("x" ,grep)))))
  873. (p0 (dummy-package "example"
  874. (inputs `(("foo" ,coreutils)
  875. ("bar" ,grep)
  876. ("baz" ,dep)))))
  877. (rewrite (package-input-rewriting `((,coreutils . ,sed)
  878. (,grep . ,findutils))
  879. (cut string-append "r-" <>)))
  880. (p1 (rewrite p0))
  881. (p2 (rewrite p0)))
  882. (and (not (eq? p1 p0))
  883. (eq? p1 p2) ;memoization
  884. (string=? "r-example" (package-name p1))
  885. (match (package-inputs p1)
  886. ((("foo" dep1) ("bar" dep2) ("baz" dep3))
  887. (and (eq? dep1 sed)
  888. (eq? dep2 findutils)
  889. (string=? (package-name dep3) "r-chbouib")
  890. (eq? dep3 (rewrite dep)) ;memoization
  891. (match (package-native-inputs dep3)
  892. ((("x" dep))
  893. (eq? dep findutils)))))))))
  894. (test-equal "package-patched-vulnerabilities"
  895. '(("CVE-2015-1234")
  896. ("CVE-2016-1234" "CVE-2018-4567")
  897. ())
  898. (let ((p1 (dummy-package "pi"
  899. (source (dummy-origin
  900. (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
  901. (p2 (dummy-package "pi"
  902. (source (dummy-origin
  903. (patches (list
  904. "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
  905. (p3 (dummy-package "pi" (source (dummy-origin)))))
  906. (map package-patched-vulnerabilities
  907. (list p1 p2 p3))))
  908. (test-eq "fold-packages" hello
  909. (fold-packages (lambda (p r)
  910. (if (string=? (package-name p) "hello")
  911. p
  912. r))
  913. #f))
  914. (test-assert "fold-packages, hidden package"
  915. ;; There are two public variables providing "guile@2.0" ('guile-final' in
  916. ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
  917. ;; should show up.
  918. (match (fold-packages (lambda (p r)
  919. (if (and (string=? (package-name p) "guile")
  920. (string-prefix? "2.0"
  921. (package-version p)))
  922. (cons p r)
  923. r))
  924. '())
  925. ((one)
  926. (eq? one guile-2.0))))
  927. (test-assert "find-packages-by-name"
  928. (match (find-packages-by-name "hello")
  929. (((? (cut eq? hello <>))) #t)
  930. (wrong (pk 'find-packages-by-name wrong #f))))
  931. (test-assert "find-packages-by-name with version"
  932. (match (find-packages-by-name "hello" (package-version hello))
  933. (((? (cut eq? hello <>))) #t)
  934. (wrong (pk 'find-packages-by-name wrong #f))))
  935. (test-assert "--search-paths with pattern"
  936. ;; Make sure 'guix package --search-paths' correctly reports environment
  937. ;; variables when file patterns are used (in particular, it must follow
  938. ;; symlinks when looking for 'catalog.xml'.) To do that, we rely on the
  939. ;; libxml2 package specification, which contains such a definition.
  940. (let* ((p1 (package
  941. (name "foo") (version "0") (source #f)
  942. (build-system trivial-build-system)
  943. (arguments
  944. `(#:guile ,%bootstrap-guile
  945. #:modules ((guix build utils))
  946. #:builder (begin
  947. (use-modules (guix build utils))
  948. (let ((out (assoc-ref %outputs "out")))
  949. (mkdir-p (string-append out "/xml/bar/baz"))
  950. (call-with-output-file
  951. (string-append out "/xml/bar/baz/catalog.xml")
  952. (lambda (port)
  953. (display "xml? wat?!" port)))
  954. #t))))
  955. (synopsis #f) (description #f)
  956. (home-page #f) (license #f)))
  957. (p2 (package
  958. ;; Provide a fake libxml2 to avoid building the real one. This
  959. ;; is OK because 'guix package' gets search path specifications
  960. ;; from the same-named package found in the distro.
  961. (name "libxml2") (version "0.0.0") (source #f)
  962. (build-system trivial-build-system)
  963. (arguments
  964. `(#:guile ,%bootstrap-guile
  965. #:builder (begin
  966. (mkdir (assoc-ref %outputs "out"))
  967. #t)))
  968. (native-search-paths (package-native-search-paths libxml2))
  969. (synopsis #f) (description #f)
  970. (home-page #f) (license #f)))
  971. (prof (run-with-store %store
  972. (profile-derivation
  973. (manifest (map package->manifest-entry
  974. (list p1 p2)))
  975. #:hooks '()
  976. #:locales? #f)
  977. #:guile-for-build (%guile-for-build))))
  978. (build-derivations %store (list prof))
  979. (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
  980. (regexp-quote (derivation->output-path prof)))
  981. (with-output-to-string
  982. (lambda ()
  983. (guix-package "-p" (derivation->output-path prof)
  984. "--search-paths"))))))
  985. (test-assert "--search-paths with single-item search path"
  986. ;; Make sure 'guix package --search-paths' correctly reports environment
  987. ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
  988. ;; separator, meaning that the first match wins.
  989. (let* ((p1 (dummy-package "foo"
  990. (build-system trivial-build-system)
  991. (arguments
  992. `(#:guile ,%bootstrap-guile
  993. #:modules ((guix build utils))
  994. #:builder (begin
  995. (use-modules (guix build utils))
  996. (let ((out (assoc-ref %outputs "out")))
  997. (mkdir-p (string-append out "/etc/ssl/certs"))
  998. (call-with-output-file
  999. (string-append
  1000. out "/etc/ssl/certs/ca-certificates.crt")
  1001. (const #t))))))))
  1002. (p2 (package (inherit p1) (name "bar")))
  1003. (p3 (dummy-package "git"
  1004. ;; Provide a fake Git to avoid building the real one.
  1005. (build-system trivial-build-system)
  1006. (arguments
  1007. `(#:guile ,%bootstrap-guile
  1008. #:builder (begin
  1009. (mkdir (assoc-ref %outputs "out"))
  1010. #t)))
  1011. (native-search-paths (package-native-search-paths git))))
  1012. (prof1 (run-with-store %store
  1013. (profile-derivation
  1014. (packages->manifest (list p1 p3))
  1015. #:hooks '()
  1016. #:locales? #f)
  1017. #:guile-for-build (%guile-for-build)))
  1018. (prof2 (run-with-store %store
  1019. (profile-derivation
  1020. (packages->manifest (list p2 p3))
  1021. #:hooks '()
  1022. #:locales? #f)
  1023. #:guile-for-build (%guile-for-build))))
  1024. (build-derivations %store (list prof1 prof2))
  1025. (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
  1026. (regexp-quote (derivation->output-path prof1)))
  1027. (with-output-to-string
  1028. (lambda ()
  1029. (guix-package "-p" (derivation->output-path prof1)
  1030. "-p" (derivation->output-path prof2)
  1031. "--search-paths"))))))
  1032. (test-equal "specification->package when not found"
  1033. 'quit
  1034. (catch 'quit
  1035. (lambda ()
  1036. ;; This should call 'leave', producing an error message.
  1037. (specification->package "this-package-does-not-exist"))
  1038. (lambda (key . args)
  1039. key)))
  1040. (test-end "packages")
  1041. ;;; Local Variables:
  1042. ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
  1043. ;;; End: