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