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.
 
 
 
 
 
 

1970 lines
81 KiB

  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 © 2013 Nikita Karetnikov <nikita@karetnikov.org>
  4. ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
  5. ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
  6. ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
  7. ;;; Copyright © 2016, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
  8. ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
  9. ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
  10. ;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  11. ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com>
  12. ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
  13. ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
  14. ;;;
  15. ;;; This file is part of GNU Guix.
  16. ;;;
  17. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  18. ;;; under the terms of the GNU General Public License as published by
  19. ;;; the Free Software Foundation; either version 3 of the License, or (at
  20. ;;; your option) any later version.
  21. ;;;
  22. ;;; GNU Guix is distributed in the hope that it will be useful, but
  23. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  25. ;;; GNU General Public License for more details.
  26. ;;;
  27. ;;; You should have received a copy of the GNU General Public License
  28. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  29. (define-module (guix profiles)
  30. #:use-module ((guix config) #:select (%state-directory))
  31. #:use-module ((guix utils) #:hide (package-name->name+version))
  32. #:use-module ((guix build utils)
  33. #:select (package-name->name+version mkdir-p))
  34. #:use-module (guix i18n)
  35. #:use-module (guix records)
  36. #:use-module (guix packages)
  37. #:use-module (guix derivations)
  38. #:use-module (guix search-paths)
  39. #:use-module (guix gexp)
  40. #:use-module (guix modules)
  41. #:use-module (guix monads)
  42. #:use-module (guix store)
  43. #:use-module (guix sets)
  44. #:use-module (ice-9 vlist)
  45. #:use-module (ice-9 match)
  46. #:use-module (ice-9 regex)
  47. #:use-module (ice-9 ftw)
  48. #:use-module (ice-9 format)
  49. #:use-module (srfi srfi-1)
  50. #:use-module (srfi srfi-9)
  51. #:use-module (srfi srfi-11)
  52. #:use-module (srfi srfi-19)
  53. #:use-module (srfi srfi-26)
  54. #:use-module (srfi srfi-34)
  55. #:use-module (srfi srfi-35)
  56. #:export (&profile-error
  57. profile-error?
  58. profile-error-profile
  59. &profile-not-found-error
  60. profile-not-found-error?
  61. &profile-collision-error
  62. profile-collision-error?
  63. profile-collision-error-entry
  64. profile-collision-error-conflict
  65. &missing-generation-error
  66. missing-generation-error?
  67. missing-generation-error-generation
  68. &unmatched-pattern-error
  69. unmatched-pattern-error?
  70. unmatched-pattern-error-pattern
  71. unmatched-pattern-error-manifest
  72. manifest make-manifest
  73. manifest?
  74. manifest-entries
  75. manifest-transitive-entries
  76. <manifest-entry> ; FIXME: eventually make it internal
  77. manifest-entry
  78. manifest-entry?
  79. manifest-entry-name
  80. manifest-entry-version
  81. manifest-entry-output
  82. manifest-entry-item
  83. manifest-entry-dependencies
  84. manifest-entry-search-paths
  85. manifest-entry-parent
  86. manifest-entry-properties
  87. lower-manifest-entry
  88. manifest-entry=?
  89. manifest-pattern
  90. manifest-pattern?
  91. manifest-pattern-name
  92. manifest-pattern-version
  93. manifest-pattern-output
  94. concatenate-manifests
  95. map-manifest-entries
  96. manifest-remove
  97. manifest-add
  98. manifest-lookup
  99. manifest-installed?
  100. manifest-matching-entries
  101. manifest-search-paths
  102. manifest-transaction
  103. manifest-transaction?
  104. manifest-transaction-install
  105. manifest-transaction-remove
  106. manifest-transaction-install-entry
  107. manifest-transaction-remove-pattern
  108. manifest-transaction-null?
  109. manifest-transaction-removal-candidate?
  110. manifest-perform-transaction
  111. manifest-transaction-effects
  112. profile-manifest
  113. package->manifest-entry
  114. packages->manifest
  115. ca-certificate-bundle
  116. %default-profile-hooks
  117. profile-derivation
  118. profile-search-paths
  119. profile
  120. profile?
  121. profile-name
  122. profile-content
  123. profile-hooks
  124. profile-locales?
  125. profile-allow-collisions?
  126. profile-relative-symlinks?
  127. generation-number
  128. generation-profile
  129. generation-numbers
  130. profile-generations
  131. relative-generation-spec->number
  132. relative-generation
  133. previous-generation-number
  134. generation-time
  135. generation-file-name
  136. switch-to-generation
  137. roll-back
  138. delete-generation
  139. %user-profile-directory
  140. %profile-directory
  141. %current-profile
  142. ensure-profile-directory
  143. canonicalize-profile
  144. user-friendly-profile
  145. linux-module-database))
  146. ;;; Commentary:
  147. ;;;
  148. ;;; Tools to create and manipulate profiles---i.e., the representation of a
  149. ;;; set of installed packages.
  150. ;;;
  151. ;;; Code:
  152. ;;;
  153. ;;; Condition types.
  154. ;;;
  155. (define-condition-type &profile-error &error
  156. profile-error?
  157. (profile profile-error-profile))
  158. (define-condition-type &profile-not-found-error &profile-error
  159. profile-not-found-error?)
  160. (define-condition-type &profile-collision-error &error
  161. profile-collision-error?
  162. (entry profile-collision-error-entry) ;<manifest-entry>
  163. (conflict profile-collision-error-conflict)) ;<manifest-entry>
  164. (define-condition-type &unmatched-pattern-error &error
  165. unmatched-pattern-error?
  166. (pattern unmatched-pattern-error-pattern) ;<manifest-pattern>
  167. (manifest unmatched-pattern-error-manifest)) ;<manifest>
  168. (define-condition-type &missing-generation-error &profile-error
  169. missing-generation-error?
  170. (generation missing-generation-error-generation))
  171. ;;;
  172. ;;; Manifests.
  173. ;;;
  174. (define-record-type <manifest>
  175. (manifest entries)
  176. manifest?
  177. (entries manifest-entries)) ; list of <manifest-entry>
  178. ;; Convenient alias, to avoid name clashes.
  179. (define make-manifest manifest)
  180. (define-record-type* <manifest-entry> manifest-entry
  181. make-manifest-entry
  182. manifest-entry?
  183. (name manifest-entry-name) ; string
  184. (version manifest-entry-version) ; string
  185. (output manifest-entry-output ; string
  186. (default "out"))
  187. (item manifest-entry-item) ; package | file-like | store path
  188. (dependencies manifest-entry-dependencies ; <manifest-entry>*
  189. (default '()))
  190. (search-paths manifest-entry-search-paths ; search-path-specification*
  191. (default '()))
  192. (parent manifest-entry-parent ; promise (#f | <manifest-entry>)
  193. (default (delay #f)))
  194. (properties manifest-entry-properties ; list of symbol/value pairs
  195. (default '())))
  196. (define-record-type* <manifest-pattern> manifest-pattern
  197. make-manifest-pattern
  198. manifest-pattern?
  199. (name manifest-pattern-name) ; string
  200. (version manifest-pattern-version ; string | #f
  201. (default #f))
  202. (output manifest-pattern-output ; string | #f
  203. (default "out")))
  204. (define (list=? = lst1 lst2)
  205. "Return true if LST1 and LST2 have the same length and their elements are
  206. pairwise equal per =."
  207. (match lst1
  208. (()
  209. (null? lst2))
  210. ((head1 . tail1)
  211. (match lst2
  212. ((head2 . tail2)
  213. (and (= head1 head2) (list=? = tail1 tail2)))
  214. (()
  215. #f)))))
  216. (define (manifest-entry=? entry1 entry2)
  217. "Return true if ENTRY1 is equivalent to ENTRY2, ignoring their 'properties'
  218. field."
  219. (match entry1
  220. (($ <manifest-entry> name1 version1 output1 item1 dependencies1 paths1)
  221. (match entry2
  222. (($ <manifest-entry> name2 version2 output2 item2 dependencies2 paths2)
  223. (and (string=? name1 name2)
  224. (string=? version1 version2)
  225. (string=? output1 output2)
  226. (equal? item1 item2) ;XXX: could be <package> vs. store item
  227. (equal? paths1 paths2)
  228. (list=? manifest-entry=? dependencies1 dependencies2)))))))
  229. (define (manifest-transitive-entries manifest)
  230. "Return the entries of MANIFEST along with their propagated inputs,
  231. recursively."
  232. (let loop ((entries (manifest-entries manifest))
  233. (result '())
  234. (visited (set))) ;compare with 'equal?'
  235. (match entries
  236. (()
  237. (reverse result))
  238. ((head . tail)
  239. (if (set-contains? visited head)
  240. (loop tail result visited)
  241. (loop (append (manifest-entry-dependencies head)
  242. tail)
  243. (cons head result)
  244. (set-insert head visited)))))))
  245. (define (profile-manifest profile)
  246. "Return the PROFILE's manifest."
  247. (let ((file (string-append profile "/manifest")))
  248. (if (file-exists? file)
  249. (call-with-input-file file read-manifest)
  250. (manifest '()))))
  251. (define (manifest-entry-lookup manifest)
  252. "Return a lookup procedure for the entries of MANIFEST. The lookup
  253. procedure takes two arguments: the entry name and output."
  254. (define mapping
  255. (let loop ((entries (manifest-entries manifest))
  256. (mapping vlist-null))
  257. (fold (lambda (entry result)
  258. (vhash-cons (cons (manifest-entry-name entry)
  259. (manifest-entry-output entry))
  260. entry
  261. (loop (manifest-entry-dependencies entry)
  262. result)))
  263. mapping
  264. entries)))
  265. (lambda (name output)
  266. (match (vhash-assoc (cons name output) mapping)
  267. ((_ . entry) entry)
  268. (#f #f))))
  269. (define* (lower-manifest-entry entry system #:key target)
  270. "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store
  271. file name."
  272. (define (recurse entry)
  273. (mapm/accumulate-builds (lambda (entry)
  274. (lower-manifest-entry entry system
  275. #:target target))
  276. (manifest-entry-dependencies entry)))
  277. (let ((item (manifest-entry-item entry)))
  278. (if (string? item)
  279. (with-monad %store-monad
  280. (return entry))
  281. (mlet %store-monad ((drv (lower-object item system
  282. #:target target))
  283. (dependencies (recurse entry))
  284. (output -> (manifest-entry-output entry)))
  285. (return (manifest-entry
  286. (inherit entry)
  287. (item (derivation->output-path drv output))
  288. (dependencies dependencies)))))))
  289. (define* (check-for-collisions manifest system #:key target)
  290. "Check whether the entries of MANIFEST conflict with one another; raise a
  291. '&profile-collision-error' when a conflict is encountered."
  292. (define lookup
  293. (manifest-entry-lookup manifest))
  294. (define candidates
  295. (filter-map (lambda (entry)
  296. (let ((other (lookup (manifest-entry-name entry)
  297. (manifest-entry-output entry))))
  298. (and other (list entry other))))
  299. (manifest-transitive-entries manifest)))
  300. (define lower-pair
  301. (match-lambda
  302. ((first second)
  303. (mlet %store-monad ((first (lower-manifest-entry first system
  304. #:target target))
  305. (second (lower-manifest-entry second system
  306. #:target target)))
  307. (return (list first second))))))
  308. ;; Start by lowering CANDIDATES "in parallel".
  309. (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates)))
  310. (foldm %store-monad
  311. (lambda (entries result)
  312. (match entries
  313. ((first second)
  314. (if (string=? (manifest-entry-item first)
  315. (manifest-entry-item second))
  316. (return result)
  317. (raise (condition
  318. (&profile-collision-error
  319. (entry first)
  320. (conflict second))))))))
  321. #t
  322. lst)))
  323. (define* (package->manifest-entry package #:optional (output "out")
  324. #:key (parent (delay #f))
  325. (properties '()))
  326. "Return a manifest entry for the OUTPUT of package PACKAGE."
  327. ;; For each dependency, keep a promise pointing to its "parent" entry.
  328. (letrec* ((deps (map (match-lambda
  329. ((label package)
  330. (package->manifest-entry package
  331. #:parent (delay entry)))
  332. ((label package output)
  333. (package->manifest-entry package output
  334. #:parent (delay entry))))
  335. (package-propagated-inputs package)))
  336. (entry (manifest-entry
  337. (name (package-name package))
  338. (version (package-version package))
  339. (output output)
  340. (item package)
  341. (dependencies (delete-duplicates deps))
  342. (search-paths
  343. (package-transitive-native-search-paths package))
  344. (parent parent)
  345. (properties properties))))
  346. entry))
  347. (define (packages->manifest packages)
  348. "Return a list of manifest entries, one for each item listed in PACKAGES.
  349. Elements of PACKAGES can be either package objects or package/string tuples
  350. denoting a specific output of a package."
  351. (define inferiors-loaded?
  352. ;; This hack allows us to provide seamless integration for inferior
  353. ;; packages while not having a hard dependency on (guix inferior).
  354. (resolve-module '(guix inferior) #f #f #:ensure #f))
  355. (define (inferior->entry)
  356. (module-ref (resolve-interface '(guix inferior))
  357. 'inferior-package->manifest-entry))
  358. (manifest
  359. (map (match-lambda
  360. (((? package? package) output)
  361. (package->manifest-entry package output))
  362. ((? package? package)
  363. (package->manifest-entry package))
  364. ((thing output)
  365. (if inferiors-loaded?
  366. ((inferior->entry) thing output)
  367. (throw 'wrong-type-arg 'packages->manifest
  368. "Wrong package object: ~S" (list thing) (list thing))))
  369. (thing
  370. (if inferiors-loaded?
  371. ((inferior->entry) thing)
  372. (throw 'wrong-type-arg 'packages->manifest
  373. "Wrong package object: ~S" (list thing) (list thing)))))
  374. packages)))
  375. (define (manifest->gexp manifest)
  376. "Return a representation of MANIFEST as a gexp."
  377. (define (entry->gexp entry)
  378. (match entry
  379. (($ <manifest-entry> name version output (? string? path)
  380. (deps ...) (search-paths ...) _ (properties ...))
  381. #~(#$name #$version #$output #$path
  382. (propagated-inputs #$(map entry->gexp deps))
  383. (search-paths #$(map search-path-specification->sexp
  384. search-paths))
  385. (properties . #$properties)))
  386. (($ <manifest-entry> name version output package
  387. (deps ...) (search-paths ...) _ (properties ...))
  388. #~(#$name #$version #$output
  389. (ungexp package (or output "out"))
  390. (propagated-inputs #$(map entry->gexp deps))
  391. (search-paths #$(map search-path-specification->sexp
  392. search-paths))
  393. (properties . #$properties)))))
  394. (match manifest
  395. (($ <manifest> (entries ...))
  396. #~(manifest (version 3)
  397. (packages #$(map entry->gexp entries))))))
  398. (define (find-package name version)
  399. "Return a package from the distro matching NAME and possibly VERSION. This
  400. procedure is here for backward-compatibility and will eventually vanish."
  401. (define find-best-packages-by-name ;break abstractions
  402. (module-ref (resolve-interface '(gnu packages))
  403. 'find-best-packages-by-name))
  404. ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the
  405. ;; former traverses the module tree only once and then allows for efficient
  406. ;; access via a vhash.
  407. (match (find-best-packages-by-name name version)
  408. ((p _ ...) p)
  409. (_
  410. (match (find-best-packages-by-name name #f)
  411. ((p _ ...) p)
  412. (_ #f)))))
  413. (define (sexp->manifest sexp)
  414. "Parse SEXP as a manifest."
  415. (define (infer-search-paths name version)
  416. ;; Infer the search path specifications for NAME-VERSION by looking up a
  417. ;; same-named package in the distro. Useful for the old manifest formats
  418. ;; that did not store search path info.
  419. (let ((package (find-package name version)))
  420. (if package
  421. (package-native-search-paths package)
  422. '())))
  423. (define (infer-dependency item parent)
  424. ;; Return a <manifest-entry> for ITEM.
  425. (let-values (((name version)
  426. (package-name->name+version
  427. (store-path-package-name item))))
  428. (manifest-entry
  429. (name name)
  430. (version version)
  431. (item item)
  432. (parent parent))))
  433. (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
  434. (match sexp
  435. ((name version output path
  436. ('propagated-inputs deps)
  437. ('search-paths search-paths)
  438. extra-stuff ...)
  439. ;; For each of DEPS, keep a promise pointing to ENTRY.
  440. (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry))
  441. deps))
  442. (entry (manifest-entry
  443. (name name)
  444. (version version)
  445. (output output)
  446. (item path)
  447. (dependencies deps*)
  448. (search-paths (map sexp->search-path-specification
  449. search-paths))
  450. (parent parent)
  451. (properties (or (assoc-ref extra-stuff 'properties)
  452. '())))))
  453. entry))))
  454. (match sexp
  455. (('manifest ('version 0)
  456. ('packages ((name version output path) ...)))
  457. (manifest
  458. (map (lambda (name version output path)
  459. (manifest-entry
  460. (name name)
  461. (version version)
  462. (output output)
  463. (item path)
  464. (search-paths (infer-search-paths name version))))
  465. name version output path)))
  466. ;; Version 1 adds a list of propagated inputs to the
  467. ;; name/version/output/path tuples.
  468. (('manifest ('version 1)
  469. ('packages ((name version output path deps) ...)))
  470. (manifest
  471. (map (lambda (name version output path deps)
  472. ;; Up to Guix 0.7 included, dependencies were listed as ("gmp"
  473. ;; "/gnu/store/...-gmp") for instance. Discard the 'label' in
  474. ;; such lists.
  475. (let ((deps (match deps
  476. (((labels directories) ...)
  477. directories)
  478. ((directories ...)
  479. directories))))
  480. (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
  481. deps))
  482. (entry (manifest-entry
  483. (name name)
  484. (version version)
  485. (output output)
  486. (item path)
  487. (dependencies deps*)
  488. (search-paths
  489. (infer-search-paths name version)))))
  490. entry)))
  491. name version output path deps)))
  492. ;; Version 2 adds search paths and is slightly more verbose.
  493. (('manifest ('version 2 minor-version ...)
  494. ('packages ((name version output path
  495. ('propagated-inputs deps)
  496. ('search-paths search-paths)
  497. extra-stuff ...)
  498. ...)))
  499. (manifest
  500. (map (lambda (name version output path deps search-paths)
  501. (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
  502. deps))
  503. (entry (manifest-entry
  504. (name name)
  505. (version version)
  506. (output output)
  507. (item path)
  508. (dependencies deps*)
  509. (search-paths
  510. (map sexp->search-path-specification
  511. search-paths)))))
  512. entry))
  513. name version output path deps search-paths)))
  514. ;; Version 3 represents DEPS as full-blown manifest entries.
  515. (('manifest ('version 3 minor-version ...)
  516. ('packages (entries ...)))
  517. (manifest (map sexp->manifest-entry entries)))
  518. (_
  519. (raise (condition
  520. (&message (message "unsupported manifest format")))))))
  521. (define (read-manifest port)
  522. "Return the packages listed in MANIFEST."
  523. (sexp->manifest (read port)))
  524. (define (concatenate-manifests lst)
  525. "Concatenate the manifests listed in LST and return the resulting manifest."
  526. (manifest (append-map manifest-entries lst)))
  527. (define (map-manifest-entries proc manifest)
  528. "Apply PROC to all the entries of MANIFEST and return a new manifest."
  529. (make-manifest
  530. (map proc (manifest-entries manifest))))
  531. (define (entry-predicate pattern)
  532. "Return a procedure that returns #t when passed a manifest entry that
  533. matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they
  534. are ignored."
  535. (match pattern
  536. (($ <manifest-pattern> name version output)
  537. (match-lambda
  538. (($ <manifest-entry> entry-name entry-version entry-output)
  539. (and (string=? entry-name name)
  540. (or (not entry-output) (not output)
  541. (string=? entry-output output))
  542. (or (not version)
  543. (string=? entry-version version))))))))
  544. (define (manifest-remove manifest patterns)
  545. "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS
  546. must be a manifest-pattern."
  547. (define (remove-entry pattern lst)
  548. (remove (entry-predicate pattern) lst))
  549. (make-manifest (fold remove-entry
  550. (manifest-entries manifest)
  551. patterns)))
  552. (define (manifest-add manifest entries)
  553. "Add a list of manifest ENTRIES to MANIFEST and return new manifest.
  554. Remove MANIFEST entries that have the same name and output as ENTRIES."
  555. (define (same-entry? entry name output)
  556. (match entry
  557. (($ <manifest-entry> entry-name _ entry-output _)
  558. (and (equal? name entry-name)
  559. (equal? output entry-output)))))
  560. (make-manifest
  561. (fold (lambda (entry result) ;XXX: quadratic
  562. (match entry
  563. (($ <manifest-entry> name _ out _)
  564. (cons entry
  565. (remove (cut same-entry? <> name out)
  566. result)))))
  567. (manifest-entries manifest)
  568. entries)))
  569. (define (manifest-lookup manifest pattern)
  570. "Return the first item of MANIFEST that matches PATTERN, or #f if there is
  571. no match.."
  572. (find (entry-predicate pattern)
  573. (manifest-entries manifest)))
  574. (define (manifest-installed? manifest pattern)
  575. "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
  576. #f otherwise."
  577. (->bool (manifest-lookup manifest pattern)))
  578. (define (manifest-matching-entries manifest patterns)
  579. "Return all the entries of MANIFEST that match one of the PATTERNS. Raise
  580. an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one
  581. of PATTERNS."
  582. (fold-right (lambda (pattern matches)
  583. (match (filter (entry-predicate pattern)
  584. (manifest-entries manifest))
  585. (()
  586. (raise (condition
  587. (&unmatched-pattern-error
  588. (pattern pattern)
  589. (manifest manifest)))))
  590. (lst
  591. (append lst matches))))
  592. '()
  593. patterns))
  594. (define (manifest-search-paths manifest)
  595. "Return the list of search path specifications that apply to MANIFEST,
  596. including the search path specification for $PATH."
  597. (delete-duplicates
  598. (cons $PATH
  599. (append-map manifest-entry-search-paths
  600. (manifest-entries manifest)))))
  601. ;;;
  602. ;;; Manifest transactions.
  603. ;;;
  604. (define-record-type* <manifest-transaction> manifest-transaction
  605. make-manifest-transaction
  606. manifest-transaction?
  607. (install manifest-transaction-install ; list of <manifest-entry>
  608. (default '()))
  609. (remove manifest-transaction-remove ; list of <manifest-pattern>
  610. (default '())))
  611. (define (manifest-transaction-install-entry entry transaction)
  612. "Augment TRANSACTION's set of installed packages with ENTRY, a
  613. <manifest-entry>."
  614. (manifest-transaction
  615. (inherit transaction)
  616. (install
  617. (cons entry (manifest-transaction-install transaction)))))
  618. (define (manifest-transaction-remove-pattern pattern transaction)
  619. "Add PATTERN to TRANSACTION's list of packages to remove."
  620. (manifest-transaction
  621. (inherit transaction)
  622. (remove
  623. (cons pattern (manifest-transaction-remove transaction)))))
  624. (define (manifest-transaction-null? transaction)
  625. "Return true if TRANSACTION has no effect---i.e., it neither installs nor
  626. remove software."
  627. (match transaction
  628. (($ <manifest-transaction> () ()) #t)
  629. (($ <manifest-transaction> _ _) #f)))
  630. (define (manifest-transaction-removal-candidate? entry transaction)
  631. "Return true if ENTRY is a candidate for removal in TRANSACTION."
  632. (any (lambda (pattern)
  633. ((entry-predicate pattern) entry))
  634. (manifest-transaction-remove transaction)))
  635. (define (manifest-transaction-effects manifest transaction)
  636. "Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values:
  637. the list of packages that would be removed, installed, upgraded, or downgraded
  638. when applying TRANSACTION to MANIFEST. Upgrades are represented as pairs
  639. where the head is the entry being upgraded and the tail is the entry that will
  640. replace it."
  641. (define (manifest-entry->pattern entry)
  642. (manifest-pattern
  643. (name (manifest-entry-name entry))
  644. (output (manifest-entry-output entry))))
  645. (let loop ((input (manifest-transaction-install transaction))
  646. (install '())
  647. (upgrade '())
  648. (downgrade '()))
  649. (match input
  650. (()
  651. (let ((remove (manifest-transaction-remove transaction)))
  652. (values (manifest-matching-entries manifest remove)
  653. (reverse install) (reverse upgrade) (reverse downgrade))))
  654. ((entry rest ...)
  655. ;; Check whether installing ENTRY corresponds to the installation of a
  656. ;; new package or to an upgrade.
  657. ;; XXX: When the exact same output directory is installed, we're not
  658. ;; really upgrading anything. Add a check for that case.
  659. (let* ((pattern (manifest-entry->pattern entry))
  660. (previous (manifest-lookup manifest pattern))
  661. (newer? (and previous
  662. (version>=? (manifest-entry-version entry)
  663. (manifest-entry-version previous)))))
  664. (loop rest
  665. (if previous install (cons entry install))
  666. (if (and previous newer?)
  667. (alist-cons previous entry upgrade)
  668. upgrade)
  669. (if (and previous (not newer?))
  670. (alist-cons previous entry downgrade)
  671. downgrade)))))))
  672. (define (manifest-perform-transaction manifest transaction)
  673. "Perform TRANSACTION on MANIFEST and return the new manifest."
  674. (let ((install (manifest-transaction-install transaction))
  675. (remove (manifest-transaction-remove transaction)))
  676. (manifest-add (manifest-remove manifest remove)
  677. install)))
  678. ;;;
  679. ;;; Profiles.
  680. ;;;
  681. (define (manifest-inputs manifest)
  682. "Return a list of <gexp-input> objects for MANIFEST."
  683. (define entry->input
  684. (match-lambda
  685. (($ <manifest-entry> name version output thing deps)
  686. ;; THING may be a package or a file name. In the latter case, assume
  687. ;; it's already valid.
  688. (cons (gexp-input thing output)
  689. (append-map entry->input deps)))))
  690. (append-map entry->input (manifest-entries manifest)))
  691. (define* (manifest-lookup-package manifest name #:optional version)
  692. "Return as a monadic value the first package or store path referenced by
  693. MANIFEST that is named NAME and optionally has the given VERSION prefix, or #f
  694. if not found."
  695. ;; Return as a monadic value the package or store path referenced by the
  696. ;; manifest ENTRY, or #f if not referenced.
  697. (define (entry-lookup-package entry)
  698. (define (find-among-inputs inputs)
  699. (find (lambda (input)
  700. (and (package? input)
  701. (equal? name (package-name input))
  702. (if version
  703. (string-prefix? version (package-version input))
  704. #t)))
  705. inputs))
  706. (define (find-among-store-items items)
  707. (find (lambda (item)
  708. (let-values (((name* version*)
  709. (package-name->name+version
  710. (store-path-package-name item))))
  711. (and (string=? name name*)
  712. (if version
  713. (string-prefix? version version*)
  714. #t))))
  715. items))
  716. (with-monad %store-monad
  717. (match (manifest-entry-item entry)
  718. ((? package? package)
  719. (match (cons (list (package-name package) package)
  720. (package-transitive-inputs package))
  721. (((labels inputs . _) ...)
  722. (return (find-among-inputs inputs)))))
  723. ((? string? item)
  724. (mlet %store-monad ((refs (references* item)))
  725. (return (find-among-store-items refs))))
  726. (item
  727. ;; XXX: ITEM might be a 'computed-file' or anything like that, in
  728. ;; which case we don't know what to do. The fix may be to check
  729. ;; references once ITEM is compiled, as proposed at
  730. ;; <https://bugs.gnu.org/29927>.
  731. (return #f)))))
  732. (anym %store-monad
  733. entry-lookup-package (manifest-entries manifest)))
  734. (define (info-dir-file manifest)
  735. "Return a derivation that builds the 'dir' file for all the entries of
  736. MANIFEST."
  737. (define texinfo ;lazy reference
  738. (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
  739. (define gzip ;lazy reference
  740. (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
  741. (define glibc-utf8-locales ;lazy reference
  742. (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
  743. (define build
  744. (with-imported-modules '((guix build utils))
  745. #~(begin
  746. (use-modules (guix build utils)
  747. (srfi srfi-1) (srfi srfi-26)
  748. (ice-9 ftw))
  749. (define (info-file? file)
  750. (or (string-suffix? ".info" file)
  751. (string-suffix? ".info.gz" file)))
  752. (define (info-files top)
  753. (let ((infodir (string-append top "/share/info")))
  754. (map (cut string-append infodir "/" <>)
  755. (or (scandir infodir info-file?) '()))))
  756. (define (info-file-language file)
  757. (let* ((base (if (string-suffix? ".gz" file)
  758. (basename file ".info.gz")
  759. (basename file ".info")))
  760. (dot (string-rindex base #\.)))
  761. (if dot
  762. (string-drop base (+ 1 dot))
  763. "en")))
  764. (define (install-info info)
  765. (let ((language (info-file-language info)))
  766. ;; We need to choose a valid locale for $LANGUAGE to be honored.
  767. (setenv "LC_ALL" "en_US.utf8")
  768. (setenv "LANGUAGE" language)
  769. (zero?
  770. (system* #+(file-append texinfo "/bin/install-info")
  771. "--silent" info
  772. (apply string-append #$output "/share/info/dir"
  773. (if (string=? "en" language)
  774. '("")
  775. `("." ,language)))))))
  776. (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
  777. (setenv "GUIX_LOCPATH"
  778. #+(file-append glibc-utf8-locales "/lib/locale"))
  779. (mkdir-p (string-append #$output "/share/info"))
  780. (exit (every install-info
  781. (append-map info-files
  782. '#$(manifest-inputs manifest)))))))
  783. (gexp->derivation "info-dir" build
  784. #:local-build? #t
  785. #:substitutable? #f
  786. #:properties
  787. `((type . profile-hook)
  788. (hook . info-dir))))
  789. (define (ghc-package-cache-file manifest)
  790. "Return a derivation that builds the GHC 'package.cache' file for all the
  791. entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
  792. (define ghc ;lazy reference
  793. (module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
  794. (define build
  795. (with-imported-modules '((guix build utils))
  796. #~(begin
  797. (use-modules (guix build utils)
  798. (srfi srfi-1) (srfi srfi-26)
  799. (ice-9 ftw))
  800. (define ghc-name-version
  801. (let* ((base (basename #+ghc)))
  802. (string-drop base
  803. (+ 1 (string-index base #\-)))))
  804. (define db-subdir
  805. (string-append "lib/" ghc-name-version "/package.conf.d"))
  806. (define db-dir
  807. (string-append #$output "/" db-subdir))
  808. (define (conf-files top)
  809. (let ((db (string-append top "/" db-subdir)))
  810. (if (file-exists? db)
  811. (find-files db "\\.conf$")
  812. '())))
  813. (define (copy-conf-file conf)
  814. (let ((base (basename conf)))
  815. (copy-file conf (string-append db-dir "/" base))))
  816. (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
  817. (for-each copy-conf-file
  818. (append-map conf-files
  819. (delete-duplicates
  820. '#$(manifest-inputs manifest))))
  821. (let ((success
  822. (zero?
  823. (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
  824. (string-append "--package-db=" db-dir)))))
  825. (for-each delete-file (find-files db-dir "\\.conf$"))
  826. (exit success)))))
  827. (with-monad %store-monad
  828. ;; Don't depend on GHC when there's nothing to do.
  829. (if (any (cut string-prefix? "ghc" <>)
  830. (map manifest-entry-name (manifest-entries manifest)))
  831. (gexp->derivation "ghc-package-cache" build
  832. #:local-build? #t
  833. #:substitutable? #f
  834. #:properties
  835. `((type . profile-hook)
  836. (hook . ghc-package-cache)))
  837. (return #f))))
  838. (define (ca-certificate-bundle manifest)
  839. "Return a derivation that builds a single-file bundle containing the CA
  840. certificates in the /etc/ssl/certs sub-directories of the packages in
  841. MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
  842. ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html>
  843. ;; for a discussion.
  844. (define glibc-utf8-locales ;lazy reference
  845. (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
  846. (define build
  847. (with-imported-modules '((guix build utils))
  848. #~(begin
  849. (use-modules (guix build utils)
  850. (rnrs io ports)
  851. (srfi srfi-1)
  852. (srfi srfi-26)
  853. (ice-9 ftw)
  854. (ice-9 match))
  855. (define (pem-file? file)
  856. (string-suffix? ".pem" file))
  857. (define (ca-files top)
  858. (let ((cert-dir (string-append top "/etc/ssl/certs")))
  859. (map (cut string-append cert-dir "/" <>)
  860. (or (scandir cert-dir pem-file?) '()))))
  861. (define (concatenate-files files result)
  862. "Make RESULT the concatenation of all of FILES."
  863. (define (dump file port)
  864. (display (call-with-input-file file get-string-all)
  865. port)
  866. (newline port)) ;required, see <https://bugs.debian.org/635570>
  867. (call-with-output-file result
  868. (lambda (port)
  869. (for-each (cut dump <> port) files))))
  870. ;; Some file names in the NSS certificates are UTF-8 encoded so
  871. ;; install a UTF-8 locale.
  872. (setenv "LOCPATH"
  873. (string-append #+glibc-utf8-locales "/lib/locale/"
  874. #+(version-major+minor
  875. (package-version glibc-utf8-locales))))
  876. (setlocale LC_ALL "en_US.utf8")
  877. (match (append-map ca-files '#$(manifest-inputs manifest))
  878. (()
  879. ;; Since there are no CA files, just create an empty directory. Do
  880. ;; not create the etc/ssl/certs sub-directory, since that would
  881. ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be
  882. ;; defined.
  883. (mkdir #$output)
  884. #t)
  885. ((ca-files ...)
  886. (let ((result (string-append #$output "/etc/ssl/certs")))
  887. (mkdir-p result)
  888. (concatenate-files ca-files
  889. (string-append result
  890. "/ca-certificates.crt"))
  891. #t))))))
  892. (gexp->derivation "ca-certificate-bundle" build
  893. #:local-build? #t
  894. #:substitutable? #f
  895. #:properties
  896. `((type . profile-hook)
  897. (hook . ca-certificate-bundle))))
  898. (define (glib-schemas manifest)
  899. "Return a derivation that unions all schemas from manifest entries and
  900. creates the Glib 'gschemas.compiled' file."
  901. (define glib ; lazy reference
  902. (module-ref (resolve-interface '(gnu packages glib)) 'glib))
  903. (mlet %store-monad ((%glib (manifest-lookup-package manifest "glib"))
  904. ;; XXX: Can't use glib-compile-schemas corresponding
  905. ;; to the glib referenced by 'manifest'. Because
  906. ;; '%glib' can be either a package or store path, and
  907. ;; there's no way to get the "bin" output for the later.
  908. (glib-compile-schemas
  909. -> #~(string-append #+glib:bin
  910. "/bin/glib-compile-schemas")))
  911. (define build
  912. (with-imported-modules '((guix build utils)
  913. (guix build union)
  914. (guix build profiles)
  915. (guix search-paths)
  916. (guix records))
  917. #~(begin
  918. (use-modules (guix build utils)
  919. (guix build union)
  920. (guix build profiles)
  921. (srfi srfi-26))
  922. (let* ((destdir (string-append #$output "/share/glib-2.0/schemas"))
  923. (schemadirs (filter file-exists?
  924. (map (cut string-append <> "/share/glib-2.0/schemas")
  925. '#$(manifest-inputs manifest)))))
  926. ;; Union all the schemas.
  927. (mkdir-p (string-append #$output "/share/glib-2.0"))
  928. (union-build destdir schemadirs
  929. #:log-port (%make-void-port "w"))
  930. (let ((dir destdir))
  931. (when (file-is-directory? dir)
  932. (ensure-writable-directory dir)
  933. (invoke #+glib-compile-schemas
  934. (string-append "--targetdir=" dir)
  935. dir)))))))
  936. ;; Don't run the hook when there's nothing to do.
  937. (if %glib
  938. (gexp->derivation "glib-schemas" build
  939. #:local-build? #t
  940. #:substitutable? #f
  941. #:properties
  942. `((type . profile-hook)
  943. (hook . glib-schemas)))
  944. (return #f))))
  945. (define (gtk-icon-themes manifest)
  946. "Return a derivation that unions all icon themes from manifest entries and
  947. creates the GTK+ 'icon-theme.cache' file for each theme."
  948. (define gtk+ ; lazy reference
  949. (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+))
  950. (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+"))
  951. ;; XXX: Can't use gtk-update-icon-cache corresponding
  952. ;; to the gtk+ referenced by 'manifest'. Because
  953. ;; '%gtk+' can be either a package or store path, and
  954. ;; there's no way to get the "bin" output for the later.
  955. (gtk-update-icon-cache
  956. -> #~(string-append #+gtk+:bin
  957. "/bin/gtk-update-icon-cache")))
  958. (define build
  959. (with-imported-modules '((guix build utils)
  960. (guix build union)
  961. (guix build profiles)
  962. (guix search-paths)
  963. (guix records))
  964. #~(begin
  965. (use-modules (guix build utils)
  966. (guix build union)
  967. (guix build profiles)
  968. (srfi srfi-26)
  969. (ice-9 ftw))
  970. (let* ((destdir (string-append #$output "/share/icons"))
  971. (icondirs (filter file-exists?
  972. (map (cut string-append <> "/share/icons")
  973. '#$(manifest-inputs manifest)))))
  974. ;; Union all the icons.
  975. (mkdir-p (string-append #$output "/share"))
  976. (union-build destdir icondirs
  977. #:log-port (%make-void-port "w"))
  978. ;; Update the 'icon-theme.cache' file for each icon theme.
  979. (for-each
  980. (lambda (theme)
  981. (let ((dir (string-append destdir "/" theme)))
  982. ;; Occasionally DESTDIR contains plain files, such as
  983. ;; "abiword_48.png". Ignore these.
  984. (when (file-is-directory? dir)
  985. (ensure-writable-directory dir)
  986. (system* #+gtk-update-icon-cache "-t" dir "--quiet"))))
  987. (scandir destdir (negate (cut member <> '("." "..")))))))))
  988. ;; Don't run the hook when there's nothing to do.
  989. (if %gtk+
  990. (gexp->derivation "gtk-icon-themes" build
  991. #:local-build? #t
  992. #:substitutable? #f
  993. #:properties
  994. `((type . profile-hook)
  995. (hook . gtk-icon-themes)))
  996. (return #f))))
  997. (define (gtk-im-modules manifest)
  998. "Return a derivation that builds the cache files for input method modules
  999. for both major versions of GTK+."
  1000. (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3"))
  1001. (gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
  1002. (define (build gtk gtk-version query)
  1003. (let ((major (string-take gtk-version 1)))
  1004. (with-imported-modules '((guix build utils)
  1005. (guix build union)
  1006. (guix build profiles)
  1007. (guix search-paths)
  1008. (guix records))
  1009. #~(begin
  1010. (use-modules (guix build utils)
  1011. (guix build union)
  1012. (guix build profiles)
  1013. (ice-9 popen)
  1014. (srfi srfi-1)
  1015. (srfi srfi-26))
  1016. (let* ((prefix (string-append "/lib/gtk-" #$major ".0/"
  1017. #$gtk-version))
  1018. (destdir (string-append #$output prefix))
  1019. (moddirs (cons (string-append #$gtk prefix "/immodules")
  1020. (filter file-exists?
  1021. (map (cut string-append <> prefix "/immodules")
  1022. '#$(manifest-inputs manifest)))))
  1023. (modules (append-map (cut find-files <> "\\.so$")
  1024. moddirs)))
  1025. ;; Generate a new immodules cache file.
  1026. (mkdir-p (string-append #$output prefix))
  1027. (let ((pipe (apply open-pipe* OPEN_READ #$query modules))
  1028. (outfile (string-append #$output prefix
  1029. "/immodules-gtk" #$major ".cache")))
  1030. (dynamic-wind
  1031. (const #t)
  1032. (lambda ()
  1033. (call-with-output-file outfile
  1034. (lambda (out)
  1035. (while (not (eof-object? (peek-char pipe)))
  1036. (write-char (read-char pipe) out))))
  1037. #t)
  1038. (lambda ()
  1039. (close-pipe pipe)))))))))
  1040. ;; Don't run the hook when there's nothing to do.
  1041. (let* ((pkg-gtk+ (module-ref ; lazy reference
  1042. (resolve-interface '(gnu packages gtk)) 'gtk+))
  1043. (gexp #~(begin
  1044. #$(if gtk+
  1045. (build
  1046. gtk+ "3.0.0"
  1047. ;; Use 'gtk-query-immodules-3.0' from the 'bin'
  1048. ;; output of latest gtk+ package.
  1049. #~(string-append
  1050. #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0"))
  1051. #t)
  1052. #$(if gtk+-2
  1053. (build
  1054. gtk+-2 "2.10.0"
  1055. #~(string-append
  1056. #$gtk+-2 "/bin/gtk-query-immodules-2.0"))
  1057. #t))))
  1058. (if (or gtk+ gtk+-2)
  1059. (gexp->derivation "gtk-im-modules" gexp
  1060. #:local-build? #t
  1061. #:substitutable? #f
  1062. #:properties
  1063. `((type . profile-hook)
  1064. (hook . gtk-im-modules)))
  1065. (return #f)))))
  1066. (define (linux-module-database manifest)
  1067. "Return a derivation that unites all the kernel modules of the manifest
  1068. and creates the dependency graph of all these kernel modules.
  1069. This is meant to be used as a profile hook."
  1070. (define kmod ; lazy reference
  1071. (module-ref (resolve-interface '(gnu packages linux)) 'kmod))
  1072. (define build
  1073. (with-imported-modules
  1074. (source-module-closure '((guix build utils)
  1075. (gnu build linux-modules)))
  1076. #~(begin
  1077. (use-modules (ice-9 ftw)
  1078. (ice-9 match)
  1079. (srfi srfi-1) ; append-map
  1080. (gnu build linux-modules))
  1081. (let* ((inputs '#$(manifest-inputs manifest))
  1082. (module-directories
  1083. (map (lambda (directory)
  1084. (string-append directory "/lib/modules"))
  1085. inputs))
  1086. (directory-entries
  1087. (lambda (directory)
  1088. (scandir directory (lambda (basename)
  1089. (not
  1090. (string-prefix? "." basename))))))
  1091. ;; Note: Should usually result in one entry.
  1092. (versions (delete-duplicates
  1093. (append-map directory-entries
  1094. module-directories))))
  1095. (match versions
  1096. ((version)
  1097. (let ((old-path (getenv "PATH")))
  1098. (setenv "PATH" #+(file-append kmod "/bin"))
  1099. (make-linux-module-directory inputs version #$output)
  1100. (setenv "PATH" old-path)))
  1101. (_ (error "Specified Linux kernel and Linux kernel modules
  1102. are not all of the same version")))))))
  1103. (gexp->derivation "linux-module-database" build
  1104. #:local-build? #t
  1105. #:substitutable? #f
  1106. #:properties
  1107. `((type . profile-hook)
  1108. (hook . linux-module-database))))
  1109. (define (xdg-desktop-database manifest)
  1110. "Return a derivation that builds the @file{mimeinfo.cache} database from
  1111. desktop files. It's used to query what applications can handle a given
  1112. MIME type."
  1113. (define desktop-file-utils ; lazy reference
  1114. (module-ref (resolve-interface '(gnu packages freedesktop))
  1115. 'desktop-file-utils))
  1116. (mlet %store-monad ((glib
  1117. (manifest-lookup-package
  1118. manifest "glib")))
  1119. (define build
  1120. (with-imported-modules '((guix build utils)
  1121. (guix build union))
  1122. #~(begin
  1123. (use-modules (srfi srfi-26)
  1124. (guix build utils)
  1125. (guix build union))
  1126. (let* ((destdir (string-append #$output "/share/applications"))
  1127. (appdirs (filter file-exists?
  1128. (map (cut string-append <>
  1129. "/share/applications")
  1130. '#$(manifest-inputs manifest))))
  1131. (update-desktop-database (string-append
  1132. #+desktop-file-utils
  1133. "/bin/update-desktop-database")))
  1134. (mkdir-p (string-append #$output "/share"))
  1135. (union-build destdir appdirs
  1136. #:log-port (%make-void-port "w"))
  1137. (exit (zero? (system* update-desktop-database destdir)))))))
  1138. ;; Don't run the hook when 'glib' is not referenced.
  1139. (if glib
  1140. (gexp->derivation "xdg-desktop-database" build
  1141. #:local-build? #t
  1142. #:substitutable? #f
  1143. #:properties
  1144. `((type . profile-hook)
  1145. (hook . xdg-desktop-database)))
  1146. (return #f))))
  1147. (define (xdg-mime-database manifest)
  1148. "Return a derivation that builds the @file{mime.cache} database from manifest
  1149. entries. It's used to query the MIME type of a given file."
  1150. (define shared-mime-info ; lazy reference
  1151. (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
  1152. (mlet %store-monad ((glib
  1153. (manifest-lookup-package
  1154. manifest "glib")))
  1155. (define build
  1156. (with-imported-modules '((guix build utils)
  1157. (guix build union))
  1158. #~(begin
  1159. (use-modules (srfi srfi-26)
  1160. (guix build utils)
  1161. (guix build union))
  1162. (let* ((datadir (string-append #$output "/share"))
  1163. (destdir (string-append datadir "/mime"))
  1164. (pkgdirs (filter file-exists?
  1165. (map (cut string-append <>
  1166. "/share/mime/packages")
  1167. (cons #+shared-mime-info
  1168. '#$(manifest-inputs manifest)))))
  1169. (update-mime-database (string-append
  1170. #+shared-mime-info
  1171. "/bin/update-mime-database")))
  1172. (mkdir-p destdir)
  1173. (union-build (string-append destdir "/packages") pkgdirs
  1174. #:log-port (%make-void-port "w"))
  1175. (setenv "XDG_DATA_HOME" datadir)
  1176. (exit (zero? (system* update-mime-database destdir)))))))
  1177. ;; Don't run the hook when there are no GLib based applications.
  1178. (if glib
  1179. (gexp->derivation "xdg-mime-database" build
  1180. #:local-build? #t
  1181. #:substitutable? #f
  1182. #:properties
  1183. `((type . profile-hook)
  1184. (hook . xdg-mime-database)))
  1185. (return #f))))
  1186. ;; Several font packages may install font files into same directory, so
  1187. ;; fonts.dir and fonts.scale file should be generated here, instead of in
  1188. ;; packages.
  1189. (define (fonts-dir-file manifest)
  1190. "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
  1191. files for the fonts of the @var{manifest} entries."
  1192. (define mkfontscale
  1193. (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
  1194. (define mkfontdir
  1195. (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir))
  1196. (define build
  1197. #~(begin
  1198. (use-modules (srfi srfi-26)
  1199. (guix build utils)
  1200. (guix build union))
  1201. (let ((fonts-dirs (filter file-exists?
  1202. (map (cut string-append <>
  1203. "/share/fonts")
  1204. '#$(manifest-inputs manifest)))))
  1205. (mkdir #$output)
  1206. (if (null? fonts-dirs)
  1207. (exit #t)
  1208. (let* ((share-dir (string-append #$output "/share"))
  1209. (fonts-dir (string-append share-dir "/fonts"))
  1210. (mkfontscale (string-append #+mkfontscale
  1211. "/bin/mkfontscale"))
  1212. (mkfontdir (string-append #+mkfontdir
  1213. "/bin/mkfontdir"))
  1214. (empty-file? (lambda (filename)
  1215. (call-with-ascii-input-file filename
  1216. (lambda (p)
  1217. (eqv? #\0 (read-char p))))))
  1218. (fonts-dir-file "fonts.dir")
  1219. (fonts-scale-file "fonts.scale"))
  1220. (mkdir-p share-dir)
  1221. ;; Create all sub-directories, because we may create fonts.dir
  1222. ;; and fonts.scale files in the sub-directories.
  1223. (union-build fonts-dir fonts-dirs
  1224. #:log-port (%make-void-port "w")
  1225. #:create-all-directories? #t)
  1226. (let ((directories (find-files fonts-dir
  1227. (lambda (file stat)
  1228. (eq? 'directory (stat:type stat)))
  1229. #:directories? #t)))
  1230. (for-each (lambda (dir)
  1231. (with-directory-excursion dir
  1232. (when (file-exists? fonts-scale-file)
  1233. (delete-file fonts-scale-file))
  1234. (when (file-exists? fonts-dir-file)
  1235. (delete-file fonts-dir-file))
  1236. (unless (and (zero? (system* mkfontscale))
  1237. (zero? (system* mkfontdir)))
  1238. (exit #f))
  1239. (when (and (file-exists? fonts-scale-file)
  1240. (empty-file? fonts-scale-file))
  1241. (delete-file fonts-scale-file))
  1242. (when (and (file-exists? fonts-dir-file)
  1243. (empty-file? fonts-dir-file))
  1244. (delete-file fonts-dir-file))))
  1245. directories)))))))
  1246. (gexp->derivation "fonts-dir" build
  1247. #:modules '((guix build utils)
  1248. (guix build union)
  1249. (srfi srfi-26))
  1250. #:local-build? #t
  1251. #:substitutable? #f
  1252. #:properties
  1253. `((type . profile-hook)
  1254. (hook . fonts-dir))))
  1255. (define (manual-database manifest)
  1256. "Return a derivation that builds the manual page database (\"mandb\") for
  1257. the entries in MANIFEST."
  1258. (define gdbm-ffi
  1259. (module-ref (resolve-interface '(gnu packages guile))
  1260. 'guile-gdbm-ffi))
  1261. (define zlib
  1262. (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
  1263. (define config.scm
  1264. (scheme-file "config.scm"
  1265. #~(begin
  1266. (define-module #$'(guix config) ;placate Geiser
  1267. #:export (%libz))
  1268. (define %libz
  1269. #+(file-append zlib "/lib/libz")))))
  1270. (define modules
  1271. (cons `((guix config) => ,config.scm)
  1272. (delete '(guix config)
  1273. (source-module-closure `((guix build utils)
  1274. (guix man-db))))))
  1275. (define build
  1276. (with-imported-modules modules
  1277. (with-extensions (list gdbm-ffi) ;for (guix man-db)
  1278. #~(begin
  1279. (use-modules (guix man-db)
  1280. (guix build utils)
  1281. (ice-9 threads)
  1282. (srfi srfi-1)
  1283. (srfi srfi-19))
  1284. (define (print-string msg)
  1285. (display msg)
  1286. (force-output))
  1287. (define-syntax-rule (print fmt args ...)
  1288. ;; Build up the string and display it at once.
  1289. (print-string (format #f fmt args ...)))
  1290. (define (compute-entry directory count total)
  1291. (print "\r[~3d/~3d] building list of man-db entries..."
  1292. count total)
  1293. (let ((man (string-append directory "/share/man")))
  1294. (if (directory-exists? man)
  1295. (mandb-entries man)
  1296. '())))
  1297. (define (compute-entries)
  1298. ;; This is the most expensive part (I/O and CPU, due to
  1299. ;; decompression), so report progress as we traverse INPUTS.
  1300. ;; Cap at 4 threads because we don't see any speedup beyond that
  1301. ;; on an SSD laptop.
  1302. (let* ((inputs '#$(manifest-inputs manifest))
  1303. (total (length inputs))
  1304. (threads (min (parallel-job-count) 4)))
  1305. (concatenate
  1306. (n-par-map threads compute-entry inputs
  1307. (iota total 1)
  1308. (make-list total total)))))
  1309. (define man-directory
  1310. (string-append #$output "/share/man"))
  1311. (mkdir-p man-directory)
  1312. (format #t "Creating manual page database...~%")
  1313. (force-output)
  1314. (let* ((start (current-time))
  1315. (entries (compute-entries))
  1316. (_ (write-mandb-database (string-append man-directory
  1317. "/index.db")
  1318. entries))
  1319. (duration (time-difference (current-time) start)))
  1320. (newline)
  1321. (format #t "~a entries processed in ~,1f s~%"
  1322. (length entries)
  1323. (+ (time-second duration)
  1324. (* (time-nanosecond duration) (expt 10 -9))))
  1325. (force-output))))))
  1326. (gexp->derivation "manual-database" build
  1327. ;; Work around GDBM 1.13 issue whereby uninitialized bytes
  1328. ;; get written to disk:
  1329. ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
  1330. #:env-vars `(("MALLOC_PERTURB_" . "1"))
  1331. #:local-build? #t
  1332. #:properties
  1333. `((type . profile-hook)
  1334. (hook . manual-database))))
  1335. (define (texlive-configuration manifest)
  1336. "Return a derivation that builds a TeXlive configuration for the entries in
  1337. MANIFEST."
  1338. (define entry->texlive-input
  1339. (match-lambda
  1340. (($ <manifest-entry> name version output thing deps)
  1341. (if (string-prefix? "texlive-" name)
  1342. (cons (gexp-input thing output)
  1343. (append-map entry->texlive-input deps))
  1344. '()))))
  1345. (define build
  1346. (with-imported-modules '((guix build utils)
  1347. (guix build union))
  1348. #~(begin
  1349. (use-modules (guix build utils)
  1350. (guix build union))
  1351. ;; Build a modifiable union of all texlive inputs. We do this so
  1352. ;; that TeX live can resolve the parent and grandparent directories
  1353. ;; correctly. There might be a more elegant way to accomplish this.
  1354. (union-build #$output
  1355. '#$(append-map entry->texlive-input
  1356. (manifest-entries manifest))
  1357. #:create-all-directories? #t
  1358. #:log-port (%make-void-port "w"))
  1359. (let ((texmf.cnf (string-append
  1360. #$output
  1361. "/share/texmf-dist/web2c/texmf.cnf")))
  1362. (when (file-exists? texmf.cnf)
  1363. (substitute* texmf.cnf
  1364. (("^TEXMFROOT = .*")
  1365. (string-append "TEXMFROOT = " #$output "/share\n"))
  1366. (("^TEXMF = .*")
  1367. "TEXMF = $TEXMFROOT/share/texmf-dist\n"))))
  1368. #t)))
  1369. (with-monad %store-monad
  1370. (if (any (cut string-prefix? "texlive-" <>)
  1371. (map manifest-entry-name (manifest-entries manifest)))
  1372. (gexp->derivation "texlive-configuration" build
  1373. #:substitutable? #f
  1374. #:local-build? #t
  1375. #:properties
  1376. `((type . profile-hook)
  1377. (hook . texlive-configuration)))
  1378. (return #f))))
  1379. (define %default-profile-hooks
  1380. ;; This is the list of derivation-returning procedures that are called by
  1381. ;; default when making a non-empty profile.
  1382. (list info-dir-file
  1383. manual-database
  1384. fonts-dir-file
  1385. ghc-package-cache-file
  1386. ca-certificate-bundle
  1387. glib-schemas
  1388. gtk-icon-themes
  1389. gtk-im-modules
  1390. texlive-configuration
  1391. xdg-desktop-database
  1392. xdg-mime-database))
  1393. (define* (profile-derivation manifest
  1394. #:key
  1395. (name "profile")
  1396. (hooks %default-profile-hooks)
  1397. (locales? #t)
  1398. (allow-collisions? #f)
  1399. (relative-symlinks? #f)
  1400. system target)
  1401. "Return a derivation that builds a profile (aka. 'user environment') with
  1402. the given MANIFEST. The profile includes additional derivations returned by
  1403. the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
  1404. Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if
  1405. entries in MANIFEST collide (for instance if there are two same-name packages
  1406. with a different version number.)
  1407. When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
  1408. a dependency on the 'glibc-utf8-locales' package.
  1409. When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets.
  1410. This is one of the things to do for the result to be relocatable.
  1411. When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
  1412. are cross-built for TARGET."
  1413. (mlet* %store-monad ((system (if system
  1414. (return system)
  1415. (current-system)))
  1416. (target (if target
  1417. (return target)
  1418. (current-target-system)))
  1419. (ok? (if allow-collisions?
  1420. (return #t)
  1421. (check-for-collisions manifest system
  1422. #:target target)))
  1423. (extras (if (null? (manifest-entries manifest))
  1424. (return '())
  1425. (mapm/accumulate-builds (lambda (hook)
  1426. (hook manifest))
  1427. hooks))))
  1428. (define inputs
  1429. (append (filter-map (lambda (drv)
  1430. (and (derivation? drv)
  1431. (gexp-input drv)))
  1432. extras)
  1433. (manifest-inputs manifest)))
  1434. (define glibc-utf8-locales ;lazy reference
  1435. (module-ref (resolve-interface '(gnu packages base))
  1436. 'glibc-utf8-locales))
  1437. (define set-utf8-locale
  1438. ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so
  1439. ;; install a UTF-8 locale.
  1440. #~(begin
  1441. (setenv "LOCPATH"
  1442. #$(file-append glibc-utf8-locales "/lib/locale/"
  1443. (version-major+minor
  1444. (package-version glibc-utf8-locales))))
  1445. (setlocale LC_ALL "en_US.utf8")))
  1446. (define builder
  1447. (with-imported-modules '((guix build profiles)
  1448. (guix build union)
  1449. (guix build utils)
  1450. (guix search-paths)
  1451. (guix records))
  1452. #~(begin
  1453. (use-modules (guix build profiles)
  1454. (guix search-paths)
  1455. (srfi srfi-1))
  1456. (setvbuf (current-output-port) _IOLBF)
  1457. (setvbuf (current-error-port) _IOLBF)
  1458. #+(if locales? set-utf8-locale #t)
  1459. (define search-paths
  1460. ;; Search paths of MANIFEST's packages, converted back to their
  1461. ;; record form.
  1462. (map sexp->search-path-specification
  1463. (delete-duplicates
  1464. '#$(map search-path-specification->sexp
  1465. (manifest-search-paths manifest)))))
  1466. (build-profile #$output '#$inputs
  1467. #:symlink #$(if relative-symlinks?
  1468. #~symlink-relative
  1469. #~symlink)
  1470. #:manifest '#$(manifest->gexp manifest)
  1471. #:search-paths search-paths))))
  1472. (gexp->derivation name builder
  1473. #:system system
  1474. #:target target
  1475. ;; Don't complain about _IO* on Guile 2.2.
  1476. #:env-vars '(("GUILE_WARN_DEPRECATED" . "no"))
  1477. ;; Not worth offloading.
  1478. #:local-build? #t
  1479. ;; Disable substitution because it would trigger a
  1480. ;; connection to the substitute server, which is likely
  1481. ;; to have no substitute to offer.
  1482. #:substitutable? #f
  1483. #:properties `((type . profile)
  1484. (profile
  1485. (count
  1486. . ,(length
  1487. (manifest-entries manifest))))))))
  1488. ;; Declarative profile.
  1489. (define-record-type* <profile> profile make-profile
  1490. profile?
  1491. (name profile-name (default "profile")) ;string
  1492. (content profile-content) ;<manifest>
  1493. (hooks profile-hooks ;list of procedures
  1494. (default %default-profile-hooks))
  1495. (locales? profile-locales? ;Boolean
  1496. (default #t))
  1497. (allow-collisions? profile-allow-collisions? ;Boolean
  1498. (default #f))
  1499. (relative-symlinks? profile-relative-symlinks? ;Boolean
  1500. (default #f)))
  1501. (define-gexp-compiler (profile-compiler (profile <profile>) system target)
  1502. "Compile PROFILE to a derivation."
  1503. (match profile
  1504. (($ <profile> name manifest hooks
  1505. locales? allow-collisions? relative-symlinks?)
  1506. (profile-derivation manifest
  1507. #:name name
  1508. #:hooks hooks
  1509. #:locales? locales?
  1510. #:allow-collisions? allow-collisions?
  1511. #:relative-symlinks? relative-symlinks?
  1512. #:system system #:target target))))
  1513. (define* (profile-search-paths profile
  1514. #:optional (manifest (profile-manifest profile))
  1515. #:key (getenv (const #f)))
  1516. "Read the manifest of PROFILE and evaluate the values of search path
  1517. environment variables required by PROFILE; return a list of
  1518. specification/value pairs. If MANIFEST is not #f, it is assumed to be the
  1519. manifest of PROFILE, which avoids rereading it.
  1520. Use GETENV to determine the current settings and report only settings not
  1521. already effective."
  1522. (evaluate-search-paths (manifest-search-paths manifest)
  1523. (list profile) getenv))
  1524. (define (profile-regexp profile)
  1525. "Return a regular expression that matches PROFILE's name and number."
  1526. (make-regexp (string-append "^" (regexp-quote (basename profile))
  1527. "-([0-9]+)")))
  1528. (define (generation-number profile)
  1529. "Return PROFILE's number or 0. An absolute file name must be used."
  1530. (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
  1531. (basename (readlink profile))))
  1532. (compose string->number (cut match:substring <> 1)))
  1533. 0))
  1534. (define %profile-generation-rx
  1535. ;; Regexp that matches profile generation.
  1536. (make-regexp "(.*)-([0-9]+)-link$"))
  1537. (define (generation-profile file)
  1538. "If FILE is a profile generation GC root such as \"guix-profile-42-link\",
  1539. return its corresponding profile---e.g., \"guix-profile\". Otherwise return
  1540. #f."
  1541. (match (regexp-exec %profile-generation-rx file)
  1542. (#f #f)
  1543. (m (let ((profile (match:substring m 1)))
  1544. (and (file-exists? (string-append profile "/manifest"))
  1545. profile)))))
  1546. (define (generation-numbers profile)
  1547. "Return the sorted list of generation numbers of PROFILE, or '(0) if no
  1548. former profiles were found."
  1549. (match (scandir (dirname profile)
  1550. (cute regexp-exec (profile-regexp profile) <>))
  1551. (#f ; no profile directory
  1552. '(0))
  1553. (() ; no profiles
  1554. '(0))
  1555. ((profiles ...) ; former profiles around
  1556. (sort (map (compose string->number
  1557. (cut match:substring <> 1)
  1558. (cute regexp-exec (profile-regexp profile) <>))
  1559. profiles)
  1560. <))))
  1561. (define (profile-generations profile)
  1562. "Return a list of PROFILE's generations."
  1563. (let ((generations (generation-numbers profile)))
  1564. (if (equal? generations '(0))
  1565. '()
  1566. generations)))
  1567. (define (relative-generation-spec->number profile spec)
  1568. "Return PROFILE's generation specified by SPEC, which is a string. The SPEC
  1569. may be a N, -N, or +N, where N is a number. If the spec is N, then the number
  1570. returned is N. If it is -N, then the number returned is the profile's current
  1571. generation number minus N. If it is +N, then the number returned is the
  1572. profile's current generation number plus N. Return #f if there is no such
  1573. generation."
  1574. (let ((number (string->number spec)))
  1575. (and number
  1576. (case (string-ref spec 0)
  1577. ((#\+ #\-)
  1578. (relative-generation profile number))
  1579. (else (if (memv number (profile-generations profile))
  1580. number
  1581. #f))))))
  1582. (define* (relative-generation profile shift #:optional
  1583. (current (generation-number profile)))
  1584. "Return PROFILE's generation shifted from the CURRENT generation by SHIFT.
  1585. SHIFT is a positive or negative number.
  1586. Return #f if there is no such generation."
  1587. (let* ((abs-shift (abs shift))
  1588. (numbers (profile-generations profile))
  1589. (from-current (memq current
  1590. (if (negative? shift)
  1591. (reverse numbers)
  1592. numbers))))
  1593. (and from-current
  1594. (< abs-shift (length from-current))
  1595. (list-ref from-current abs-shift))))
  1596. (define* (previous-generation-number profile #:optional
  1597. (number (generation-number profile)))
  1598. "Return the number of the generation before generation NUMBER of
  1599. PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
  1600. case when generations have been deleted (there are \"holes\")."
  1601. (or (relative-generation profile -1 number)
  1602. 0))
  1603. (define (generation-file-name profile generation)
  1604. "Return the file name for PROFILE's GENERATION."
  1605. (format #f "~a-~a-link" profile generation))
  1606. (define (generation-time profile number)
  1607. "Return the creation time of a generation in the UTC format."
  1608. (make-time time-utc 0
  1609. (stat:ctime (stat (generation-file-name profile number)))))
  1610. (define (link-to-empty-profile store generation)
  1611. "Link GENERATION, a string, to the empty profile. An error is raised if
  1612. that fails."
  1613. (let* ((drv (run-with-store store
  1614. (profile-derivation (manifest '())
  1615. #:locales? #f)))
  1616. (prof (derivation->output-path drv "out")))
  1617. (build-derivations store (list drv))
  1618. (switch-symlinks generation prof)))
  1619. (define (switch-to-generation profile number)
  1620. "Atomically switch PROFILE to the generation NUMBER. Return the number of
  1621. the generation that was current before switching."
  1622. (let ((current (generation-number profile))
  1623. (generation (generation-file-name profile number)))
  1624. (cond ((not (file-exists? profile))
  1625. (raise (condition (&profile-not-found-error
  1626. (profile profile)))))
  1627. ((not (file-exists? generation))
  1628. (raise (condition (&missing-generation-error
  1629. (profile profile)
  1630. (generation number)))))
  1631. (else
  1632. (switch-symlinks profile (basename generation))
  1633. current))))
  1634. (define (switch-to-previous-generation profile)
  1635. "Atomically switch PROFILE to the previous generation. Return the former
  1636. generation number and the current one."
  1637. (let ((previous (previous-generation-number profile)))
  1638. (values (switch-to-generation profile previous)
  1639. previous)))
  1640. (define (roll-back store profile)
  1641. "Roll back to the previous generation of PROFILE. Return the number of the
  1642. generation that was current before switching and the new generation number."
  1643. (let* ((number (generation-number profile))
  1644. (previous-number (previous-generation-number profile number))
  1645. (previous-generation (generation-file-name profile previous-number)))
  1646. (cond ((not (file-exists? profile)) ;invalid profile
  1647. (raise (condition (&profile-not-found-error
  1648. (profile profile)))))
  1649. ((zero? number) ;empty profile
  1650. (values number number))
  1651. ((or (zero? previous-number) ;going to emptiness
  1652. (not (file-exists? previous-generation)))
  1653. (link-to-empty-profile store previous-generation)
  1654. (switch-to-previous-generation profile))
  1655. (else ;anything else
  1656. (switch-to-previous-generation profile)))))
  1657. (define (delete-generation store profile number)
  1658. "Delete generation with NUMBER from PROFILE. Return the file name of the
  1659. generation that has been deleted, or #f if nothing was done (for instance
  1660. because the NUMBER is zero.)"
  1661. (define (delete-and-return)
  1662. (let ((generation (generation-file-name profile number)))
  1663. (delete-file generation)
  1664. generation))
  1665. (let* ((current-number (generation-number profile))
  1666. (previous-number (previous-generation-number profile number))
  1667. (previous-generation (generation-file-name profile previous-number)))
  1668. (cond ((zero? number) #f) ;do not delete generation 0
  1669. ((and (= number current-number)
  1670. (not (file-exists? previous-generation)))
  1671. (link-to-empty-profile store previous-generation)
  1672. (switch-to-previous-generation profile)
  1673. (delete-and-return))
  1674. ((= number current-number)
  1675. (roll-back store profile)
  1676. (delete-and-return))
  1677. (else
  1678. (delete-and-return)))))
  1679. (define %user-profile-directory
  1680. (and=> (getenv "HOME")
  1681. (cut string-append <> "/.guix-profile")))
  1682. (define %profile-directory
  1683. (string-append %state-directory "/profiles/"
  1684. (or (and=> (or (getenv "USER")
  1685. (getenv "LOGNAME")
  1686. (false-if-exception
  1687. (passwd:name (getpwuid (getuid)))))
  1688. (cut string-append "per-user/" <>))
  1689. "default")))
  1690. (define %current-profile
  1691. ;; Call it `guix-profile', not `profile', to allow Guix profiles to
  1692. ;; coexist with Nix profiles.
  1693. (string-append %profile-directory "/guix-profile"))
  1694. (define (ensure-profile-directory)
  1695. "Attempt to create /…/profiles/per-user/$USER if needed. Nowadays this is
  1696. taken care of by the daemon."
  1697. (let ((s (stat %profile-directory #f)))
  1698. (unless (and s (eq? 'directory (stat:type s)))
  1699. (catch 'system-error
  1700. (lambda ()
  1701. (mkdir-p %profile-directory))
  1702. (lambda args
  1703. ;; Often, we cannot create %PROFILE-DIRECTORY because its
  1704. ;; parent directory is root-owned and we're running
  1705. ;; unprivileged.
  1706. (raise (condition
  1707. (&message
  1708. (message
  1709. (format #f
  1710. (G_ "while creating directory `~a': ~a")
  1711. %profile-directory
  1712. (strerror (system-error-errno args)))))
  1713. (&fix-hint
  1714. (hint
  1715. (format #f (G_ "Please create the @file{~a} directory, \
  1716. with you as the owner.")
  1717. %profile-directory))))))))
  1718. ;; Bail out if it's not owned by the user.
  1719. (unless (or (not s) (= (stat:uid s) (getuid)))
  1720. (raise (condition
  1721. (&message
  1722. (message
  1723. (format #f (G_ "directory `~a' is not owned by you")
  1724. %profile-directory)))
  1725. (&fix-hint
  1726. (hint
  1727. (format #f (G_ "Please change the owner of @file{~a} \
  1728. to user ~s.")
  1729. %profile-directory (or (getenv "USER")
  1730. (getenv "LOGNAME")
  1731. (getuid))))))))))
  1732. (define (canonicalize-profile profile)
  1733. "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that.
  1734. Otherwise return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile'
  1735. as if '-p' was omitted." ; see <http://bugs.gnu.org/17939>
  1736. ;; Trim trailing slashes so 'readlink' can do its job.
  1737. (let ((profile (string-trim-right profile #\/)))
  1738. (catch 'system-error
  1739. (lambda ()
  1740. (let ((target (readlink profile)))
  1741. (if (string=? (dirname target) %profile-directory)
  1742. target
  1743. profile)))
  1744. (const profile))))
  1745. (define %known-shorthand-profiles
  1746. ;; Known shorthand forms for profiles that the user manipulates.
  1747. (list (string-append (config-directory #:ensure? #f) "/current")
  1748. %user-profile-directory))
  1749. (define (user-friendly-profile profile)
  1750. "Return either ~/.guix-profile or ~/.config/guix/current if that's what
  1751. PROFILE refers to, directly or indirectly, or PROFILE."
  1752. (or (find (lambda (shorthand)
  1753. (and shorthand
  1754. (let ((target (false-if-exception
  1755. (readlink shorthand))))
  1756. (and target (string=? target profile)))))
  1757. %known-shorthand-profiles)
  1758. profile))
  1759. ;;; profiles.scm ends here