profiles.scm 28 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (test-profiles)
  20. #:use-module (guix tests)
  21. #:use-module (guix profiles)
  22. #:use-module (guix gexp)
  23. #:use-module (guix store)
  24. #:use-module (guix monads)
  25. #:use-module (guix grafts)
  26. #:use-module (guix packages)
  27. #:use-module (guix derivations)
  28. #:use-module (guix build-system trivial)
  29. #:use-module (gnu packages bootstrap)
  30. #:use-module ((gnu packages base) #:prefix packages:)
  31. #:use-module ((gnu packages guile) #:prefix packages:)
  32. #:use-module (ice-9 match)
  33. #:use-module (ice-9 regex)
  34. #:use-module (ice-9 popen)
  35. #:use-module (rnrs io ports)
  36. #:use-module (srfi srfi-1)
  37. #:use-module (srfi srfi-11)
  38. #:use-module (srfi srfi-34)
  39. #:use-module (srfi srfi-64))
  40. ;; Test the (guix profiles) module.
  41. (define %store
  42. (open-connection-for-tests))
  43. ;; Globally disable grafts because they can trigger early builds.
  44. (%graft? #f)
  45. ;; Example manifest entries.
  46. (define guile-1.8.8
  47. (manifest-entry
  48. (name "guile")
  49. (version "1.8.8")
  50. (item "/gnu/store/...")
  51. (output "out")))
  52. (define guile-2.0.9
  53. (manifest-entry
  54. (name "guile")
  55. (version "2.0.9")
  56. (item "/gnu/store/...")
  57. (output "out")))
  58. (define guile-2.0.9:debug
  59. (manifest-entry (inherit guile-2.0.9)
  60. (output "debug")))
  61. (define glibc
  62. (manifest-entry
  63. (name "glibc")
  64. (version "2.19")
  65. (item "/gnu/store/...")
  66. (output "out")))
  67. (test-begin "profiles")
  68. (test-assert "manifest-installed?"
  69. (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
  70. (and (manifest-installed? m (manifest-pattern (name "guile")))
  71. (manifest-installed? m (manifest-pattern
  72. (name "guile") (output "debug")))
  73. (manifest-installed? m (manifest-pattern
  74. (name "guile") (output "out")
  75. (version "2.0.9")))
  76. (not (manifest-installed?
  77. m (manifest-pattern (name "guile") (version "1.8.8"))))
  78. (not (manifest-installed?
  79. m (manifest-pattern (name "guile") (output "foobar")))))))
  80. (test-assert "manifest-matching-entries"
  81. (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
  82. (m (manifest e)))
  83. (and (equal? e
  84. (manifest-matching-entries m
  85. (list (manifest-pattern
  86. (name "guile")
  87. (output #f)))))
  88. (equal? (list guile-2.0.9)
  89. (manifest-matching-entries m
  90. (list (manifest-pattern
  91. (name "guile")
  92. (version "2.0.9"))))))))
  93. (test-assert "manifest-matching-entries, no match"
  94. (let ((m (manifest (list guile-2.0.9)))
  95. (p (manifest-pattern (name "python"))))
  96. (guard (c ((unmatched-pattern-error? c)
  97. (and (eq? p (unmatched-pattern-error-pattern c))
  98. (eq? m (unmatched-pattern-error-manifest c)))))
  99. (manifest-matching-entries m (list p))
  100. #f)))
  101. (test-equal "concatenate-manifests"
  102. (manifest (list guile-2.0.9 glibc))
  103. (concatenate-manifests (list (manifest (list guile-2.0.9))
  104. (manifest (list glibc)))))
  105. (test-assert "manifest-remove"
  106. (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
  107. (m1 (manifest-remove m0
  108. (list (manifest-pattern (name "guile")))))
  109. (m2 (manifest-remove m1
  110. (list (manifest-pattern (name "guile"))))) ; same
  111. (m3 (manifest-remove m2
  112. (list (manifest-pattern
  113. (name "guile") (output "debug")))))
  114. (m4 (manifest-remove m3
  115. (list (manifest-pattern (name "guile"))))))
  116. (match (manifest-entries m2)
  117. ((($ <manifest-entry> "guile" "2.0.9" "debug"))
  118. (and (equal? m1 m2)
  119. (null? (manifest-entries m3))
  120. (null? (manifest-entries m4)))))))
  121. (test-assert "manifest-add"
  122. (let* ((m0 (manifest '()))
  123. (m1 (manifest-add m0 (list guile-1.8.8)))
  124. (m2 (manifest-add m1 (list guile-2.0.9)))
  125. (m3 (manifest-add m2 (list guile-2.0.9:debug)))
  126. (m4 (manifest-add m3 (list guile-2.0.9:debug))))
  127. (and (match (manifest-entries m1)
  128. ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
  129. (_ #f))
  130. (match (manifest-entries m2)
  131. ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
  132. (_ #f))
  133. (equal? m3 m4))))
  134. (test-equal "manifest-add removes duplicates" ;<https://bugs.gnu.org/30569>
  135. (list guile-2.0.9)
  136. (manifest-entries (manifest-add (manifest '())
  137. (list guile-2.0.9 guile-2.0.9))))
  138. (test-assert "manifest-perform-transaction"
  139. (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
  140. (t1 (manifest-transaction
  141. (install (list guile-1.8.8))
  142. (remove (list (manifest-pattern (name "guile")
  143. (output "debug"))))))
  144. (t2 (manifest-transaction
  145. (remove (list (manifest-pattern (name "guile")
  146. (version "2.0.9")
  147. (output #f))))))
  148. (m1 (manifest-perform-transaction m0 t1))
  149. (m2 (manifest-perform-transaction m1 t2))
  150. (m3 (manifest-perform-transaction m0 t2)))
  151. (and (match (manifest-entries m1)
  152. ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
  153. (_ #f))
  154. (equal? m1 m2)
  155. (null? (manifest-entries m3)))))
  156. (test-assert "manifest-transaction-effects"
  157. (let* ((m0 (manifest (list guile-1.8.8)))
  158. (t (manifest-transaction
  159. (install (list guile-2.0.9 glibc)))))
  160. (let-values (((remove install upgrade downgrade)
  161. (manifest-transaction-effects m0 t)))
  162. (and (null? remove) (null? downgrade)
  163. (equal? (list glibc) install)
  164. (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
  165. (test-assert "manifest-transaction-effects and downgrades"
  166. (let* ((m0 (manifest (list guile-2.0.9)))
  167. (t (manifest-transaction (install (list guile-1.8.8)))))
  168. (let-values (((remove install upgrade downgrade)
  169. (manifest-transaction-effects m0 t)))
  170. (and (null? remove) (null? install) (null? upgrade)
  171. (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
  172. (test-assert "manifest-transaction-effects and pseudo-upgrades"
  173. (let* ((m0 (manifest (list guile-2.0.9)))
  174. (t (manifest-transaction (install (list guile-2.0.9)))))
  175. (let-values (((remove install upgrade downgrade)
  176. (manifest-transaction-effects m0 t)))
  177. (and (null? remove) (null? install) (null? downgrade)
  178. (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))
  179. (test-assert "manifest-transaction-null?"
  180. (manifest-transaction-null? (manifest-transaction)))
  181. (test-assert "manifest-transaction-removal-candidate?"
  182. (let ((m (manifest (list guile-2.0.9)))
  183. (t (manifest-transaction
  184. (remove (list (manifest-pattern (name "guile")))))))
  185. (and (manifest-transaction-removal-candidate? guile-2.0.9 t)
  186. (not (manifest-transaction-removal-candidate? glibc t)))))
  187. (test-assertm "profile-derivation"
  188. (mlet* %store-monad
  189. ((entry -> (package->manifest-entry %bootstrap-guile))
  190. (guile (package->derivation %bootstrap-guile))
  191. (drv (profile-derivation (manifest (list entry))
  192. #:hooks '()
  193. #:locales? #f))
  194. (profile -> (derivation->output-path drv))
  195. (bindir -> (string-append profile "/bin"))
  196. (_ (built-derivations (list drv))))
  197. (return (and (file-exists? (string-append bindir "/guile"))
  198. (string=? (dirname (readlink bindir))
  199. (derivation->output-path guile))))))
  200. (test-assertm "<profile>"
  201. (mlet* %store-monad
  202. ((entry -> (package->manifest-entry %bootstrap-guile))
  203. (profile -> (profile (hooks '()) (locales? #f)
  204. (content (manifest (list entry)))))
  205. (drv (lower-object profile))
  206. (profile -> (derivation->output-path drv))
  207. (bindir -> (string-append profile "/bin"))
  208. (_ (built-derivations (list drv))))
  209. (return (file-exists? (string-append bindir "/guile")))))
  210. (test-assertm "profile-derivation relative symlinks, one entry"
  211. (mlet* %store-monad
  212. ((entry -> (package->manifest-entry %bootstrap-guile))
  213. (guile (package->derivation %bootstrap-guile))
  214. (drv (profile-derivation (manifest (list entry))
  215. #:relative-symlinks? #t
  216. #:hooks '()
  217. #:locales? #f))
  218. (profile -> (derivation->output-path drv))
  219. (bindir -> (string-append profile "/bin"))
  220. (_ (built-derivations (list drv))))
  221. (return (and (file-exists? (string-append bindir "/guile"))
  222. (string=? (readlink bindir)
  223. (string-append "../"
  224. (basename
  225. (derivation->output-path guile))
  226. "/bin"))))))
  227. (unless (network-reachable?) (test-skip 1))
  228. (test-assertm "profile-derivation relative symlinks, two entries"
  229. (mlet* %store-monad
  230. ((manifest -> (packages->manifest
  231. (list %bootstrap-guile gnu-make-for-tests)))
  232. (guile (package->derivation %bootstrap-guile))
  233. (make (package->derivation gnu-make-for-tests))
  234. (drv (profile-derivation manifest
  235. #:relative-symlinks? #t
  236. #:hooks '()
  237. #:locales? #f))
  238. (profile -> (derivation->output-path drv))
  239. (bindir -> (string-append profile "/bin"))
  240. (_ (built-derivations (list drv))))
  241. (return (and (file-exists? (string-append bindir "/guile"))
  242. (file-exists? (string-append bindir "/make"))
  243. (string=? (readlink (string-append bindir "/guile"))
  244. (string-append "../../"
  245. (basename
  246. (derivation->output-path guile))
  247. "/bin/guile"))
  248. (string=? (readlink (string-append bindir "/make"))
  249. (string-append "../../"
  250. (basename
  251. (derivation->output-path make))
  252. "/bin/make"))))))
  253. (test-assertm "profile-derivation, inputs"
  254. (mlet* %store-monad
  255. ((entry -> (package->manifest-entry packages:glibc "debug"))
  256. (drv (profile-derivation (manifest (list entry))
  257. #:hooks '()
  258. #:locales? #f)))
  259. (return (derivation-inputs drv))))
  260. (test-assertm "profile-derivation, cross-compilation"
  261. (mlet* %store-monad
  262. ((manifest -> (packages->manifest (list packages:sed packages:grep)))
  263. (target -> "arm-linux-gnueabihf")
  264. (grep (package->cross-derivation packages:grep target))
  265. (sed (package->cross-derivation packages:sed target))
  266. (locales (package->derivation packages:glibc-utf8-locales))
  267. (drv (profile-derivation manifest
  268. #:hooks '()
  269. #:locales? #t
  270. #:target target)))
  271. (define (find-input package)
  272. (let ((name (string-append (package-full-name package "-") ".drv")))
  273. (any (lambda (input)
  274. (let ((input (derivation-input-path input)))
  275. (and (string-suffix? name input) input)))
  276. (derivation-inputs drv))))
  277. ;; The inputs for grep and sed should be cross-build derivations, but that
  278. ;; for the glibc-utf8-locales should be a native build.
  279. (return (and (string=? (derivation-system drv) (%current-system))
  280. (string=? (find-input packages:grep)
  281. (derivation-file-name grep))
  282. (string=? (find-input packages:sed)
  283. (derivation-file-name sed))
  284. (string=? (find-input packages:glibc-utf8-locales)
  285. (derivation-file-name locales))))))
  286. (test-assert "package->manifest-entry defaults to \"out\""
  287. (let ((outputs (package-outputs packages:glibc)))
  288. (equal? (manifest-entry-output
  289. (package->manifest-entry (package
  290. (inherit packages:glibc)
  291. (outputs (reverse outputs)))))
  292. (manifest-entry-output
  293. (package->manifest-entry packages:glibc))
  294. "out")))
  295. (test-assertm "profile-manifest, search-paths"
  296. (mlet* %store-monad
  297. ((guile -> (package
  298. (inherit %bootstrap-guile)
  299. (native-search-paths
  300. (package-native-search-paths packages:guile-2.0))))
  301. (entry -> (package->manifest-entry guile))
  302. (drv (profile-derivation (manifest (list entry))
  303. #:hooks '()
  304. #:locales? #f))
  305. (profile -> (derivation->output-path drv)))
  306. (mbegin %store-monad
  307. (built-derivations (list drv))
  308. ;; Read the manifest back and make sure search paths are preserved.
  309. (let ((manifest (profile-manifest profile)))
  310. (match (manifest-entries manifest)
  311. ((result)
  312. (return (equal? (manifest-entry-search-paths result)
  313. (manifest-entry-search-paths entry)
  314. (package-native-search-paths
  315. packages:guile-2.0)))))))))
  316. (test-assert "package->manifest-entry, search paths"
  317. ;; See <http://bugs.gnu.org/22073>.
  318. (let ((mpl (@ (gnu packages python-xyz) python2-matplotlib)))
  319. (lset= eq?
  320. (package-transitive-native-search-paths mpl)
  321. (manifest-entry-search-paths
  322. (package->manifest-entry mpl)))))
  323. (test-equal "packages->manifest, propagated inputs"
  324. (map (match-lambda
  325. ((label package)
  326. (list (package-name package) (package-version package)
  327. package)))
  328. (package-propagated-inputs packages:guile-2.2))
  329. (map (lambda (entry)
  330. (list (manifest-entry-name entry)
  331. (manifest-entry-version entry)
  332. (manifest-entry-item entry)))
  333. (manifest-entry-dependencies
  334. (package->manifest-entry packages:guile-2.2))))
  335. (test-assert "manifest-entry-parent"
  336. (let ((entry (package->manifest-entry packages:guile-2.2)))
  337. (match (manifest-entry-dependencies entry)
  338. ((dependencies ..1)
  339. (and (every (lambda (parent)
  340. (eq? entry (force parent)))
  341. (map manifest-entry-parent dependencies))
  342. (not (force (manifest-entry-parent entry))))))))
  343. (test-assertm "read-manifest"
  344. (mlet* %store-monad ((manifest -> (packages->manifest
  345. (list (package
  346. (inherit %bootstrap-guile)
  347. (native-search-paths
  348. (package-native-search-paths
  349. packages:guile-2.0))))))
  350. (drv (profile-derivation manifest
  351. #:hooks '()
  352. #:locales? #f))
  353. (out -> (derivation->output-path drv)))
  354. (define (entry->sexp entry)
  355. (list (manifest-entry-name entry)
  356. (manifest-entry-version entry)
  357. (manifest-entry-search-paths entry)
  358. (manifest-entry-dependencies entry)
  359. (force (manifest-entry-parent entry))))
  360. (mbegin %store-monad
  361. (built-derivations (list drv))
  362. (let ((manifest2 (profile-manifest out)))
  363. (return (equal? (map entry->sexp (manifest-entries manifest))
  364. (map entry->sexp (manifest-entries manifest2))))))))
  365. (test-equal "collision"
  366. '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
  367. (guard (c ((profile-collision-error? c)
  368. (let ((entry1 (profile-collision-error-entry c))
  369. (entry2 (profile-collision-error-conflict c)))
  370. (list (list (manifest-entry-name entry1)
  371. (manifest-entry-version entry1))
  372. (list (manifest-entry-name entry2)
  373. (manifest-entry-version entry2))))))
  374. (run-with-store %store
  375. (mlet* %store-monad ((p0 -> (package
  376. (inherit %bootstrap-guile)
  377. (version "42")))
  378. (p1 -> (dummy-package "p1"
  379. (propagated-inputs `(("p0" ,p0)))))
  380. (manifest -> (packages->manifest
  381. (list %bootstrap-guile p1)))
  382. (drv (profile-derivation manifest
  383. #:hooks '()
  384. #:locales? #f)))
  385. (return #f)))))
  386. (test-equal "collision of propagated inputs"
  387. '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
  388. (guard (c ((profile-collision-error? c)
  389. (let ((entry1 (profile-collision-error-entry c))
  390. (entry2 (profile-collision-error-conflict c)))
  391. (list (list (manifest-entry-name entry1)
  392. (manifest-entry-version entry1))
  393. (list (manifest-entry-name entry2)
  394. (manifest-entry-version entry2))))))
  395. (run-with-store %store
  396. (mlet* %store-monad ((p0 -> (package
  397. (inherit %bootstrap-guile)
  398. (version "42")))
  399. (p1 -> (dummy-package "p1"
  400. (propagated-inputs
  401. `(("guile" ,%bootstrap-guile)))))
  402. (p2 -> (dummy-package "p2"
  403. (propagated-inputs
  404. `(("guile" ,p0)))))
  405. (manifest -> (packages->manifest (list p1 p2)))
  406. (drv (profile-derivation manifest
  407. #:hooks '()
  408. #:locales? #f)))
  409. (return #f)))))
  410. (test-assertm "no collision"
  411. ;; Here we have an entry that is "lowered" (its 'item' field is a store file
  412. ;; name) and another entry (its 'item' field is a package) that is
  413. ;; equivalent.
  414. (mlet* %store-monad ((p -> (dummy-package "p"
  415. (propagated-inputs
  416. `(("guile" ,%bootstrap-guile)))))
  417. (guile (package->derivation %bootstrap-guile))
  418. (entry -> (manifest-entry
  419. (inherit (package->manifest-entry
  420. %bootstrap-guile))
  421. (item (derivation->output-path guile))))
  422. (manifest -> (manifest
  423. (list entry
  424. (package->manifest-entry p))))
  425. (drv (profile-derivation manifest)))
  426. (return (->bool drv))))
  427. (test-assertm "etc/profile"
  428. ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
  429. (mlet* %store-monad
  430. ((guile -> (package
  431. (inherit %bootstrap-guile)
  432. (native-search-paths
  433. (package-native-search-paths packages:guile-2.0))))
  434. (entry -> (package->manifest-entry guile))
  435. (drv (profile-derivation (manifest (list entry))
  436. #:hooks '()
  437. #:locales? #f))
  438. (profile -> (derivation->output-path drv)))
  439. (mbegin %store-monad
  440. (built-derivations (list drv))
  441. (let* ((pipe (open-input-pipe
  442. (string-append "unset GUIX_PROFILE; "
  443. ;; 'source' is a Bashism; use '.' (dot).
  444. ". " profile "/etc/profile; "
  445. ;; Don't try to parse set(1) output because
  446. ;; it differs among shells; just use echo.
  447. "echo $PATH")))
  448. (path (get-string-all pipe)))
  449. (return
  450. (and (zero? (close-pipe pipe))
  451. (string-contains path (string-append profile "/bin"))))))))
  452. (test-assertm "etc/profile when etc/ already exists"
  453. ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
  454. ;; etc/ directory, which makes it read-only. Make sure the profile build
  455. ;; handles that.
  456. (mlet* %store-monad
  457. ((thing -> (dummy-package "dummy"
  458. (build-system trivial-build-system)
  459. (arguments
  460. `(#:guile ,%bootstrap-guile
  461. #:builder
  462. (let ((out (assoc-ref %outputs "out")))
  463. (mkdir out)
  464. (mkdir (string-append out "/etc"))
  465. (call-with-output-file (string-append out "/etc/foo")
  466. (lambda (port)
  467. (display "foo!" port)))
  468. #t)))))
  469. (entry -> (package->manifest-entry thing))
  470. (drv (profile-derivation (manifest (list entry))
  471. #:hooks '()
  472. #:locales? #f))
  473. (profile -> (derivation->output-path drv)))
  474. (mbegin %store-monad
  475. (built-derivations (list drv))
  476. (return (and (file-exists? (string-append profile "/etc/profile"))
  477. (string=? (call-with-input-file
  478. (string-append profile "/etc/foo")
  479. get-string-all)
  480. "foo!"))))))
  481. (test-assertm "etc/profile when etc/ is a symlink"
  482. ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
  483. ;; gracelessly because 'scandir' would return #f.
  484. (mlet* %store-monad
  485. ((thing -> (dummy-package "dummy"
  486. (build-system trivial-build-system)
  487. (arguments
  488. `(#:guile ,%bootstrap-guile
  489. #:builder
  490. (let ((out (assoc-ref %outputs "out")))
  491. (mkdir out)
  492. (mkdir (string-append out "/foo"))
  493. (symlink "foo" (string-append out "/etc"))
  494. (call-with-output-file (string-append out "/etc/bar")
  495. (lambda (port)
  496. (display "foo!" port)))
  497. #t)))))
  498. (entry -> (package->manifest-entry thing))
  499. (drv (profile-derivation (manifest (list entry))
  500. #:hooks '()
  501. #:locales? #f))
  502. (profile -> (derivation->output-path drv)))
  503. (mbegin %store-monad
  504. (built-derivations (list drv))
  505. (return (and (file-exists? (string-append profile "/etc/profile"))
  506. (string=? (call-with-input-file
  507. (string-append profile "/etc/bar")
  508. get-string-all)
  509. "foo!"))))))
  510. (test-assertm "profile-derivation when etc/ is a relative symlink"
  511. ;; See <https://bugs.gnu.org/32686>.
  512. (mlet* %store-monad
  513. ((etc (gexp->derivation
  514. "etc"
  515. #~(begin
  516. (mkdir #$output)
  517. (call-with-output-file (string-append #$output "/foo")
  518. (lambda (port)
  519. (display "Heya!" port))))))
  520. (thing -> (dummy-package "dummy"
  521. (build-system trivial-build-system)
  522. (inputs
  523. `(("etc" ,etc)))
  524. (arguments
  525. `(#:guile ,%bootstrap-guile
  526. #:builder
  527. (let ((out (assoc-ref %outputs "out"))
  528. (etc (assoc-ref %build-inputs "etc")))
  529. (mkdir out)
  530. (symlink etc (string-append out "/etc"))
  531. #t)))))
  532. (entry -> (package->manifest-entry thing))
  533. (drv (profile-derivation (manifest (list entry))
  534. #:relative-symlinks? #t
  535. #:hooks '()
  536. #:locales? #f))
  537. (profile -> (derivation->output-path drv)))
  538. (mbegin %store-monad
  539. (built-derivations (list drv))
  540. (return (string=? (call-with-input-file
  541. (string-append profile "/etc/foo")
  542. get-string-all)
  543. "Heya!")))))
  544. (test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949>
  545. "does-not-exist"
  546. (mlet* %store-monad
  547. ((thing1 -> (dummy-package "dummy"
  548. (build-system trivial-build-system)
  549. (arguments
  550. `(#:guile ,%bootstrap-guile
  551. #:builder
  552. (let ((out (assoc-ref %outputs "out")))
  553. (mkdir out)
  554. (symlink "does-not-exist"
  555. (string-append out "/dangling"))
  556. #t)))))
  557. (thing2 -> (package (inherit thing1) (name "dummy2")))
  558. (drv (profile-derivation (packages->manifest
  559. (list thing1 thing2))
  560. #:hooks '()
  561. #:locales? #f))
  562. (profile -> (derivation->output-path drv)))
  563. (mbegin %store-monad
  564. (built-derivations (list drv))
  565. (return (readlink (readlink (string-append profile "/dangling")))))))
  566. (test-equalm "profile in profile"
  567. '("foo" "0")
  568. ;; Make sure we can build a profile that has another profile has one of its
  569. ;; entries. The new profile's /manifest and /etc/profile must override the
  570. ;; other's.
  571. (mlet* %store-monad
  572. ((prof0 (profile-derivation
  573. (manifest
  574. (list (package->manifest-entry %bootstrap-guile)))
  575. #:hooks '()
  576. #:locales? #f))
  577. (prof1 (profile-derivation
  578. (manifest (list (manifest-entry
  579. (name "foo")
  580. (version "0")
  581. (item prof0))))
  582. #:hooks '()
  583. #:locales? #f)))
  584. (mbegin %store-monad
  585. (built-derivations (list prof1))
  586. (let ((out (derivation->output-path prof1)))
  587. (return (and (file-exists?
  588. (string-append out "/bin/guile"))
  589. (let ((manifest (profile-manifest out)))
  590. (match (manifest-entries manifest)
  591. ((entry)
  592. (list (manifest-entry-name entry)
  593. (manifest-entry-version entry)))))))))))
  594. (test-end "profiles")
  595. ;;; Local Variables:
  596. ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
  597. ;;; End: