Commit | Line | Data |
---|---|---|
cc4ecc2d | 1 | ;;; GNU Guix --- Functional package management for GNU |
9679123c | 2 | ;;; Copyright © 2013-2022 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> |
15cf09fc | 7 | ;;; Copyright © 2016, 2017, 2018, 2019, 2021, 2022 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> |
20e3dd05 | 10 | ;;; Copyright © 2017, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> |
723f5b1d | 11 | ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com> |
91be09de | 12 | ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com> |
5c79f238 | 13 | ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org> |
ee61777a | 14 | ;;; Copyright © 2014 David Thompson <davet@gnu.org> |
cc4ecc2d LC |
15 | ;;; |
16 | ;;; This file is part of GNU Guix. | |
17 | ;;; | |
18 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
19 | ;;; under the terms of the GNU General Public License as published by | |
20 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
21 | ;;; your option) any later version. | |
22 | ;;; | |
23 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
24 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
25 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
26 | ;;; GNU General Public License for more details. | |
27 | ;;; | |
28 | ;;; You should have received a copy of the GNU General Public License | |
29 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
30 | ||
31 | (define-module (guix profiles) | |
efcb4441 | 32 | #:use-module ((guix config) #:select (%state-directory)) |
97425486 LC |
33 | #:use-module ((guix utils) #:hide (package-name->name+version)) |
34 | #:use-module ((guix build utils) | |
77dcfb4c | 35 | #:select (package-name->name+version mkdir-p)) |
5a573139 | 36 | #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message)) |
77dcfb4c | 37 | #:use-module (guix i18n) |
cc4ecc2d | 38 | #:use-module (guix records) |
cc4ecc2d | 39 | #:use-module (guix packages) |
e89431bf LC |
40 | #:use-module (guix derivations) |
41 | #:use-module (guix search-paths) | |
a54c94a4 | 42 | #:use-module (guix gexp) |
b8396f96 | 43 | #:use-module (guix modules) |
79ee406d | 44 | #:use-module (guix monads) |
e87f0591 | 45 | #:use-module (guix store) |
a654dc4b | 46 | #:use-module (ice-9 vlist) |
cc4ecc2d LC |
47 | #:use-module (ice-9 match) |
48 | #:use-module (ice-9 regex) | |
49 | #:use-module (ice-9 ftw) | |
343745c8 | 50 | #:use-module (ice-9 format) |
cc4ecc2d LC |
51 | #:use-module (srfi srfi-1) |
52 | #:use-module (srfi srfi-9) | |
79601521 | 53 | #:use-module (srfi srfi-11) |
cc4ecc2d LC |
54 | #:use-module (srfi srfi-19) |
55 | #:use-module (srfi srfi-26) | |
c0c018f1 AK |
56 | #:use-module (srfi srfi-34) |
57 | #:use-module (srfi srfi-35) | |
ee61777a | 58 | #:autoload (srfi srfi-98) (get-environment-variables) |
c0c018f1 AK |
59 | #:export (&profile-error |
60 | profile-error? | |
61 | profile-error-profile | |
62 | &profile-not-found-error | |
63 | profile-not-found-error? | |
fdc4f665 | 64 | &profile-collision-error |
a654dc4b LC |
65 | profile-collision-error? |
66 | profile-collision-error-entry | |
67 | profile-collision-error-conflict | |
c0c018f1 AK |
68 | &missing-generation-error |
69 | missing-generation-error? | |
70 | missing-generation-error-generation | |
487cbb01 LC |
71 | &unmatched-pattern-error |
72 | unmatched-pattern-error? | |
73 | unmatched-pattern-error-pattern | |
74 | unmatched-pattern-error-manifest | |
c0c018f1 AK |
75 | |
76 | manifest make-manifest | |
cc4ecc2d LC |
77 | manifest? |
78 | manifest-entries | |
a654dc4b | 79 | manifest-transitive-entries |
cc4ecc2d LC |
80 | |
81 | <manifest-entry> ; FIXME: eventually make it internal | |
82 | manifest-entry | |
83 | manifest-entry? | |
84 | manifest-entry-name | |
85 | manifest-entry-version | |
86 | manifest-entry-output | |
a54c94a4 | 87 | manifest-entry-item |
cc4ecc2d | 88 | manifest-entry-dependencies |
dedb17ad | 89 | manifest-entry-search-paths |
b3a00885 | 90 | manifest-entry-parent |
f6f2346f | 91 | manifest-entry-properties |
190ddfe2 | 92 | lower-manifest-entry |
cc4ecc2d | 93 | |
a357849f | 94 | manifest-entry=? |
cc4ecc2d | 95 | |
a2078770 LC |
96 | manifest-pattern |
97 | manifest-pattern? | |
03763d64 LC |
98 | manifest-pattern-name |
99 | manifest-pattern-version | |
100 | manifest-pattern-output | |
a2078770 | 101 | |
ce30a0eb | 102 | concatenate-manifests |
8a705ae4 | 103 | map-manifest-entries |
cc4ecc2d | 104 | manifest-remove |
f7554030 | 105 | manifest-add |
ef8993e2 | 106 | manifest-lookup |
cc4ecc2d | 107 | manifest-installed? |
a2078770 | 108 | manifest-matching-entries |
f03df3ee | 109 | manifest-search-paths |
993023a2 | 110 | check-for-collisions |
cc4ecc2d | 111 | |
b41e2148 LC |
112 | manifest->code |
113 | ||
343745c8 AK |
114 | manifest-transaction |
115 | manifest-transaction? | |
116 | manifest-transaction-install | |
117 | manifest-transaction-remove | |
c8c25704 LC |
118 | manifest-transaction-install-entry |
119 | manifest-transaction-remove-pattern | |
120 | manifest-transaction-null? | |
6d382339 | 121 | manifest-transaction-removal-candidate? |
343745c8 | 122 | manifest-perform-transaction |
79601521 | 123 | manifest-transaction-effects |
343745c8 | 124 | |
cc4ecc2d | 125 | profile-manifest |
462f5cca | 126 | package->manifest-entry |
23f99f1a | 127 | package->development-manifest |
8404ed5c | 128 | packages->manifest |
849a1b81 | 129 | ca-certificate-bundle |
aa46a028 | 130 | %default-profile-hooks |
67a6828b | 131 | %manifest-format-version |
cc4ecc2d | 132 | profile-derivation |
78d55b70 | 133 | profile-search-paths |
ee61777a | 134 | load-profile |
06d45f45 | 135 | |
ef674a24 LC |
136 | profile |
137 | profile? | |
138 | profile-name | |
139 | profile-content | |
140 | profile-hooks | |
141 | profile-locales? | |
142 | profile-allow-collisions? | |
143 | profile-relative-symlinks? | |
144 | ||
cc4ecc2d | 145 | generation-number |
c872b952 | 146 | generation-profile |
cc4ecc2d | 147 | generation-numbers |
f452e8ff | 148 | profile-generations |
9008debc | 149 | relative-generation-spec->number |
3ccde087 | 150 | relative-generation |
cc4ecc2d LC |
151 | previous-generation-number |
152 | generation-time | |
06d45f45 LC |
153 | generation-file-name |
154 | switch-to-generation | |
155 | roll-back | |
efcb4441 LC |
156 | delete-generation |
157 | ||
158 | %user-profile-directory | |
159 | %profile-directory | |
160 | %current-profile | |
77dcfb4c | 161 | ensure-profile-directory |
efcb4441 | 162 | canonicalize-profile |
5c79f238 DM |
163 | user-friendly-profile |
164 | ||
165 | linux-module-database)) | |
cc4ecc2d LC |
166 | |
167 | ;;; Commentary: | |
168 | ;;; | |
169 | ;;; Tools to create and manipulate profiles---i.e., the representation of a | |
170 | ;;; set of installed packages. | |
171 | ;;; | |
172 | ;;; Code: | |
173 | ||
174 | \f | |
c0c018f1 AK |
175 | ;;; |
176 | ;;; Condition types. | |
177 | ;;; | |
178 | ||
179 | (define-condition-type &profile-error &error | |
180 | profile-error? | |
181 | (profile profile-error-profile)) | |
182 | ||
183 | (define-condition-type &profile-not-found-error &profile-error | |
184 | profile-not-found-error?) | |
185 | ||
a654dc4b LC |
186 | (define-condition-type &profile-collision-error &error |
187 | profile-collision-error? | |
188 | (entry profile-collision-error-entry) ;<manifest-entry> | |
189 | (conflict profile-collision-error-conflict)) ;<manifest-entry> | |
190 | ||
487cbb01 LC |
191 | (define-condition-type &unmatched-pattern-error &error |
192 | unmatched-pattern-error? | |
193 | (pattern unmatched-pattern-error-pattern) ;<manifest-pattern> | |
194 | (manifest unmatched-pattern-error-manifest)) ;<manifest> | |
195 | ||
c0c018f1 AK |
196 | (define-condition-type &missing-generation-error &profile-error |
197 | missing-generation-error? | |
198 | (generation missing-generation-error-generation)) | |
199 | ||
200 | \f | |
cc4ecc2d LC |
201 | ;;; |
202 | ;;; Manifests. | |
203 | ;;; | |
204 | ||
205 | (define-record-type <manifest> | |
206 | (manifest entries) | |
207 | manifest? | |
208 | (entries manifest-entries)) ; list of <manifest-entry> | |
209 | ||
210 | ;; Convenient alias, to avoid name clashes. | |
211 | (define make-manifest manifest) | |
212 | ||
213 | (define-record-type* <manifest-entry> manifest-entry | |
214 | make-manifest-entry | |
215 | manifest-entry? | |
216 | (name manifest-entry-name) ; string | |
217 | (version manifest-entry-version) ; string | |
218 | (output manifest-entry-output ; string | |
219 | (default "out")) | |
3636b1c7 | 220 | (item manifest-entry-item) ; package | file-like | store path |
55b4715f | 221 | (dependencies manifest-entry-dependencies ; <manifest-entry>* |
dedb17ad LC |
222 | (default '())) |
223 | (search-paths manifest-entry-search-paths ; search-path-specification* | |
b3a00885 LC |
224 | (default '())) |
225 | (parent manifest-entry-parent ; promise (#f | <manifest-entry>) | |
f6f2346f LC |
226 | (default (delay #f))) |
227 | (properties manifest-entry-properties ; list of symbol/value pairs | |
228 | (default '()))) | |
cc4ecc2d | 229 | |
a2078770 LC |
230 | (define-record-type* <manifest-pattern> manifest-pattern |
231 | make-manifest-pattern | |
232 | manifest-pattern? | |
233 | (name manifest-pattern-name) ; string | |
234 | (version manifest-pattern-version ; string | #f | |
235 | (default #f)) | |
236 | (output manifest-pattern-output ; string | #f | |
237 | (default "out"))) | |
238 | ||
a357849f LC |
239 | (define (list=? = lst1 lst2) |
240 | "Return true if LST1 and LST2 have the same length and their elements are | |
241 | pairwise equal per =." | |
242 | (match lst1 | |
243 | (() | |
244 | (null? lst2)) | |
245 | ((head1 . tail1) | |
246 | (match lst2 | |
247 | ((head2 . tail2) | |
248 | (and (= head1 head2) (list=? = tail1 tail2))) | |
249 | (() | |
250 | #f))))) | |
251 | ||
252 | (define (manifest-entry=? entry1 entry2) | |
253 | "Return true if ENTRY1 is equivalent to ENTRY2, ignoring their 'properties' | |
254 | field." | |
255 | (match entry1 | |
256 | (($ <manifest-entry> name1 version1 output1 item1 dependencies1 paths1) | |
257 | (match entry2 | |
258 | (($ <manifest-entry> name2 version2 output2 item2 dependencies2 paths2) | |
259 | (and (string=? name1 name2) | |
260 | (string=? version1 version2) | |
261 | (string=? output1 output2) | |
262 | (equal? item1 item2) ;XXX: could be <package> vs. store item | |
263 | (equal? paths1 paths2) | |
264 | (list=? manifest-entry=? dependencies1 dependencies2))))))) | |
265 | ||
2e2b5ad7 LC |
266 | (define (manifest-transitive-entries manifest) |
267 | "Return the entries of MANIFEST along with their propagated inputs, | |
268 | recursively." | |
269 | (let loop ((entries (manifest-entries manifest)) | |
270 | (result '()) | |
9acac9f9 | 271 | (visited vlist-null)) ;compare with 'manifest-entry=?' |
2e2b5ad7 LC |
272 | (match entries |
273 | (() | |
274 | (reverse result)) | |
275 | ((head . tail) | |
9acac9f9 | 276 | (if (vhash-assoc head visited manifest-entry=?) |
2e2b5ad7 LC |
277 | (loop tail result visited) |
278 | (loop (append (manifest-entry-dependencies head) | |
279 | tail) | |
280 | (cons head result) | |
9acac9f9 | 281 | (vhash-cons head #t visited))))))) |
2e2b5ad7 | 282 | |
cc4ecc2d LC |
283 | (define (profile-manifest profile) |
284 | "Return the PROFILE's manifest." | |
285 | (let ((file (string-append profile "/manifest"))) | |
286 | (if (file-exists? file) | |
287 | (call-with-input-file file read-manifest) | |
288 | (manifest '())))) | |
289 | ||
a654dc4b LC |
290 | (define (manifest-entry-lookup manifest) |
291 | "Return a lookup procedure for the entries of MANIFEST. The lookup | |
292 | procedure takes two arguments: the entry name and output." | |
293 | (define mapping | |
294 | (let loop ((entries (manifest-entries manifest)) | |
295 | (mapping vlist-null)) | |
296 | (fold (lambda (entry result) | |
297 | (vhash-cons (cons (manifest-entry-name entry) | |
298 | (manifest-entry-output entry)) | |
299 | entry | |
300 | (loop (manifest-entry-dependencies entry) | |
301 | result))) | |
302 | mapping | |
303 | entries))) | |
304 | ||
305 | (lambda (name output) | |
306 | (match (vhash-assoc (cons name output) mapping) | |
307 | ((_ . entry) entry) | |
308 | (#f #f)))) | |
309 | ||
310 | (define* (lower-manifest-entry entry system #:key target) | |
311 | "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store | |
312 | file name." | |
1a9a373e LC |
313 | (define (recurse entry) |
314 | (mapm/accumulate-builds (lambda (entry) | |
315 | (lower-manifest-entry entry system | |
316 | #:target target)) | |
317 | (manifest-entry-dependencies entry))) | |
318 | ||
a654dc4b LC |
319 | (let ((item (manifest-entry-item entry))) |
320 | (if (string? item) | |
321 | (with-monad %store-monad | |
322 | (return entry)) | |
323 | (mlet %store-monad ((drv (lower-object item system | |
324 | #:target target)) | |
1a9a373e | 325 | (dependencies (recurse entry)) |
a654dc4b LC |
326 | (output -> (manifest-entry-output entry))) |
327 | (return (manifest-entry | |
328 | (inherit entry) | |
1a9a373e LC |
329 | (item (derivation->output-path drv output)) |
330 | (dependencies dependencies))))))) | |
a654dc4b LC |
331 | |
332 | (define* (check-for-collisions manifest system #:key target) | |
333 | "Check whether the entries of MANIFEST conflict with one another; raise a | |
334 | '&profile-collision-error' when a conflict is encountered." | |
335 | (define lookup | |
336 | (manifest-entry-lookup manifest)) | |
337 | ||
25af35fa LC |
338 | (define candidates |
339 | (filter-map (lambda (entry) | |
340 | (let ((other (lookup (manifest-entry-name entry) | |
341 | (manifest-entry-output entry)))) | |
2ac5e07a LC |
342 | (and other |
343 | (not (eq? (manifest-entry-item entry) | |
344 | (manifest-entry-item other))) | |
345 | (list entry other)))) | |
25af35fa LC |
346 | (manifest-transitive-entries manifest))) |
347 | ||
348 | (define lower-pair | |
349 | (match-lambda | |
350 | ((first second) | |
351 | (mlet %store-monad ((first (lower-manifest-entry first system | |
352 | #:target target)) | |
353 | (second (lower-manifest-entry second system | |
354 | #:target target))) | |
355 | (return (list first second)))))) | |
356 | ||
357 | ;; Start by lowering CANDIDATES "in parallel". | |
358 | (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates))) | |
a654dc4b | 359 | (foldm %store-monad |
25af35fa LC |
360 | (lambda (entries result) |
361 | (match entries | |
362 | ((first second) | |
363 | (if (string=? (manifest-entry-item first) | |
364 | (manifest-entry-item second)) | |
365 | (return result) | |
366 | (raise (condition | |
367 | (&profile-collision-error | |
368 | (entry first) | |
369 | (conflict second)))))))) | |
a654dc4b | 370 | #t |
25af35fa | 371 | lst))) |
a654dc4b | 372 | |
90ea8b16 LC |
373 | (define (default-properties package) |
374 | "Return the default properties of a manifest entry for PACKAGE." | |
375 | ;; Preserve transformation options by default. | |
376 | (match (assq-ref (package-properties package) 'transformations) | |
377 | (#f '()) | |
378 | (transformations `((transformations . ,transformations))))) | |
379 | ||
b3a00885 | 380 | (define* (package->manifest-entry package #:optional (output "out") |
2b73d828 | 381 | #:key (parent (delay #f)) |
90ea8b16 | 382 | (properties (default-properties package))) |
9e90fc77 | 383 | "Return a manifest entry for the OUTPUT of package PACKAGE." |
b3a00885 LC |
384 | ;; For each dependency, keep a promise pointing to its "parent" entry. |
385 | (letrec* ((deps (map (match-lambda | |
386 | ((label package) | |
387 | (package->manifest-entry package | |
388 | #:parent (delay entry))) | |
389 | ((label package output) | |
390 | (package->manifest-entry package output | |
391 | #:parent (delay entry)))) | |
392 | (package-propagated-inputs package))) | |
393 | (entry (manifest-entry | |
394 | (name (package-name package)) | |
395 | (version (package-version package)) | |
396 | (output output) | |
397 | (item package) | |
398 | (dependencies (delete-duplicates deps)) | |
399 | (search-paths | |
400 | (package-transitive-native-search-paths package)) | |
2b73d828 LC |
401 | (parent parent) |
402 | (properties properties)))) | |
b3a00885 | 403 | entry)) |
462f5cca | 404 | |
23f99f1a LC |
405 | (define* (package->development-manifest package |
406 | #:optional | |
407 | (system (%current-system)) | |
408 | #:key target) | |
409 | "Return a manifest for the \"development inputs\" of PACKAGE for SYSTEM, | |
410 | optionally when cross-compiling to TARGET. Development inputs include both | |
411 | explicit and implicit inputs of PACKAGE." | |
412 | (manifest | |
413 | (filter-map (match-lambda | |
414 | ((label (? package? package)) | |
415 | (package->manifest-entry package)) | |
416 | ((label (? package? package) output) | |
417 | (package->manifest-entry package output)) | |
418 | ;; TODO: Support <inferior-package>. | |
419 | (_ | |
420 | #f)) | |
421 | (package-development-inputs package system #:target target)))) | |
422 | ||
8404ed5c DT |
423 | (define (packages->manifest packages) |
424 | "Return a list of manifest entries, one for each item listed in PACKAGES. | |
425 | Elements of PACKAGES can be either package objects or package/string tuples | |
426 | denoting a specific output of a package." | |
811b21fb LC |
427 | (define inferiors-loaded? |
428 | ;; This hack allows us to provide seamless integration for inferior | |
429 | ;; packages while not having a hard dependency on (guix inferior). | |
430 | (resolve-module '(guix inferior) #f #f #:ensure #f)) | |
431 | ||
432 | (define (inferior->entry) | |
433 | (module-ref (resolve-interface '(guix inferior)) | |
434 | 'inferior-package->manifest-entry)) | |
435 | ||
8404ed5c | 436 | (manifest |
07340cbe LP |
437 | (delete-duplicates |
438 | (map (match-lambda | |
439 | (((? package? package) output) | |
440 | (package->manifest-entry package output)) | |
441 | ((? package? package) | |
442 | (package->manifest-entry package)) | |
443 | ((thing output) | |
444 | (if inferiors-loaded? | |
445 | ((inferior->entry) thing output) | |
446 | (throw 'wrong-type-arg 'packages->manifest | |
447 | "Wrong package object: ~S" (list thing) (list thing)))) | |
448 | (thing | |
449 | (if inferiors-loaded? | |
450 | ((inferior->entry) thing) | |
451 | (throw 'wrong-type-arg 'packages->manifest | |
452 | "Wrong package object: ~S" (list thing) (list thing))))) | |
453 | packages) | |
454 | manifest-entry=?))) | |
8404ed5c | 455 | |
89e22887 LC |
456 | (define %manifest-format-version |
457 | ;; The current manifest format version. | |
458 | 4) | |
459 | ||
460 | (define* (manifest->gexp manifest #:optional | |
461 | (format-version %manifest-format-version)) | |
462 | "Return a representation in FORMAT-VERSION of MANIFEST as a gexp." | |
4ff12d1d | 463 | (define (optional name value) |
89e22887 LC |
464 | (match format-version |
465 | (4 | |
466 | (if (null? value) | |
467 | #~() | |
468 | #~((#$name #$value)))) | |
469 | (3 | |
470 | (match name | |
471 | ('properties #~((#$name #$@value))) | |
472 | (_ #~((#$name #$value))))))) | |
4ff12d1d | 473 | |
a54c94a4 | 474 | (define (entry->gexp entry) |
4ff12d1d LC |
475 | ;; Maintain in state monad a vhash of visited entries, indexed by their |
476 | ;; item, usually package objects (we cannot use the entry itself as an | |
477 | ;; index since identical entries are usually not 'eq?'). Use that vhash | |
478 | ;; to avoid repeating duplicate entries. This is particularly useful in | |
479 | ;; the presence of propagated inputs, where we could otherwise end up | |
480 | ;; repeating large trees. | |
481 | (mlet %state-monad ((visited (current-state))) | |
89e22887 LC |
482 | (if (and (= format-version 4) |
483 | (match (vhash-assq (manifest-entry-item entry) visited) | |
484 | ((_ . previous-entry) | |
485 | (manifest-entry=? previous-entry entry)) | |
486 | (#f #f))) | |
4ff12d1d LC |
487 | (return #~(repeated #$(manifest-entry-name entry) |
488 | #$(manifest-entry-version entry) | |
489 | (ungexp (manifest-entry-item entry) | |
490 | (manifest-entry-output entry)))) | |
491 | (mbegin %state-monad | |
492 | (set-current-state (vhash-consq (manifest-entry-item entry) | |
493 | entry visited)) | |
494 | (mlet %state-monad ((deps (mapm %state-monad entry->gexp | |
495 | (manifest-entry-dependencies entry)))) | |
496 | (return | |
497 | (match entry | |
498 | (($ <manifest-entry> name version output (? string? path) | |
499 | (_ ...) (search-paths ...) _ (properties ...)) | |
500 | #~(#$name #$version #$output #$path | |
501 | #$@(optional 'propagated-inputs deps) | |
502 | #$@(optional 'search-paths | |
503 | (map search-path-specification->sexp | |
504 | search-paths)) | |
505 | #$@(optional 'properties properties))) | |
506 | (($ <manifest-entry> name version output package | |
507 | (_deps ...) (search-paths ...) _ (properties ...)) | |
508 | #~(#$name #$version #$output | |
509 | (ungexp package (or output "out")) | |
510 | #$@(optional 'propagated-inputs deps) | |
511 | #$@(optional 'search-paths | |
512 | (map search-path-specification->sexp | |
513 | search-paths)) | |
514 | #$@(optional 'properties properties)))))))))) | |
cc4ecc2d | 515 | |
89e22887 LC |
516 | (unless (memq format-version '(3 4)) |
517 | (raise (formatted-message | |
518 | (G_ "cannot emit manifests formatted as version ~a") | |
519 | format-version))) | |
520 | ||
cc4ecc2d LC |
521 | (match manifest |
522 | (($ <manifest> (entries ...)) | |
89e22887 | 523 | #~(manifest (version #$format-version) |
4ff12d1d LC |
524 | (packages #$(run-with-state |
525 | (mapm %state-monad entry->gexp entries) | |
526 | vlist-null)))))) | |
cc4ecc2d LC |
527 | |
528 | (define (sexp->manifest sexp) | |
529 | "Parse SEXP as a manifest." | |
b3a00885 | 530 | (define (infer-dependency item parent) |
55b4715f LC |
531 | ;; Return a <manifest-entry> for ITEM. |
532 | (let-values (((name version) | |
533 | (package-name->name+version | |
534 | (store-path-package-name item)))) | |
535 | (manifest-entry | |
536 | (name name) | |
537 | (version version) | |
b3a00885 LC |
538 | (item item) |
539 | (parent parent)))) | |
540 | ||
4ff12d1d LC |
541 | (define* (sexp->manifest-entry/v3 sexp #:optional (parent (delay #f))) |
542 | ;; Read SEXP as a version 3 manifest entry. | |
b3a00885 LC |
543 | (match sexp |
544 | ((name version output path | |
545 | ('propagated-inputs deps) | |
546 | ('search-paths search-paths) | |
547 | extra-stuff ...) | |
548 | ;; For each of DEPS, keep a promise pointing to ENTRY. | |
4ff12d1d | 549 | (letrec* ((deps* (map (cut sexp->manifest-entry/v3 <> (delay entry)) |
b3a00885 LC |
550 | deps)) |
551 | (entry (manifest-entry | |
552 | (name name) | |
553 | (version version) | |
554 | (output output) | |
555 | (item path) | |
556 | (dependencies deps*) | |
557 | (search-paths (map sexp->search-path-specification | |
558 | search-paths)) | |
f6f2346f LC |
559 | (parent parent) |
560 | (properties (or (assoc-ref extra-stuff 'properties) | |
561 | '()))))) | |
b3a00885 | 562 | entry)))) |
55b4715f | 563 | |
4ff12d1d LC |
564 | (define-syntax let-fields |
565 | (syntax-rules () | |
566 | ;; Bind the fields NAME of LST to same-named variables in the lexical | |
567 | ;; scope of BODY. | |
568 | ((_ lst (name rest ...) body ...) | |
569 | (let ((name (match (assq 'name lst) | |
570 | ((_ value) value) | |
571 | (#f '())))) | |
572 | (let-fields lst (rest ...) body ...))) | |
573 | ((_ lst () body ...) | |
574 | (begin body ...)))) | |
575 | ||
576 | (define* (sexp->manifest-entry sexp #:optional (parent (delay #f))) | |
577 | (match sexp | |
578 | (('repeated name version path) | |
579 | ;; This entry is the same as another one encountered earlier; look it | |
580 | ;; up and return it. | |
581 | (mlet %state-monad ((visited (current-state)) | |
582 | (key -> (list name version path))) | |
583 | (match (vhash-assoc key visited) | |
584 | (#f | |
585 | (raise (formatted-message | |
586 | (G_ "invalid repeated entry in profile: ~s") | |
587 | sexp))) | |
588 | ((_ . entry) | |
589 | (return entry))))) | |
590 | ((name version output path fields ...) | |
591 | (let-fields fields (propagated-inputs search-paths properties) | |
592 | (mlet* %state-monad | |
593 | ((entry -> #f) | |
594 | (deps (mapm %state-monad | |
595 | (cut sexp->manifest-entry <> (delay entry)) | |
596 | propagated-inputs)) | |
597 | (visited (current-state)) | |
598 | (key -> (list name version path))) | |
599 | (set! entry ;XXX: emulate 'letrec*' | |
600 | (manifest-entry | |
601 | (name name) | |
602 | (version version) | |
603 | (output output) | |
604 | (item path) | |
605 | (dependencies deps) | |
606 | (search-paths (map sexp->search-path-specification | |
607 | search-paths)) | |
608 | (parent parent) | |
609 | (properties properties))) | |
610 | (mbegin %state-monad | |
611 | (set-current-state (vhash-cons key entry visited)) | |
612 | (return entry))))))) | |
613 | ||
cc4ecc2d | 614 | (match sexp |
e7e04396 | 615 | ;; Versions 0 and 1 are no longer produced since 2015. |
cc4ecc2d | 616 | |
dedb17ad LC |
617 | ;; Version 2 adds search paths and is slightly more verbose. |
618 | (('manifest ('version 2 minor-version ...) | |
619 | ('packages ((name version output path | |
620 | ('propagated-inputs deps) | |
621 | ('search-paths search-paths) | |
622 | extra-stuff ...) | |
623 | ...))) | |
624 | (manifest | |
625 | (map (lambda (name version output path deps search-paths) | |
b3a00885 LC |
626 | (letrec* ((deps* (map (cute infer-dependency <> (delay entry)) |
627 | deps)) | |
628 | (entry (manifest-entry | |
629 | (name name) | |
630 | (version version) | |
631 | (output output) | |
632 | (item path) | |
633 | (dependencies deps*) | |
634 | (search-paths | |
635 | (map sexp->search-path-specification | |
636 | search-paths))))) | |
637 | entry)) | |
dedb17ad | 638 | name version output path deps search-paths))) |
55b4715f LC |
639 | |
640 | ;; Version 3 represents DEPS as full-blown manifest entries. | |
641 | (('manifest ('version 3 minor-version ...) | |
642 | ('packages (entries ...))) | |
4ff12d1d LC |
643 | (manifest (map sexp->manifest-entry/v3 entries))) |
644 | ||
645 | ;; Version 4 deduplicates repeated entries and makes manifest entry fields | |
646 | ;; such as 'propagated-inputs' and 'search-paths' optional. | |
647 | (('manifest ('version 4 minor-version ...) | |
648 | ('packages (entries ...))) | |
649 | (manifest (run-with-state | |
650 | (mapm %state-monad sexp->manifest-entry entries) | |
651 | vlist-null))) | |
cc4ecc2d | 652 | (_ |
88aab8e3 LC |
653 | (raise (condition |
654 | (&message (message "unsupported manifest format"))))))) | |
cc4ecc2d LC |
655 | |
656 | (define (read-manifest port) | |
657 | "Return the packages listed in MANIFEST." | |
658 | (sexp->manifest (read port))) | |
659 | ||
ce30a0eb LC |
660 | (define (concatenate-manifests lst) |
661 | "Concatenate the manifests listed in LST and return the resulting manifest." | |
662 | (manifest (append-map manifest-entries lst))) | |
663 | ||
8a705ae4 LC |
664 | (define (map-manifest-entries proc manifest) |
665 | "Apply PROC to all the entries of MANIFEST and return a new manifest." | |
666 | (make-manifest | |
667 | (map proc (manifest-entries manifest)))) | |
668 | ||
a2078770 LC |
669 | (define (entry-predicate pattern) |
670 | "Return a procedure that returns #t when passed a manifest entry that | |
671 | matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they | |
672 | are ignored." | |
673 | (match pattern | |
674 | (($ <manifest-pattern> name version output) | |
675 | (match-lambda | |
676 | (($ <manifest-entry> entry-name entry-version entry-output) | |
677 | (and (string=? entry-name name) | |
678 | (or (not entry-output) (not output) | |
679 | (string=? entry-output output)) | |
680 | (or (not version) | |
681 | (string=? entry-version version)))))))) | |
682 | ||
683 | (define (manifest-remove manifest patterns) | |
684 | "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS | |
685 | must be a manifest-pattern." | |
686 | (define (remove-entry pattern lst) | |
687 | (remove (entry-predicate pattern) lst)) | |
688 | ||
689 | (make-manifest (fold remove-entry | |
cc4ecc2d | 690 | (manifest-entries manifest) |
a2078770 | 691 | patterns))) |
cc4ecc2d | 692 | |
f7554030 AK |
693 | (define (manifest-add manifest entries) |
694 | "Add a list of manifest ENTRIES to MANIFEST and return new manifest. | |
695 | Remove MANIFEST entries that have the same name and output as ENTRIES." | |
696 | (define (same-entry? entry name output) | |
697 | (match entry | |
435603a1 | 698 | (($ <manifest-entry> entry-name _ entry-output _) |
f7554030 AK |
699 | (and (equal? name entry-name) |
700 | (equal? output entry-output))))) | |
701 | ||
702 | (make-manifest | |
435603a1 LC |
703 | (fold (lambda (entry result) ;XXX: quadratic |
704 | (match entry | |
705 | (($ <manifest-entry> name _ out _) | |
706 | (cons entry | |
707 | (remove (cut same-entry? <> name out) | |
708 | result))))) | |
709 | (manifest-entries manifest) | |
710 | entries))) | |
f7554030 | 711 | |
ef8993e2 LC |
712 | (define (manifest-lookup manifest pattern) |
713 | "Return the first item of MANIFEST that matches PATTERN, or #f if there is | |
714 | no match.." | |
715 | (find (entry-predicate pattern) | |
716 | (manifest-entries manifest))) | |
717 | ||
a2078770 LC |
718 | (define (manifest-installed? manifest pattern) |
719 | "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), | |
720 | #f otherwise." | |
ef8993e2 | 721 | (->bool (manifest-lookup manifest pattern))) |
cc4ecc2d | 722 | |
a2078770 | 723 | (define (manifest-matching-entries manifest patterns) |
487cbb01 LC |
724 | "Return all the entries of MANIFEST that match one of the PATTERNS. Raise |
725 | an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one | |
726 | of PATTERNS." | |
727 | (fold-right (lambda (pattern matches) | |
728 | (match (filter (entry-predicate pattern) | |
729 | (manifest-entries manifest)) | |
730 | (() | |
731 | (raise (condition | |
732 | (&unmatched-pattern-error | |
733 | (pattern pattern) | |
734 | (manifest manifest))))) | |
735 | (lst | |
736 | (append lst matches)))) | |
737 | '() | |
738 | patterns)) | |
a2078770 | 739 | |
f03df3ee LC |
740 | (define (manifest-search-paths manifest) |
741 | "Return the list of search path specifications that apply to MANIFEST, | |
742 | including the search path specification for $PATH." | |
743 | (delete-duplicates | |
744 | (cons $PATH | |
745 | (append-map manifest-entry-search-paths | |
746 | (manifest-entries manifest))))) | |
747 | ||
b41e2148 LC |
748 | (define* (manifest->code manifest |
749 | #:key (entry-package-version (const ""))) | |
750 | "Return an sexp representing code to build an approximate version of | |
751 | MANIFEST; the code is wrapped in a top-level 'begin' form. Call | |
752 | ENTRY-PACKAGE-VERSION to determine the version number to use in the spec for a | |
753 | given entry; it can be set to 'manifest-entry-version' for fully-specified | |
754 | version numbers, or to some other procedure to disambiguate versions for | |
755 | packages for which several versions are available." | |
756 | (define (entry-transformations entry) | |
757 | ;; Return the transformations that apply to ENTRY. | |
758 | (assoc-ref (manifest-entry-properties entry) 'transformations)) | |
759 | ||
760 | (define transformation-procedures | |
761 | ;; List of transformation options/procedure name pairs. | |
762 | (let loop ((entries (manifest-entries manifest)) | |
763 | (counter 1) | |
764 | (result '())) | |
765 | (match entries | |
766 | (() result) | |
767 | ((entry . tail) | |
768 | (match (entry-transformations entry) | |
769 | (#f | |
770 | (loop tail counter result)) | |
771 | (options | |
772 | (if (assoc-ref result options) | |
773 | (loop tail counter result) | |
774 | (loop tail (+ 1 counter) | |
775 | (alist-cons options | |
776 | (string->symbol | |
777 | (format #f "transform~a" counter)) | |
778 | result))))))))) | |
779 | ||
780 | (define (qualified-name entry) | |
781 | ;; Return the name of ENTRY possibly with "@" followed by a version. | |
782 | (match (entry-package-version entry) | |
783 | ("" (manifest-entry-name entry)) | |
784 | (version (string-append (manifest-entry-name entry) | |
785 | "@" version)))) | |
786 | ||
787 | (if (null? transformation-procedures) | |
788 | `(begin ;simplest case | |
789 | (specifications->manifest | |
790 | (list ,@(map (lambda (entry) | |
791 | (match (manifest-entry-output entry) | |
792 | ("out" (qualified-name entry)) | |
793 | (output (string-append (qualified-name entry) | |
794 | ":" output)))) | |
795 | (manifest-entries manifest))))) | |
796 | (let* ((transform (lambda (options exp) | |
797 | (if (not options) | |
798 | exp | |
799 | (let ((proc (assoc-ref transformation-procedures | |
800 | options))) | |
801 | `(,proc ,exp)))))) | |
802 | `(begin ;transformations apply | |
803 | (use-modules (guix transformations)) | |
804 | ||
805 | ,@(map (match-lambda | |
806 | ((options . name) | |
807 | `(define ,name | |
808 | (options->transformation ',options)))) | |
809 | transformation-procedures) | |
810 | ||
811 | (packages->manifest | |
812 | (list ,@(map (lambda (entry) | |
813 | (define options | |
814 | (entry-transformations entry)) | |
815 | ||
816 | (define name | |
817 | (qualified-name entry)) | |
818 | ||
819 | (match (manifest-entry-output entry) | |
820 | ("out" | |
821 | (transform options | |
822 | `(specification->package ,name))) | |
823 | (output | |
824 | `(list ,(transform | |
825 | options | |
826 | `(specification->package ,name)) | |
827 | ,output)))) | |
828 | (manifest-entries manifest)))))))) | |
829 | ||
cc4ecc2d | 830 | \f |
343745c8 AK |
831 | ;;; |
832 | ;;; Manifest transactions. | |
833 | ;;; | |
834 | ||
835 | (define-record-type* <manifest-transaction> manifest-transaction | |
836 | make-manifest-transaction | |
837 | manifest-transaction? | |
838 | (install manifest-transaction-install ; list of <manifest-entry> | |
839 | (default '())) | |
840 | (remove manifest-transaction-remove ; list of <manifest-pattern> | |
841 | (default '()))) | |
842 | ||
c8c25704 LC |
843 | (define (manifest-transaction-install-entry entry transaction) |
844 | "Augment TRANSACTION's set of installed packages with ENTRY, a | |
845 | <manifest-entry>." | |
846 | (manifest-transaction | |
847 | (inherit transaction) | |
848 | (install | |
849 | (cons entry (manifest-transaction-install transaction))))) | |
850 | ||
851 | (define (manifest-transaction-remove-pattern pattern transaction) | |
852 | "Add PATTERN to TRANSACTION's list of packages to remove." | |
853 | (manifest-transaction | |
854 | (inherit transaction) | |
855 | (remove | |
856 | (cons pattern (manifest-transaction-remove transaction))))) | |
857 | ||
858 | (define (manifest-transaction-null? transaction) | |
859 | "Return true if TRANSACTION has no effect---i.e., it neither installs nor | |
860 | remove software." | |
861 | (match transaction | |
862 | (($ <manifest-transaction> () ()) #t) | |
863 | (($ <manifest-transaction> _ _) #f))) | |
864 | ||
6d382339 LC |
865 | (define (manifest-transaction-removal-candidate? entry transaction) |
866 | "Return true if ENTRY is a candidate for removal in TRANSACTION." | |
867 | (any (lambda (pattern) | |
868 | ((entry-predicate pattern) entry)) | |
869 | (manifest-transaction-remove transaction))) | |
870 | ||
79601521 | 871 | (define (manifest-transaction-effects manifest transaction) |
46b23e1a LC |
872 | "Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values: |
873 | the list of packages that would be removed, installed, upgraded, or downgraded | |
874 | when applying TRANSACTION to MANIFEST. Upgrades are represented as pairs | |
875 | where the head is the entry being upgraded and the tail is the entry that will | |
876 | replace it." | |
79601521 LC |
877 | (define (manifest-entry->pattern entry) |
878 | (manifest-pattern | |
879 | (name (manifest-entry-name entry)) | |
880 | (output (manifest-entry-output entry)))) | |
f5d952c5 LP |
881 | (define manifest-entry-pair=? |
882 | (match-lambda* | |
883 | (((m1a . m2a) (m1b . m2b)) | |
884 | (and (manifest-entry=? m1a m1b) | |
885 | (manifest-entry=? m2a m2b))) | |
886 | (_ #f))) | |
79601521 | 887 | |
46b23e1a LC |
888 | (let loop ((input (manifest-transaction-install transaction)) |
889 | (install '()) | |
890 | (upgrade '()) | |
891 | (downgrade '())) | |
79601521 LC |
892 | (match input |
893 | (() | |
894 | (let ((remove (manifest-transaction-remove transaction))) | |
f5d952c5 LP |
895 | (values (delete-duplicates |
896 | (manifest-matching-entries manifest remove) | |
897 | manifest-entry=?) | |
898 | (delete-duplicates (reverse install) manifest-entry=?) | |
899 | (delete-duplicates | |
900 | (reverse upgrade) | |
901 | manifest-entry-pair=?) | |
902 | (delete-duplicates | |
903 | (reverse downgrade) | |
904 | manifest-entry-pair=?)))) | |
79601521 LC |
905 | ((entry rest ...) |
906 | ;; Check whether installing ENTRY corresponds to the installation of a | |
907 | ;; new package or to an upgrade. | |
908 | ||
909 | ;; XXX: When the exact same output directory is installed, we're not | |
910 | ;; really upgrading anything. Add a check for that case. | |
911 | (let* ((pattern (manifest-entry->pattern entry)) | |
46b23e1a LC |
912 | (previous (manifest-lookup manifest pattern)) |
913 | (newer? (and previous | |
3bea13bb LC |
914 | (version>=? (manifest-entry-version entry) |
915 | (manifest-entry-version previous))))) | |
79601521 | 916 | (loop rest |
ef8993e2 | 917 | (if previous install (cons entry install)) |
46b23e1a | 918 | (if (and previous newer?) |
ef8993e2 | 919 | (alist-cons previous entry upgrade) |
46b23e1a LC |
920 | upgrade) |
921 | (if (and previous (not newer?)) | |
922 | (alist-cons previous entry downgrade) | |
923 | downgrade))))))) | |
79601521 | 924 | |
343745c8 | 925 | (define (manifest-perform-transaction manifest transaction) |
c8c25704 | 926 | "Perform TRANSACTION on MANIFEST and return the new manifest." |
343745c8 AK |
927 | (let ((install (manifest-transaction-install transaction)) |
928 | (remove (manifest-transaction-remove transaction))) | |
929 | (manifest-add (manifest-remove manifest remove) | |
930 | install))) | |
931 | ||
343745c8 | 932 | \f |
cc4ecc2d LC |
933 | ;;; |
934 | ;;; Profiles. | |
935 | ;;; | |
936 | ||
79ee406d | 937 | (define (manifest-inputs manifest) |
b4a4bec0 | 938 | "Return a list of <gexp-input> objects for MANIFEST." |
55b4715f LC |
939 | (define entry->input |
940 | (match-lambda | |
941 | (($ <manifest-entry> name version output thing deps) | |
942 | ;; THING may be a package or a file name. In the latter case, assume | |
943 | ;; it's already valid. | |
944 | (cons (gexp-input thing output) | |
945 | (append-map entry->input deps))))) | |
946 | ||
947 | (append-map entry->input (manifest-entries manifest))) | |
79ee406d | 948 | |
2c9f4786 | 949 | (define* (manifest-lookup-package manifest name #:optional version) |
d72d7833 | 950 | "Return as a monadic value the first package or store path referenced by |
2c9f4786 RW |
951 | MANIFEST that is named NAME and optionally has the given VERSION prefix, or #f |
952 | if not found." | |
d72d7833 SB |
953 | ;; Return as a monadic value the package or store path referenced by the |
954 | ;; manifest ENTRY, or #f if not referenced. | |
955 | (define (entry-lookup-package entry) | |
956 | (define (find-among-inputs inputs) | |
957 | (find (lambda (input) | |
958 | (and (package? input) | |
2c9f4786 RW |
959 | (equal? name (package-name input)) |
960 | (if version | |
961 | (string-prefix? version (package-version input)) | |
962 | #t))) | |
d72d7833 SB |
963 | inputs)) |
964 | (define (find-among-store-items items) | |
965 | (find (lambda (item) | |
054f60cd | 966 | (let-values (((name* version*) |
2c9f4786 RW |
967 | (package-name->name+version |
968 | (store-path-package-name item)))) | |
054f60cd | 969 | (and (string=? name name*) |
2c9f4786 | 970 | (if version |
054f60cd | 971 | (string-prefix? version version*) |
2c9f4786 | 972 | #t)))) |
d72d7833 SB |
973 | items)) |
974 | ||
d72d7833 SB |
975 | (with-monad %store-monad |
976 | (match (manifest-entry-item entry) | |
977 | ((? package? package) | |
963521a3 SB |
978 | (match (cons (list (package-name package) package) |
979 | (package-transitive-inputs package)) | |
d72d7833 SB |
980 | (((labels inputs . _) ...) |
981 | (return (find-among-inputs inputs))))) | |
982 | ((? string? item) | |
983 | (mlet %store-monad ((refs (references* item))) | |
3636b1c7 LC |
984 | (return (find-among-store-items refs)))) |
985 | (item | |
986 | ;; XXX: ITEM might be a 'computed-file' or anything like that, in | |
987 | ;; which case we don't know what to do. The fix may be to check | |
988 | ;; references once ITEM is compiled, as proposed at | |
989 | ;; <https://bugs.gnu.org/29927>. | |
990 | (return #f))))) | |
d72d7833 SB |
991 | |
992 | (anym %store-monad | |
993 | entry-lookup-package (manifest-entries manifest))) | |
994 | ||
79ee406d LC |
995 | (define (info-dir-file manifest) |
996 | "Return a derivation that builds the 'dir' file for all the entries of | |
997 | MANIFEST." | |
2f0556ae LC |
998 | (define texinfo ;lazy reference |
999 | (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo)) | |
1000 | (define gzip ;lazy reference | |
1001 | (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) | |
5b0c648a LC |
1002 | (define glibc-utf8-locales ;lazy reference |
1003 | (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) | |
2f0556ae | 1004 | |
79ee406d | 1005 | (define build |
99b231de LC |
1006 | (with-imported-modules '((guix build utils)) |
1007 | #~(begin | |
1008 | (use-modules (guix build utils) | |
1009 | (srfi srfi-1) (srfi srfi-26) | |
1010 | (ice-9 ftw)) | |
1011 | ||
1012 | (define (info-file? file) | |
1013 | (or (string-suffix? ".info" file) | |
1014 | (string-suffix? ".info.gz" file))) | |
1015 | ||
1016 | (define (info-files top) | |
1017 | (let ((infodir (string-append top "/share/info"))) | |
1018 | (map (cut string-append infodir "/" <>) | |
1019 | (or (scandir infodir info-file?) '())))) | |
1020 | ||
5b0c648a LC |
1021 | (define (info-file-language file) |
1022 | (let* ((base (if (string-suffix? ".gz" file) | |
1023 | (basename file ".info.gz") | |
1024 | (basename file ".info"))) | |
1025 | (dot (string-rindex base #\.))) | |
1026 | (if dot | |
1027 | (string-drop base (+ 1 dot)) | |
1028 | "en"))) | |
1029 | ||
99b231de | 1030 | (define (install-info info) |
5b0c648a LC |
1031 | (let ((language (info-file-language info))) |
1032 | ;; We need to choose a valid locale for $LANGUAGE to be honored. | |
1033 | (setenv "LC_ALL" "en_US.utf8") | |
1034 | (setenv "LANGUAGE" language) | |
1035 | (zero? | |
1036 | (system* #+(file-append texinfo "/bin/install-info") | |
1037 | "--silent" info | |
1038 | (apply string-append #$output "/share/info/dir" | |
1039 | (if (string=? "en" language) | |
1040 | '("") | |
1041 | `("." ,language))))))) | |
1042 | ||
1043 | (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files | |
1044 | (setenv "GUIX_LOCPATH" | |
1045 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
99b231de LC |
1046 | |
1047 | (mkdir-p (string-append #$output "/share/info")) | |
1048 | (exit (every install-info | |
1049 | (append-map info-files | |
1050 | '#$(manifest-inputs manifest))))))) | |
79ee406d | 1051 | |
aa46a028 | 1052 | (gexp->derivation "info-dir" build |
a7a4fd9a | 1053 | #:local-build? #t |
80eebee9 RW |
1054 | #:substitutable? #f |
1055 | #:properties | |
1056 | `((type . profile-hook) | |
1057 | (hook . info-dir)))) | |
79ee406d | 1058 | |
042bc828 FB |
1059 | (define (ghc-package-cache-file manifest) |
1060 | "Return a derivation that builds the GHC 'package.cache' file for all the | |
aa46a028 | 1061 | entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." |
99b231de | 1062 | (define ghc ;lazy reference |
042bc828 FB |
1063 | (module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) |
1064 | ||
1065 | (define build | |
99b231de LC |
1066 | (with-imported-modules '((guix build utils)) |
1067 | #~(begin | |
1068 | (use-modules (guix build utils) | |
1069 | (srfi srfi-1) (srfi srfi-26) | |
1070 | (ice-9 ftw)) | |
1071 | ||
1072 | (define ghc-name-version | |
1073 | (let* ((base (basename #+ghc))) | |
1074 | (string-drop base | |
1075 | (+ 1 (string-index base #\-))))) | |
1076 | ||
1077 | (define db-subdir | |
1078 | (string-append "lib/" ghc-name-version "/package.conf.d")) | |
1079 | ||
1080 | (define db-dir | |
1081 | (string-append #$output "/" db-subdir)) | |
1082 | ||
1083 | (define (conf-files top) | |
1084 | (let ((db (string-append top "/" db-subdir))) | |
1085 | (if (file-exists? db) | |
1086 | (find-files db "\\.conf$") | |
1087 | '()))) | |
1088 | ||
1089 | (define (copy-conf-file conf) | |
1090 | (let ((base (basename conf))) | |
1091 | (copy-file conf (string-append db-dir "/" base)))) | |
1092 | ||
1093 | (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) | |
1094 | (for-each copy-conf-file | |
1095 | (append-map conf-files | |
1096 | (delete-duplicates | |
1097 | '#$(manifest-inputs manifest)))) | |
1098 | (let ((success | |
1099 | (zero? | |
1100 | (system* (string-append #+ghc "/bin/ghc-pkg") "recache" | |
1101 | (string-append "--package-db=" db-dir))))) | |
1102 | (for-each delete-file (find-files db-dir "\\.conf$")) | |
1103 | (exit success))))) | |
042bc828 | 1104 | |
07eaecfa LC |
1105 | (with-monad %store-monad |
1106 | ;; Don't depend on GHC when there's nothing to do. | |
1107 | (if (any (cut string-prefix? "ghc" <>) | |
1108 | (map manifest-entry-name (manifest-entries manifest))) | |
1109 | (gexp->derivation "ghc-package-cache" build | |
a7a4fd9a | 1110 | #:local-build? #t |
80eebee9 RW |
1111 | #:substitutable? #f |
1112 | #:properties | |
1113 | `((type . profile-hook) | |
1114 | (hook . ghc-package-cache))) | |
07eaecfa | 1115 | (return #f)))) |
042bc828 | 1116 | |
536c3ee4 MW |
1117 | (define (ca-certificate-bundle manifest) |
1118 | "Return a derivation that builds a single-file bundle containing the CA | |
1119 | certificates in the /etc/ssl/certs sub-directories of the packages in | |
1120 | MANIFEST. Single-file bundles are required by programs such as Git and Lynx." | |
1121 | ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html> | |
1122 | ;; for a discussion. | |
1123 | ||
1124 | (define glibc-utf8-locales ;lazy reference | |
1125 | (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) | |
1126 | ||
1127 | (define build | |
99b231de LC |
1128 | (with-imported-modules '((guix build utils)) |
1129 | #~(begin | |
1130 | (use-modules (guix build utils) | |
1131 | (rnrs io ports) | |
1132 | (srfi srfi-1) | |
1133 | (srfi srfi-26) | |
1134 | (ice-9 ftw) | |
1135 | (ice-9 match)) | |
1136 | ||
1137 | (define (pem-file? file) | |
1138 | (string-suffix? ".pem" file)) | |
1139 | ||
1140 | (define (ca-files top) | |
1141 | (let ((cert-dir (string-append top "/etc/ssl/certs"))) | |
1142 | (map (cut string-append cert-dir "/" <>) | |
1143 | (or (scandir cert-dir pem-file?) '())))) | |
1144 | ||
1145 | (define (concatenate-files files result) | |
1146 | "Make RESULT the concatenation of all of FILES." | |
1147 | (define (dump file port) | |
1148 | (display (call-with-input-file file get-string-all) | |
1149 | port) | |
1150 | (newline port)) ;required, see <https://bugs.debian.org/635570> | |
1151 | ||
1152 | (call-with-output-file result | |
1153 | (lambda (port) | |
1154 | (for-each (cut dump <> port) files)))) | |
1155 | ||
1156 | ;; Some file names in the NSS certificates are UTF-8 encoded so | |
1157 | ;; install a UTF-8 locale. | |
1158 | (setenv "LOCPATH" | |
1159 | (string-append #+glibc-utf8-locales "/lib/locale/" | |
c6bc8e22 MB |
1160 | #+(version-major+minor |
1161 | (package-version glibc-utf8-locales)))) | |
99b231de LC |
1162 | (setlocale LC_ALL "en_US.utf8") |
1163 | ||
1164 | (match (append-map ca-files '#$(manifest-inputs manifest)) | |
1165 | (() | |
1166 | ;; Since there are no CA files, just create an empty directory. Do | |
1167 | ;; not create the etc/ssl/certs sub-directory, since that would | |
1168 | ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be | |
1169 | ;; defined. | |
1170 | (mkdir #$output) | |
1171 | #t) | |
1172 | ((ca-files ...) | |
1173 | (let ((result (string-append #$output "/etc/ssl/certs"))) | |
1174 | (mkdir-p result) | |
1175 | (concatenate-files ca-files | |
1176 | (string-append result | |
1177 | "/ca-certificates.crt")) | |
1178 | #t)))))) | |
536c3ee4 | 1179 | |
aa46a028 | 1180 | (gexp->derivation "ca-certificate-bundle" build |
a7a4fd9a | 1181 | #:local-build? #t |
80eebee9 RW |
1182 | #:substitutable? #f |
1183 | #:properties | |
1184 | `((type . profile-hook) | |
1185 | (hook . ca-certificate-bundle)))) | |
aa46a028 | 1186 | |
68228d80 LP |
1187 | (define (emacs-subdirs manifest) |
1188 | (define build | |
1189 | (with-imported-modules (source-module-closure | |
1190 | '((guix build profiles) | |
1191 | (guix build utils))) | |
1192 | #~(begin | |
1193 | (use-modules (guix build utils) | |
1194 | (guix build profiles) | |
1195 | (ice-9 ftw) ; scandir | |
1196 | (srfi srfi-1) ; append-map | |
1197 | (srfi srfi-26)) | |
1198 | ||
1199 | (let ((destdir (string-append #$output "/share/emacs/site-lisp")) | |
1200 | (subdirs | |
1201 | (append-map | |
1202 | (lambda (dir) | |
1203 | (filter | |
1204 | file-is-directory? | |
1205 | (map (cute string-append dir "/" <>) | |
1206 | (scandir dir (negate (cute member <> '("." ".."))))))) | |
1207 | (filter file-exists? | |
1208 | (map (cute string-append <> "/share/emacs/site-lisp") | |
1209 | '#$(manifest-inputs manifest)))))) | |
1210 | (mkdir-p destdir) | |
1211 | (with-directory-excursion destdir | |
1212 | (call-with-output-file "subdirs.el" | |
1213 | (lambda (port) | |
1214 | (write | |
1215 | `(normal-top-level-add-to-load-path | |
0f2a17de | 1216 | (list ,@(delete-duplicates subdirs))) |
68228d80 LP |
1217 | port) |
1218 | (newline port) | |
1219 | #t))))))) | |
1220 | (gexp->derivation "emacs-subdirs" build | |
1221 | #:local-build? #t | |
1222 | #:substitutable? #f | |
1223 | #:properties | |
1224 | `((type . profile-hook) | |
1225 | (hook . emacs-subdirs)))) | |
1226 | ||
20e3dd05 MC |
1227 | (define (gdk-pixbuf-loaders-cache-file manifest) |
1228 | "Return a derivation that produces a loaders cache file for every gdk-pixbuf | |
1229 | loaders discovered in MANIFEST." | |
1230 | (define gdk-pixbuf ;lazy reference | |
1231 | (module-ref (resolve-interface '(gnu packages gtk)) 'gdk-pixbuf)) | |
1232 | ||
1233 | (mlet* %store-monad | |
1234 | ((gdk-pixbuf (manifest-lookup-package manifest "gdk-pixbuf")) | |
1235 | (librsvg (manifest-lookup-package manifest "librsvg")) | |
71b30916 MC |
1236 | (gdk-pixbuf-bin -> (if (string? gdk-pixbuf) |
1237 | (string-append gdk-pixbuf "/bin") | |
1238 | (file-append gdk-pixbuf "/bin")))) | |
20e3dd05 MC |
1239 | |
1240 | (define build | |
1241 | (with-imported-modules (source-module-closure | |
1242 | '((guix build glib-or-gtk-build-system))) | |
1243 | #~(begin | |
1244 | (use-modules (guix build glib-or-gtk-build-system)) | |
1245 | (setenv "PATH" (string-append #$gdk-pixbuf-bin ":" (getenv "PATH"))) | |
1246 | ||
1247 | (generate-gdk-pixbuf-loaders-cache | |
1248 | ;; XXX: MANIFEST-LOOKUP-PACKAGE transitively searches through | |
1249 | ;; every input referenced by the manifest, while MANIFEST-INPUTS | |
1250 | ;; only retrieves the immediate inputs as well as their | |
1251 | ;; propagated inputs; to avoid causing an empty output derivation | |
1252 | ;; we must ensure that the inputs contain at least one | |
1253 | ;; loaders.cache file. This is why we include gdk-pixbuf or | |
1254 | ;; librsvg when they are transitively found. | |
1255 | (list #$@(if gdk-pixbuf | |
1256 | (list gdk-pixbuf) | |
1257 | '()) | |
1258 | #$@(if librsvg | |
1259 | (list librsvg) | |
1260 | '()) | |
1261 | #$@(manifest-inputs manifest)) | |
1262 | (list #$output))))) | |
1263 | ||
1264 | (if gdk-pixbuf | |
1265 | (gexp->derivation "gdk-pixbuf-loaders-cache-file" build | |
1266 | #:local-build? #t | |
1267 | #:substitutable? #f | |
1268 | #:properties | |
1269 | '((type . profile-hook) | |
1270 | (hook . gdk-pixbuf-loaders-cache-file))) | |
1271 | (return #f)))) | |
1272 | ||
de136f3e DM |
1273 | (define (glib-schemas manifest) |
1274 | "Return a derivation that unions all schemas from manifest entries and | |
1275 | creates the Glib 'gschemas.compiled' file." | |
1276 | (define glib ; lazy reference | |
1277 | (module-ref (resolve-interface '(gnu packages glib)) 'glib)) | |
1278 | ||
1279 | (mlet %store-monad ((%glib (manifest-lookup-package manifest "glib")) | |
1280 | ;; XXX: Can't use glib-compile-schemas corresponding | |
1281 | ;; to the glib referenced by 'manifest'. Because | |
1282 | ;; '%glib' can be either a package or store path, and | |
1283 | ;; there's no way to get the "bin" output for the later. | |
1284 | (glib-compile-schemas | |
1285 | -> #~(string-append #+glib:bin | |
1286 | "/bin/glib-compile-schemas"))) | |
1287 | ||
1288 | (define build | |
1289 | (with-imported-modules '((guix build utils) | |
1290 | (guix build union) | |
1291 | (guix build profiles) | |
1292 | (guix search-paths) | |
1293 | (guix records)) | |
1294 | #~(begin | |
1295 | (use-modules (guix build utils) | |
1296 | (guix build union) | |
1297 | (guix build profiles) | |
1298 | (srfi srfi-26)) | |
1299 | ||
1300 | (let* ((destdir (string-append #$output "/share/glib-2.0/schemas")) | |
1301 | (schemadirs (filter file-exists? | |
1302 | (map (cut string-append <> "/share/glib-2.0/schemas") | |
1303 | '#$(manifest-inputs manifest))))) | |
1304 | ||
1305 | ;; Union all the schemas. | |
1306 | (mkdir-p (string-append #$output "/share/glib-2.0")) | |
1307 | (union-build destdir schemadirs | |
1308 | #:log-port (%make-void-port "w")) | |
1309 | ||
1310 | (let ((dir destdir)) | |
1311 | (when (file-is-directory? dir) | |
1312 | (ensure-writable-directory dir) | |
1313 | (invoke #+glib-compile-schemas | |
1314 | (string-append "--targetdir=" dir) | |
1315 | dir))))))) | |
1316 | ||
1317 | ;; Don't run the hook when there's nothing to do. | |
1318 | (if %glib | |
1319 | (gexp->derivation "glib-schemas" build | |
1320 | #:local-build? #t | |
80eebee9 RW |
1321 | #:substitutable? #f |
1322 | #:properties | |
1323 | `((type . profile-hook) | |
1324 | (hook . glib-schemas))) | |
de136f3e DM |
1325 | (return #f)))) |
1326 | ||
b04af0ec SB |
1327 | (define (gtk-icon-themes manifest) |
1328 | "Return a derivation that unions all icon themes from manifest entries and | |
1329 | creates the GTK+ 'icon-theme.cache' file for each theme." | |
d1fb4af6 SB |
1330 | (define gtk+ ; lazy reference |
1331 | (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+)) | |
1332 | ||
1333 | (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+")) | |
1334 | ;; XXX: Can't use gtk-update-icon-cache corresponding | |
1335 | ;; to the gtk+ referenced by 'manifest'. Because | |
1336 | ;; '%gtk+' can be either a package or store path, and | |
1337 | ;; there's no way to get the "bin" output for the later. | |
1338 | (gtk-update-icon-cache | |
1339 | -> #~(string-append #+gtk+:bin | |
1340 | "/bin/gtk-update-icon-cache"))) | |
1341 | ||
b04af0ec | 1342 | (define build |
99b231de LC |
1343 | (with-imported-modules '((guix build utils) |
1344 | (guix build union) | |
1345 | (guix build profiles) | |
1346 | (guix search-paths) | |
1347 | (guix records)) | |
1348 | #~(begin | |
1349 | (use-modules (guix build utils) | |
1350 | (guix build union) | |
1351 | (guix build profiles) | |
1352 | (srfi srfi-26) | |
1353 | (ice-9 ftw)) | |
1354 | ||
1355 | (let* ((destdir (string-append #$output "/share/icons")) | |
1356 | (icondirs (filter file-exists? | |
1357 | (map (cut string-append <> "/share/icons") | |
d1fb4af6 | 1358 | '#$(manifest-inputs manifest))))) |
99b231de LC |
1359 | |
1360 | ;; Union all the icons. | |
1361 | (mkdir-p (string-append #$output "/share")) | |
1362 | (union-build destdir icondirs | |
1363 | #:log-port (%make-void-port "w")) | |
1364 | ||
1365 | ;; Update the 'icon-theme.cache' file for each icon theme. | |
1366 | (for-each | |
1367 | (lambda (theme) | |
1368 | (let ((dir (string-append destdir "/" theme))) | |
1369 | ;; Occasionally DESTDIR contains plain files, such as | |
1370 | ;; "abiword_48.png". Ignore these. | |
1371 | (when (file-is-directory? dir) | |
1372 | (ensure-writable-directory dir) | |
d1fb4af6 | 1373 | (system* #+gtk-update-icon-cache "-t" dir "--quiet")))) |
99b231de | 1374 | (scandir destdir (negate (cut member <> '("." ".."))))))))) |
b04af0ec SB |
1375 | |
1376 | ;; Don't run the hook when there's nothing to do. | |
d1fb4af6 | 1377 | (if %gtk+ |
b04af0ec | 1378 | (gexp->derivation "gtk-icon-themes" build |
a7a4fd9a | 1379 | #:local-build? #t |
80eebee9 RW |
1380 | #:substitutable? #f |
1381 | #:properties | |
1382 | `((type . profile-hook) | |
1383 | (hook . gtk-icon-themes))) | |
b04af0ec SB |
1384 | (return #f)))) |
1385 | ||
7ddc1780 RW |
1386 | (define (gtk-im-modules manifest) |
1387 | "Return a derivation that builds the cache files for input method modules | |
1388 | for both major versions of GTK+." | |
1389 | ||
1390 | (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3")) | |
1391 | (gtk+-2 (manifest-lookup-package manifest "gtk+" "2"))) | |
1392 | ||
06d7d119 | 1393 | (define (build gtk gtk-version query) |
7ddc1780 RW |
1394 | (let ((major (string-take gtk-version 1))) |
1395 | (with-imported-modules '((guix build utils) | |
1396 | (guix build union) | |
1397 | (guix build profiles) | |
1398 | (guix search-paths) | |
1399 | (guix records)) | |
1400 | #~(begin | |
1401 | (use-modules (guix build utils) | |
1402 | (guix build union) | |
1403 | (guix build profiles) | |
1404 | (ice-9 popen) | |
1405 | (srfi srfi-1) | |
1406 | (srfi srfi-26)) | |
1407 | ||
1408 | (let* ((prefix (string-append "/lib/gtk-" #$major ".0/" | |
1409 | #$gtk-version)) | |
7ddc1780 RW |
1410 | (destdir (string-append #$output prefix)) |
1411 | (moddirs (cons (string-append #$gtk prefix "/immodules") | |
1412 | (filter file-exists? | |
1413 | (map (cut string-append <> prefix "/immodules") | |
1414 | '#$(manifest-inputs manifest))))) | |
1415 | (modules (append-map (cut find-files <> "\\.so$") | |
1416 | moddirs))) | |
1417 | ||
1418 | ;; Generate a new immodules cache file. | |
1419 | (mkdir-p (string-append #$output prefix)) | |
06d7d119 | 1420 | (let ((pipe (apply open-pipe* OPEN_READ #$query modules)) |
7ddc1780 RW |
1421 | (outfile (string-append #$output prefix |
1422 | "/immodules-gtk" #$major ".cache"))) | |
1423 | (dynamic-wind | |
1424 | (const #t) | |
1425 | (lambda () | |
1426 | (call-with-output-file outfile | |
1427 | (lambda (out) | |
1428 | (while (not (eof-object? (peek-char pipe))) | |
1429 | (write-char (read-char pipe) out)))) | |
1430 | #t) | |
1431 | (lambda () | |
1432 | (close-pipe pipe))))))))) | |
1433 | ||
1434 | ;; Don't run the hook when there's nothing to do. | |
06d7d119 YH |
1435 | (let* ((pkg-gtk+ (module-ref ; lazy reference |
1436 | (resolve-interface '(gnu packages gtk)) 'gtk+)) | |
e8cbebb4 JL |
1437 | (pkg-gtk+2 (module-ref ; lazy reference |
1438 | (resolve-interface '(gnu packages gtk)) 'gtk+-2)) | |
06d7d119 YH |
1439 | (gexp #~(begin |
1440 | #$(if gtk+ | |
1441 | (build | |
1442 | gtk+ "3.0.0" | |
1443 | ;; Use 'gtk-query-immodules-3.0' from the 'bin' | |
1444 | ;; output of latest gtk+ package. | |
1445 | #~(string-append | |
1446 | #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0")) | |
1447 | #t) | |
1448 | #$(if gtk+-2 | |
1449 | (build | |
1450 | gtk+-2 "2.10.0" | |
1451 | #~(string-append | |
28292d8c | 1452 | #$pkg-gtk+2:bin "/bin/gtk-query-immodules-2.0")) |
06d7d119 | 1453 | #t)))) |
7ddc1780 RW |
1454 | (if (or gtk+ gtk+-2) |
1455 | (gexp->derivation "gtk-im-modules" gexp | |
1456 | #:local-build? #t | |
80eebee9 RW |
1457 | #:substitutable? #f |
1458 | #:properties | |
1459 | `((type . profile-hook) | |
1460 | (hook . gtk-im-modules))) | |
7ddc1780 RW |
1461 | (return #f))))) |
1462 | ||
5c79f238 DM |
1463 | (define (linux-module-database manifest) |
1464 | "Return a derivation that unites all the kernel modules of the manifest | |
1465 | and creates the dependency graph of all these kernel modules. | |
1466 | ||
1467 | This is meant to be used as a profile hook." | |
fea072d7 | 1468 | (define kmod ; lazy reference |
5c79f238 | 1469 | (module-ref (resolve-interface '(gnu packages linux)) 'kmod)) |
755f365b MO |
1470 | |
1471 | (define guile-zlib | |
1472 | (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) | |
1473 | ||
5c79f238 | 1474 | (define build |
fea072d7 LC |
1475 | (with-imported-modules (source-module-closure |
1476 | '((guix build utils) | |
5c79f238 | 1477 | (gnu build linux-modules))) |
755f365b MO |
1478 | (with-extensions (list guile-zlib) |
1479 | #~(begin | |
1480 | (use-modules (ice-9 ftw) | |
1481 | (ice-9 match) | |
1482 | (srfi srfi-1) ; append-map | |
1483 | (gnu build linux-modules)) | |
1484 | ||
1485 | (let* ((inputs '#$(manifest-inputs manifest)) | |
1486 | (module-directories | |
1487 | (map (lambda (directory) | |
1488 | (string-append directory "/lib/modules")) | |
1489 | inputs)) | |
1490 | (directory-entries | |
1491 | (lambda (directory) | |
1492 | (or (scandir directory | |
1493 | (lambda (basename) | |
1494 | (not (string-prefix? "." basename)))) | |
1495 | '()))) | |
1496 | ;; Note: Should usually result in one entry. | |
1497 | (versions (delete-duplicates | |
1498 | (append-map directory-entries | |
1499 | module-directories)))) | |
1500 | (match versions | |
1501 | ((version) | |
1502 | (let ((old-path (getenv "PATH"))) | |
1503 | (setenv "PATH" #+(file-append kmod "/bin")) | |
1504 | (make-linux-module-directory inputs version #$output) | |
1505 | (setenv "PATH" old-path))) | |
1506 | (() | |
1507 | ;; Nothing here, maybe because this is a kernel with | |
1508 | ;; CONFIG_MODULES=n. | |
1509 | (mkdir #$output)) | |
1510 | (_ (error "Specified Linux kernel and Linux kernel modules | |
1511 | are not all of the same version")))))))) | |
5c79f238 DM |
1512 | (gexp->derivation "linux-module-database" build |
1513 | #:local-build? #t | |
1514 | #:substitutable? #f | |
1515 | #:properties | |
1516 | `((type . profile-hook) | |
1517 | (hook . linux-module-database)))) | |
1518 | ||
842cb820 SB |
1519 | (define (xdg-desktop-database manifest) |
1520 | "Return a derivation that builds the @file{mimeinfo.cache} database from | |
1521 | desktop files. It's used to query what applications can handle a given | |
1522 | MIME type." | |
85cfbd46 SB |
1523 | (define desktop-file-utils ; lazy reference |
1524 | (module-ref (resolve-interface '(gnu packages freedesktop)) | |
1525 | 'desktop-file-utils)) | |
1526 | ||
1527 | (mlet %store-monad ((glib | |
d72d7833 | 1528 | (manifest-lookup-package |
85cfbd46 | 1529 | manifest "glib"))) |
d72d7833 | 1530 | (define build |
99b231de LC |
1531 | (with-imported-modules '((guix build utils) |
1532 | (guix build union)) | |
1533 | #~(begin | |
1534 | (use-modules (srfi srfi-26) | |
1535 | (guix build utils) | |
1536 | (guix build union)) | |
1537 | (let* ((destdir (string-append #$output "/share/applications")) | |
1538 | (appdirs (filter file-exists? | |
1539 | (map (cut string-append <> | |
1540 | "/share/applications") | |
1541 | '#$(manifest-inputs manifest)))) | |
1542 | (update-desktop-database (string-append | |
1543 | #+desktop-file-utils | |
1544 | "/bin/update-desktop-database"))) | |
1545 | (mkdir-p (string-append #$output "/share")) | |
1546 | (union-build destdir appdirs | |
1547 | #:log-port (%make-void-port "w")) | |
1548 | (exit (zero? (system* update-desktop-database destdir))))))) | |
842cb820 | 1549 | |
85cfbd46 SB |
1550 | ;; Don't run the hook when 'glib' is not referenced. |
1551 | (if glib | |
d72d7833 | 1552 | (gexp->derivation "xdg-desktop-database" build |
d72d7833 | 1553 | #:local-build? #t |
80eebee9 RW |
1554 | #:substitutable? #f |
1555 | #:properties | |
1556 | `((type . profile-hook) | |
1557 | (hook . xdg-desktop-database))) | |
d72d7833 | 1558 | (return #f)))) |
842cb820 | 1559 | |
6c06b1fd SB |
1560 | (define (xdg-mime-database manifest) |
1561 | "Return a derivation that builds the @file{mime.cache} database from manifest | |
1562 | entries. It's used to query the MIME type of a given file." | |
801d316b SB |
1563 | (define shared-mime-info ; lazy reference |
1564 | (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info)) | |
1565 | ||
76ea70bd | 1566 | (mlet %store-monad ((glib (manifest-lookup-package manifest "glib"))) |
d72d7833 | 1567 | (define build |
99b231de LC |
1568 | (with-imported-modules '((guix build utils) |
1569 | (guix build union)) | |
1570 | #~(begin | |
76ea70bd LC |
1571 | (use-modules (guix build utils) |
1572 | (guix build union) | |
1573 | (srfi srfi-26) | |
1574 | (ice-9 match)) | |
1575 | ||
99b231de LC |
1576 | (let* ((datadir (string-append #$output "/share")) |
1577 | (destdir (string-append datadir "/mime")) | |
1578 | (pkgdirs (filter file-exists? | |
1579 | (map (cut string-append <> | |
1580 | "/share/mime/packages") | |
801d316b | 1581 | (cons #+shared-mime-info |
76ea70bd LC |
1582 | '#$(manifest-inputs manifest)))))) |
1583 | ||
1584 | (match pkgdirs | |
1585 | ((shared-mime-info) | |
1586 | ;; PKGDIRS contains nothing but 'shared-mime-info', which | |
1587 | ;; already contains its database, so nothing to do. | |
1588 | (mkdir-p datadir) | |
1589 | (symlink #$(file-append shared-mime-info "/share/mime") | |
1590 | destdir)) | |
1591 | (_ | |
1592 | ;; PKGDIRS contains additional packages providing | |
1593 | ;; 'share/mime/packages' (very few packages do so) so rebuild | |
1594 | ;; the database. TODO: Find a way to avoid reprocessing | |
1595 | ;; 'shared-mime-info', which is the most expensive one. | |
1596 | (mkdir-p destdir) | |
1597 | (union-build (string-append destdir "/packages") pkgdirs | |
1598 | #:log-port (%make-void-port "w")) | |
1599 | (setenv "XDG_DATA_HOME" datadir) | |
1600 | (invoke #+(file-append shared-mime-info | |
1601 | "/bin/update-mime-database") | |
1602 | destdir))))))) | |
d72d7833 | 1603 | |
801d316b SB |
1604 | ;; Don't run the hook when there are no GLib based applications. |
1605 | (if glib | |
d72d7833 | 1606 | (gexp->derivation "xdg-mime-database" build |
d72d7833 | 1607 | #:local-build? #t |
80eebee9 RW |
1608 | #:substitutable? #f |
1609 | #:properties | |
1610 | `((type . profile-hook) | |
1611 | (hook . xdg-mime-database))) | |
d72d7833 | 1612 | (return #f)))) |
6c06b1fd | 1613 | |
0a5ce0d1 HY |
1614 | ;; Several font packages may install font files into same directory, so |
1615 | ;; fonts.dir and fonts.scale file should be generated here, instead of in | |
1616 | ;; packages. | |
9eb5a449 AK |
1617 | (define (fonts-dir-file manifest) |
1618 | "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale} | |
0a5ce0d1 | 1619 | files for the fonts of the @var{manifest} entries." |
9eb5a449 AK |
1620 | (define mkfontscale |
1621 | (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale)) | |
1622 | ||
1623 | (define mkfontdir | |
1624 | (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir)) | |
1625 | ||
1626 | (define build | |
1627 | #~(begin | |
1628 | (use-modules (srfi srfi-26) | |
1629 | (guix build utils) | |
1630 | (guix build union)) | |
0a5ce0d1 HY |
1631 | (let ((fonts-dirs (filter file-exists? |
1632 | (map (cut string-append <> | |
1633 | "/share/fonts") | |
1634 | '#$(manifest-inputs manifest))))) | |
9eb5a449 | 1635 | (mkdir #$output) |
0a5ce0d1 | 1636 | (if (null? fonts-dirs) |
9eb5a449 | 1637 | (exit #t) |
0a5ce0d1 HY |
1638 | (let* ((share-dir (string-append #$output "/share")) |
1639 | (fonts-dir (string-append share-dir "/fonts")) | |
9eb5a449 AK |
1640 | (mkfontscale (string-append #+mkfontscale |
1641 | "/bin/mkfontscale")) | |
1642 | (mkfontdir (string-append #+mkfontdir | |
0a5ce0d1 HY |
1643 | "/bin/mkfontdir")) |
1644 | (empty-file? (lambda (filename) | |
1645 | (call-with-ascii-input-file filename | |
1646 | (lambda (p) | |
1647 | (eqv? #\0 (read-char p)))))) | |
1648 | (fonts-dir-file "fonts.dir") | |
1649 | (fonts-scale-file "fonts.scale")) | |
1650 | (mkdir-p share-dir) | |
1651 | ;; Create all sub-directories, because we may create fonts.dir | |
1652 | ;; and fonts.scale files in the sub-directories. | |
1653 | (union-build fonts-dir fonts-dirs | |
1654 | #:log-port (%make-void-port "w") | |
1655 | #:create-all-directories? #t) | |
1656 | (let ((directories (find-files fonts-dir | |
1657 | (lambda (file stat) | |
1658 | (eq? 'directory (stat:type stat))) | |
1659 | #:directories? #t))) | |
1660 | (for-each (lambda (dir) | |
1661 | (with-directory-excursion dir | |
1662 | (when (file-exists? fonts-scale-file) | |
1663 | (delete-file fonts-scale-file)) | |
1664 | (when (file-exists? fonts-dir-file) | |
1665 | (delete-file fonts-dir-file)) | |
1666 | (unless (and (zero? (system* mkfontscale)) | |
1667 | (zero? (system* mkfontdir))) | |
1668 | (exit #f)) | |
32b7506c RW |
1669 | (when (and (file-exists? fonts-scale-file) |
1670 | (empty-file? fonts-scale-file)) | |
0a5ce0d1 | 1671 | (delete-file fonts-scale-file)) |
32b7506c RW |
1672 | (when (and (file-exists? fonts-dir-file) |
1673 | (empty-file? fonts-dir-file)) | |
0a5ce0d1 HY |
1674 | (delete-file fonts-dir-file)))) |
1675 | directories))))))) | |
9eb5a449 AK |
1676 | |
1677 | (gexp->derivation "fonts-dir" build | |
1678 | #:modules '((guix build utils) | |
0a5ce0d1 HY |
1679 | (guix build union) |
1680 | (srfi srfi-26)) | |
9eb5a449 | 1681 | #:local-build? #t |
80eebee9 RW |
1682 | #:substitutable? #f |
1683 | #:properties | |
1684 | `((type . profile-hook) | |
1685 | (hook . fonts-dir)))) | |
9eb5a449 | 1686 | |
a0b87ef8 MC |
1687 | (define (manual-database manifest) |
1688 | "Return a derivation that builds the manual page database (\"mandb\") for | |
1689 | the entries in MANIFEST." | |
b8396f96 LC |
1690 | (define gdbm-ffi |
1691 | (module-ref (resolve-interface '(gnu packages guile)) | |
1692 | 'guile-gdbm-ffi)) | |
1693 | ||
4c0c65ac MO |
1694 | (define guile-zlib |
1695 | (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) | |
b8396f96 LC |
1696 | |
1697 | (define modules | |
4c0c65ac MO |
1698 | (delete '(guix config) |
1699 | (source-module-closure `((guix build utils) | |
1700 | (guix man-db))))) | |
a0b87ef8 MC |
1701 | |
1702 | (define build | |
b8396f96 | 1703 | (with-imported-modules modules |
4c0c65ac MO |
1704 | (with-extensions (list gdbm-ffi ;for (guix man-db) |
1705 | guile-zlib) | |
331ac4cc LC |
1706 | #~(begin |
1707 | (use-modules (guix man-db) | |
1708 | (guix build utils) | |
ef4b5f2f | 1709 | (ice-9 threads) |
331ac4cc LC |
1710 | (srfi srfi-1) |
1711 | (srfi srfi-19)) | |
1712 | ||
ef4b5f2f AB |
1713 | (define (print-string msg) |
1714 | (display msg) | |
1715 | (force-output)) | |
1716 | ||
1717 | (define-syntax-rule (print fmt args ...) | |
1718 | ;; Build up the string and display it at once. | |
1719 | (print-string (format #f fmt args ...))) | |
1720 | ||
1721 | (define (compute-entry directory count total) | |
1722 | (print "\r[~3d/~3d] building list of man-db entries..." | |
1723 | count total) | |
1724 | (let ((man (string-append directory "/share/man"))) | |
1725 | (if (directory-exists? man) | |
1726 | (mandb-entries man) | |
1727 | '()))) | |
1728 | ||
331ac4cc | 1729 | (define (compute-entries) |
f6fe7da3 LC |
1730 | ;; This is the most expensive part (I/O and CPU, due to |
1731 | ;; decompression), so report progress as we traverse INPUTS. | |
ef4b5f2f AB |
1732 | ;; Cap at 4 threads because we don't see any speedup beyond that |
1733 | ;; on an SSD laptop. | |
1734 | (let* ((inputs '#$(manifest-inputs manifest)) | |
1735 | (total (length inputs)) | |
1736 | (threads (min (parallel-job-count) 4))) | |
1737 | (concatenate | |
1738 | (n-par-map threads compute-entry inputs | |
1739 | (iota total 1) | |
1740 | (make-list total total))))) | |
331ac4cc LC |
1741 | |
1742 | (define man-directory | |
1743 | (string-append #$output "/share/man")) | |
1744 | ||
1745 | (mkdir-p man-directory) | |
1746 | ||
1747 | (format #t "Creating manual page database...~%") | |
1748 | (force-output) | |
1749 | (let* ((start (current-time)) | |
1750 | (entries (compute-entries)) | |
1751 | (_ (write-mandb-database (string-append man-directory | |
1752 | "/index.db") | |
1753 | entries)) | |
1754 | (duration (time-difference (current-time) start))) | |
f6fe7da3 | 1755 | (newline) |
331ac4cc LC |
1756 | (format #t "~a entries processed in ~,1f s~%" |
1757 | (length entries) | |
1758 | (+ (time-second duration) | |
1759 | (* (time-nanosecond duration) (expt 10 -9)))) | |
1760 | (force-output)))))) | |
a0b87ef8 MC |
1761 | |
1762 | (gexp->derivation "manual-database" build | |
69de9839 | 1763 | #:substitutable? #f |
80eebee9 RW |
1764 | #:local-build? #t |
1765 | #:properties | |
1766 | `((type . profile-hook) | |
1767 | (hook . manual-database)))) | |
a0b87ef8 | 1768 | |
3c1158ac LC |
1769 | (define (manual-database/optional manifest) |
1770 | "Return a derivation to build the manual database of MANIFEST, but only if | |
1771 | MANIFEST contains the \"man-db\" package. Otherwise, return #f." | |
1772 | ;; Building the man database (for "man -k") is expensive and rarely used. | |
1773 | ;; Build it only if the profile also contains "man-db". | |
1774 | (mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db"))) | |
1775 | (if man-db | |
1776 | (manual-database manifest) | |
1777 | (return #f)))) | |
1778 | ||
805af862 RW |
1779 | (define (texlive-font-maps manifest) |
1780 | "Return a derivation that builds the TeX Live font maps for the entries in | |
743497b5 RW |
1781 | MANIFEST." |
1782 | (define entry->texlive-input | |
1783 | (match-lambda | |
1784 | (($ <manifest-entry> name version output thing deps) | |
1785 | (if (string-prefix? "texlive-" name) | |
1786 | (cons (gexp-input thing output) | |
1787 | (append-map entry->texlive-input deps)) | |
1788 | '())))) | |
a6b8794c RW |
1789 | (define texlive-bin |
1790 | (module-ref (resolve-interface '(gnu packages tex)) 'texlive-bin)) | |
1791 | (define coreutils | |
1792 | (module-ref (resolve-interface '(gnu packages base)) 'coreutils)) | |
15cf09fc RW |
1793 | (define grep |
1794 | (module-ref (resolve-interface '(gnu packages base)) 'grep)) | |
a6b8794c RW |
1795 | (define sed |
1796 | (module-ref (resolve-interface '(gnu packages base)) 'sed)) | |
1797 | (define updmap.cfg | |
1798 | (module-ref (resolve-interface '(gnu packages tex)) | |
1799 | 'texlive-default-updmap.cfg)) | |
743497b5 RW |
1800 | (define build |
1801 | (with-imported-modules '((guix build utils) | |
1802 | (guix build union)) | |
1803 | #~(begin | |
1804 | (use-modules (guix build utils) | |
a6b8794c RW |
1805 | (guix build union) |
1806 | (ice-9 popen)) | |
743497b5 RW |
1807 | |
1808 | ;; Build a modifiable union of all texlive inputs. We do this so | |
1809 | ;; that TeX live can resolve the parent and grandparent directories | |
1810 | ;; correctly. There might be a more elegant way to accomplish this. | |
805af862 | 1811 | (union-build "/tmp/texlive" |
743497b5 RW |
1812 | '#$(append-map entry->texlive-input |
1813 | (manifest-entries manifest)) | |
1814 | #:create-all-directories? #t | |
1815 | #:log-port (%make-void-port "w")) | |
805af862 RW |
1816 | |
1817 | ;; XXX: This is annoying, but it's necessary because texlive-bin | |
1818 | ;; does not provide wrapped executables. | |
1819 | (setenv "PATH" | |
1820 | (string-append #$(file-append coreutils "/bin") | |
15cf09fc RW |
1821 | ":" |
1822 | #$(file-append grep "/bin") | |
805af862 RW |
1823 | ":" |
1824 | #$(file-append sed "/bin"))) | |
1825 | (setenv "PERL5LIB" #$(file-append texlive-bin "/share/tlpkg")) | |
1826 | (setenv "GUIX_TEXMF" "/tmp/texlive/share/texmf-dist") | |
1827 | ||
1828 | ;; Remove invalid maps from config file. | |
1829 | (let* ((web2c (string-append #$output "/share/texmf-dist/web2c/")) | |
1830 | (maproot (string-append #$output "/share/texmf-dist/fonts/map/")) | |
1831 | (updmap.cfg (string-append web2c "updmap.cfg"))) | |
1832 | (mkdir-p web2c) | |
1833 | (copy-file #$updmap.cfg updmap.cfg) | |
1834 | (make-file-writable updmap.cfg) | |
1835 | (let* ((port (open-pipe* OPEN_WRITE | |
1836 | #$(file-append texlive-bin "/bin/updmap-sys") | |
1837 | "--syncwithtrees" | |
1838 | "--nohash" | |
1839 | "--force" | |
1840 | (string-append "--cnffile=" updmap.cfg)))) | |
1841 | (display "Y\n" port) | |
1842 | (when (not (zero? (status:exit-val (close-pipe port)))) | |
1843 | (error "failed to filter updmap.cfg"))) | |
1844 | ||
1845 | ;; Generate font maps. | |
1846 | (invoke #$(file-append texlive-bin "/bin/updmap-sys") | |
1847 | (string-append "--cnffile=" updmap.cfg) | |
1848 | (string-append "--dvipdfmxoutputdir=" | |
1849 | maproot "dvipdfmx/updmap") | |
1850 | (string-append "--dvipsoutputdir=" | |
1851 | maproot "dvips/updmap") | |
1852 | (string-append "--pdftexoutputdir=" | |
15cf09fc RW |
1853 | maproot "pdftex/updmap")) |
1854 | ||
1855 | ;; Create ls-R file. I know, that's not *just* for font maps, but | |
1856 | ;; we've generated new files, so there's no point in running it | |
1857 | ;; any earlier. The ls-R file must act on a full TeX Live tree, | |
1858 | ;; but we have two: the one in /tmp containing all packages and | |
1859 | ;; the one in #$output containing the generated font maps. To | |
1860 | ;; avoid having to merge ls-R files, we copy the generated stuff | |
1861 | ;; to /tmp and run mktexlsr only once. | |
1862 | (let ((a (string-append #$output "/share/texmf-dist")) | |
1863 | (b "/tmp/texlive/share/texmf-dist") | |
1864 | (mktexlsr #$(file-append texlive-bin "/bin/mktexlsr"))) | |
1865 | (copy-recursively a b) | |
1866 | (invoke mktexlsr b) | |
1867 | (install-file (string-append b "/ls-R") a)))))) | |
743497b5 | 1868 | |
bd8e7621 RW |
1869 | (mlet %store-monad ((texlive-base (manifest-lookup-package manifest "texlive-base"))) |
1870 | (if texlive-base | |
805af862 | 1871 | (gexp->derivation "texlive-font-maps" build |
bd8e7621 RW |
1872 | #:substitutable? #f |
1873 | #:local-build? #t | |
1874 | #:properties | |
1875 | `((type . profile-hook) | |
805af862 | 1876 | (hook . texlive-font-maps))) |
bd8e7621 | 1877 | (return #f)))) |
743497b5 | 1878 | |
aa46a028 LC |
1879 | (define %default-profile-hooks |
1880 | ;; This is the list of derivation-returning procedures that are called by | |
1881 | ;; default when making a non-empty profile. | |
1882 | (list info-dir-file | |
3c1158ac | 1883 | manual-database/optional |
9eb5a449 | 1884 | fonts-dir-file |
aa46a028 | 1885 | ghc-package-cache-file |
b04af0ec | 1886 | ca-certificate-bundle |
68228d80 | 1887 | emacs-subdirs |
20e3dd05 | 1888 | gdk-pixbuf-loaders-cache-file |
de136f3e | 1889 | glib-schemas |
842cb820 | 1890 | gtk-icon-themes |
7ddc1780 | 1891 | gtk-im-modules |
805af862 | 1892 | texlive-font-maps |
6c06b1fd SB |
1893 | xdg-desktop-database |
1894 | xdg-mime-database)) | |
536c3ee4 MW |
1895 | |
1896 | (define* (profile-derivation manifest | |
1897 | #:key | |
416f7f4f | 1898 | (name "profile") |
e5f04c2d | 1899 | (hooks %default-profile-hooks) |
a6562c7e | 1900 | (locales? #t) |
5a573139 | 1901 | (allow-unsupported-packages? #f) |
afd06f60 | 1902 | (allow-collisions? #f) |
e00ade3f | 1903 | (relative-symlinks? #f) |
89e22887 | 1904 | (format-version %manifest-format-version) |
176febe3 | 1905 | system target) |
79ee406d | 1906 | "Return a derivation that builds a profile (aka. 'user environment') with |
aa46a028 | 1907 | the given MANIFEST. The profile includes additional derivations returned by |
a6562c7e | 1908 | the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc. |
afd06f60 LC |
1909 | Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if |
1910 | entries in MANIFEST collide (for instance if there are two same-name packages | |
5a573139 LC |
1911 | with a different version number.) Unless ALLOW-UNSUPPORTED-PACKAGES? is true |
1912 | or TARGET is set, raise an error if MANIFEST contains a package that does not | |
1913 | support SYSTEM. | |
a6562c7e LC |
1914 | |
1915 | When LOCALES? is true, the build is performed under a UTF-8 locale; this adds | |
176febe3 LC |
1916 | a dependency on the 'glibc-utf8-locales' package. |
1917 | ||
e00ade3f LC |
1918 | When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets. |
1919 | This is one of the things to do for the result to be relocatable. | |
1920 | ||
176febe3 LC |
1921 | When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST |
1922 | are cross-built for TARGET." | |
5a573139 LC |
1923 | (define (check-supported-packages system) |
1924 | ;; Raise an error if a package in MANIFEST does not support SYSTEM. | |
1925 | (map-manifest-entries | |
1926 | (lambda (entry) | |
1927 | ||
1928 | (match (manifest-entry-item entry) | |
1929 | ((? package? package) | |
1930 | (unless (supported-package? package system) | |
1931 | (raise (formatted-message (G_ "package ~a does not support ~a") | |
1932 | (package-full-name package) system)))) | |
1933 | (_ #t))) | |
1934 | manifest)) | |
1935 | ||
a654dc4b LC |
1936 | (mlet* %store-monad ((system (if system |
1937 | (return system) | |
1938 | (current-system))) | |
91be09de MO |
1939 | (target (if target |
1940 | (return target) | |
1941 | (current-target-system))) | |
5a573139 LC |
1942 | (ok? -> (or allow-unsupported-packages? target |
1943 | (check-supported-packages system))) | |
afd06f60 LC |
1944 | (ok? (if allow-collisions? |
1945 | (return #t) | |
1946 | (check-for-collisions manifest system | |
1947 | #:target target))) | |
a654dc4b LC |
1948 | (extras (if (null? (manifest-entries manifest)) |
1949 | (return '()) | |
25af35fa LC |
1950 | (mapm/accumulate-builds (lambda (hook) |
1951 | (hook manifest)) | |
1952 | hooks)))) | |
8cef92d0 LC |
1953 | (define extra-inputs |
1954 | (filter-map (lambda (drv) | |
1955 | (and (derivation? drv) (gexp-input drv))) | |
1956 | extras)) | |
79ee406d | 1957 | |
1af0860e LC |
1958 | (define glibc-utf8-locales ;lazy reference |
1959 | (module-ref (resolve-interface '(gnu packages base)) | |
1960 | 'glibc-utf8-locales)) | |
1961 | ||
a6562c7e LC |
1962 | (define set-utf8-locale |
1963 | ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so | |
1964 | ;; install a UTF-8 locale. | |
1965 | #~(begin | |
1966 | (setenv "LOCPATH" | |
1967 | #$(file-append glibc-utf8-locales "/lib/locale/" | |
c6bc8e22 MB |
1968 | (version-major+minor |
1969 | (package-version glibc-utf8-locales)))) | |
a6562c7e LC |
1970 | (setlocale LC_ALL "en_US.utf8"))) |
1971 | ||
79ee406d | 1972 | (define builder |
99b231de LC |
1973 | (with-imported-modules '((guix build profiles) |
1974 | (guix build union) | |
1975 | (guix build utils) | |
1976 | (guix search-paths) | |
1977 | (guix records)) | |
1978 | #~(begin | |
1979 | (use-modules (guix build profiles) | |
1980 | (guix search-paths) | |
1981 | (srfi srfi-1)) | |
1982 | ||
39569dbb LC |
1983 | (let ((line (cond-expand (guile-2.2 'line) |
1984 | (else _IOLBF)))) ;Guile 2.0 | |
1985 | (setvbuf (current-output-port) line) | |
1986 | (setvbuf (current-error-port) line)) | |
99b231de | 1987 | |
a6562c7e | 1988 | #+(if locales? set-utf8-locale #t) |
1af0860e | 1989 | |
89e22887 | 1990 | (build-profile #$output '#$(manifest->gexp manifest format-version) |
8cef92d0 | 1991 | #:extra-inputs '#$extra-inputs |
e00ade3f LC |
1992 | #:symlink #$(if relative-symlinks? |
1993 | #~symlink-relative | |
8cef92d0 | 1994 | #~symlink))))) |
79ee406d | 1995 | |
416f7f4f | 1996 | (gexp->derivation name builder |
40d71e44 | 1997 | #:system system |
176febe3 | 1998 | #:target target |
a7a4fd9a | 1999 | |
cbb76780 LC |
2000 | ;; Don't complain about _IO* on Guile 2.2. |
2001 | #:env-vars '(("GUILE_WARN_DEPRECATED" . "no")) | |
2002 | ||
a7a4fd9a LC |
2003 | ;; Not worth offloading. |
2004 | #:local-build? #t | |
2005 | ||
2006 | ;; Disable substitution because it would trigger a | |
2007 | ;; connection to the substitute server, which is likely | |
2008 | ;; to have no substitute to offer. | |
e7570ec2 LC |
2009 | #:substitutable? #f |
2010 | ||
2011 | #:properties `((type . profile) | |
2012 | (profile | |
2013 | (count | |
2014 | . ,(length | |
2015 | (manifest-entries manifest)))))))) | |
cc4ecc2d | 2016 | |
ef674a24 LC |
2017 | ;; Declarative profile. |
2018 | (define-record-type* <profile> profile make-profile | |
2019 | profile? | |
2020 | (name profile-name (default "profile")) ;string | |
2021 | (content profile-content) ;<manifest> | |
2022 | (hooks profile-hooks ;list of procedures | |
2023 | (default %default-profile-hooks)) | |
2024 | (locales? profile-locales? ;Boolean | |
2025 | (default #t)) | |
2026 | (allow-collisions? profile-allow-collisions? ;Boolean | |
2027 | (default #f)) | |
2028 | (relative-symlinks? profile-relative-symlinks? ;Boolean | |
89e22887 LC |
2029 | (default #f)) |
2030 | (format-version profile-format-version ;integer | |
2031 | (default %manifest-format-version))) | |
ef674a24 LC |
2032 | |
2033 | (define-gexp-compiler (profile-compiler (profile <profile>) system target) | |
2034 | "Compile PROFILE to a derivation." | |
2035 | (match profile | |
2036 | (($ <profile> name manifest hooks | |
89e22887 LC |
2037 | locales? allow-collisions? relative-symlinks? |
2038 | format-version) | |
ef674a24 LC |
2039 | (profile-derivation manifest |
2040 | #:name name | |
2041 | #:hooks hooks | |
2042 | #:locales? locales? | |
2043 | #:allow-collisions? allow-collisions? | |
2044 | #:relative-symlinks? relative-symlinks? | |
89e22887 | 2045 | #:format-version format-version |
ef674a24 LC |
2046 | #:system system #:target target)))) |
2047 | ||
78d55b70 LC |
2048 | (define* (profile-search-paths profile |
2049 | #:optional (manifest (profile-manifest profile)) | |
2050 | #:key (getenv (const #f))) | |
2051 | "Read the manifest of PROFILE and evaluate the values of search path | |
2052 | environment variables required by PROFILE; return a list of | |
2053 | specification/value pairs. If MANIFEST is not #f, it is assumed to be the | |
2054 | manifest of PROFILE, which avoids rereading it. | |
2055 | ||
2056 | Use GETENV to determine the current settings and report only settings not | |
2057 | already effective." | |
2058 | (evaluate-search-paths (manifest-search-paths manifest) | |
2059 | (list profile) getenv)) | |
2060 | ||
ee61777a LC |
2061 | (define %precious-variables |
2062 | ;; Environment variables in the default 'load-profile' white list. | |
01f57955 | 2063 | '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER")) |
ee61777a LC |
2064 | |
2065 | (define (purify-environment white-list white-list-regexps) | |
2066 | "Unset all environment variables except those that match the regexps in | |
2067 | WHITE-LIST-REGEXPS and those listed in WHITE-LIST." | |
2068 | (for-each unsetenv | |
2069 | (remove (lambda (variable) | |
2070 | (or (member variable white-list) | |
2071 | (find (cut regexp-exec <> variable) | |
2072 | white-list-regexps))) | |
2073 | (match (get-environment-variables) | |
2074 | (((names . _) ...) | |
2075 | names))))) | |
2076 | ||
2077 | (define* (load-profile profile | |
2078 | #:optional (manifest (profile-manifest profile)) | |
2079 | #:key pure? (white-list-regexps '()) | |
2080 | (white-list %precious-variables)) | |
2081 | "Set the environment variables specified by MANIFEST for PROFILE. When | |
2082 | PURE? is #t, unset the variables in the current environment except those that | |
2083 | match the regexps in WHITE-LIST-REGEXPS and those listed in WHITE-LIST. | |
2084 | Otherwise, augment existing environment variables with additional search | |
2085 | paths." | |
2086 | (when pure? | |
2087 | (purify-environment white-list white-list-regexps)) | |
2088 | (for-each (match-lambda | |
2089 | ((($ <search-path-specification> variable _ separator) . value) | |
2090 | (let ((current (getenv variable))) | |
2091 | (setenv variable | |
2092 | (if (and current (not pure?)) | |
2093 | (if separator | |
2094 | (string-append value separator current) | |
2095 | value) | |
2096 | value))))) | |
2097 | (profile-search-paths profile manifest))) | |
2098 | ||
cc4ecc2d LC |
2099 | (define (profile-regexp profile) |
2100 | "Return a regular expression that matches PROFILE's name and number." | |
2101 | (make-regexp (string-append "^" (regexp-quote (basename profile)) | |
2102 | "-([0-9]+)"))) | |
2103 | ||
9679123c LC |
2104 | (define* (generation-number profile |
2105 | #:optional (base-profile profile)) | |
2106 | "Return PROFILE's number or 0. An absolute file name must be used. | |
2107 | ||
2108 | Optionally, if BASE-PROFILE is provided, use it instead of PROFILE to | |
2109 | construct the regexp matching generations. This is useful in special cases | |
2110 | like: (generation-number \"/run/current-system\" %system-profile)." | |
2111 | (or (and=> (false-if-exception (regexp-exec (profile-regexp base-profile) | |
cc4ecc2d LC |
2112 | (basename (readlink profile)))) |
2113 | (compose string->number (cut match:substring <> 1))) | |
2114 | 0)) | |
2115 | ||
c872b952 LC |
2116 | (define %profile-generation-rx |
2117 | ;; Regexp that matches profile generation. | |
2118 | (make-regexp "(.*)-([0-9]+)-link$")) | |
2119 | ||
2120 | (define (generation-profile file) | |
2121 | "If FILE is a profile generation GC root such as \"guix-profile-42-link\", | |
2122 | return its corresponding profile---e.g., \"guix-profile\". Otherwise return | |
2123 | #f." | |
2124 | (match (regexp-exec %profile-generation-rx file) | |
2125 | (#f #f) | |
2126 | (m (let ((profile (match:substring m 1))) | |
2127 | (and (file-exists? (string-append profile "/manifest")) | |
2128 | profile))))) | |
2129 | ||
cc4ecc2d LC |
2130 | (define (generation-numbers profile) |
2131 | "Return the sorted list of generation numbers of PROFILE, or '(0) if no | |
2132 | former profiles were found." | |
cc4ecc2d LC |
2133 | (match (scandir (dirname profile) |
2134 | (cute regexp-exec (profile-regexp profile) <>)) | |
2135 | (#f ; no profile directory | |
2136 | '(0)) | |
2137 | (() ; no profiles | |
2138 | '(0)) | |
2139 | ((profiles ...) ; former profiles around | |
2140 | (sort (map (compose string->number | |
2141 | (cut match:substring <> 1) | |
2142 | (cute regexp-exec (profile-regexp profile) <>)) | |
2143 | profiles) | |
2144 | <)))) | |
2145 | ||
f452e8ff AK |
2146 | (define (profile-generations profile) |
2147 | "Return a list of PROFILE's generations." | |
2148 | (let ((generations (generation-numbers profile))) | |
2149 | (if (equal? generations '(0)) | |
2150 | '() | |
2151 | generations))) | |
2152 | ||
9008debc CM |
2153 | (define (relative-generation-spec->number profile spec) |
2154 | "Return PROFILE's generation specified by SPEC, which is a string. The SPEC | |
2155 | may be a N, -N, or +N, where N is a number. If the spec is N, then the number | |
2156 | returned is N. If it is -N, then the number returned is the profile's current | |
2157 | generation number minus N. If it is +N, then the number returned is the | |
2158 | profile's current generation number plus N. Return #f if there is no such | |
2159 | generation." | |
2160 | (let ((number (string->number spec))) | |
2161 | (and number | |
2162 | (case (string-ref spec 0) | |
2163 | ((#\+ #\-) | |
2164 | (relative-generation profile number)) | |
2165 | (else (if (memv number (profile-generations profile)) | |
2166 | number | |
2167 | #f)))))) | |
2168 | ||
2169 | ||
3ccde087 AK |
2170 | (define* (relative-generation profile shift #:optional |
2171 | (current (generation-number profile))) | |
2172 | "Return PROFILE's generation shifted from the CURRENT generation by SHIFT. | |
2173 | SHIFT is a positive or negative number. | |
2174 | Return #f if there is no such generation." | |
2175 | (let* ((abs-shift (abs shift)) | |
2176 | (numbers (profile-generations profile)) | |
2177 | (from-current (memq current | |
2178 | (if (negative? shift) | |
2179 | (reverse numbers) | |
2180 | numbers)))) | |
2181 | (and from-current | |
2182 | (< abs-shift (length from-current)) | |
2183 | (list-ref from-current abs-shift)))) | |
2184 | ||
2185 | (define* (previous-generation-number profile #:optional | |
2186 | (number (generation-number profile))) | |
cc4ecc2d LC |
2187 | "Return the number of the generation before generation NUMBER of |
2188 | PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the | |
2189 | case when generations have been deleted (there are \"holes\")." | |
3ccde087 AK |
2190 | (or (relative-generation profile -1 number) |
2191 | 0)) | |
cc4ecc2d LC |
2192 | |
2193 | (define (generation-file-name profile generation) | |
2194 | "Return the file name for PROFILE's GENERATION." | |
2195 | (format #f "~a-~a-link" profile generation)) | |
2196 | ||
2197 | (define (generation-time profile number) | |
2198 | "Return the creation time of a generation in the UTC format." | |
2199 | (make-time time-utc 0 | |
2200 | (stat:ctime (stat (generation-file-name profile number))))) | |
2201 | ||
06d45f45 LC |
2202 | (define (link-to-empty-profile store generation) |
2203 | "Link GENERATION, a string, to the empty profile. An error is raised if | |
2204 | that fails." | |
2205 | (let* ((drv (run-with-store store | |
a6562c7e LC |
2206 | (profile-derivation (manifest '()) |
2207 | #:locales? #f))) | |
06d45f45 LC |
2208 | (prof (derivation->output-path drv "out"))) |
2209 | (build-derivations store (list drv)) | |
2210 | (switch-symlinks generation prof))) | |
2211 | ||
2212 | (define (switch-to-generation profile number) | |
2213 | "Atomically switch PROFILE to the generation NUMBER. Return the number of | |
2214 | the generation that was current before switching." | |
2215 | (let ((current (generation-number profile)) | |
2216 | (generation (generation-file-name profile number))) | |
2217 | (cond ((not (file-exists? profile)) | |
2218 | (raise (condition (&profile-not-found-error | |
2219 | (profile profile))))) | |
2220 | ((not (file-exists? generation)) | |
2221 | (raise (condition (&missing-generation-error | |
2222 | (profile profile) | |
2223 | (generation number))))) | |
2224 | (else | |
bc6e291e | 2225 | (switch-symlinks profile (basename generation)) |
06d45f45 LC |
2226 | current)))) |
2227 | ||
2228 | (define (switch-to-previous-generation profile) | |
2229 | "Atomically switch PROFILE to the previous generation. Return the former | |
2230 | generation number and the current one." | |
2231 | (let ((previous (previous-generation-number profile))) | |
2232 | (values (switch-to-generation profile previous) | |
2233 | previous))) | |
2234 | ||
2235 | (define (roll-back store profile) | |
2236 | "Roll back to the previous generation of PROFILE. Return the number of the | |
2237 | generation that was current before switching and the new generation number." | |
2238 | (let* ((number (generation-number profile)) | |
2239 | (previous-number (previous-generation-number profile number)) | |
2240 | (previous-generation (generation-file-name profile previous-number))) | |
2241 | (cond ((not (file-exists? profile)) ;invalid profile | |
2242 | (raise (condition (&profile-not-found-error | |
2243 | (profile profile))))) | |
2244 | ((zero? number) ;empty profile | |
2245 | (values number number)) | |
2246 | ((or (zero? previous-number) ;going to emptiness | |
2247 | (not (file-exists? previous-generation))) | |
2248 | (link-to-empty-profile store previous-generation) | |
2249 | (switch-to-previous-generation profile)) | |
2250 | (else ;anything else | |
2251 | (switch-to-previous-generation profile))))) | |
2252 | ||
2253 | (define (delete-generation store profile number) | |
2254 | "Delete generation with NUMBER from PROFILE. Return the file name of the | |
2255 | generation that has been deleted, or #f if nothing was done (for instance | |
2256 | because the NUMBER is zero.)" | |
2257 | (define (delete-and-return) | |
2258 | (let ((generation (generation-file-name profile number))) | |
2259 | (delete-file generation) | |
2260 | generation)) | |
2261 | ||
2262 | (let* ((current-number (generation-number profile)) | |
2263 | (previous-number (previous-generation-number profile number)) | |
2264 | (previous-generation (generation-file-name profile previous-number))) | |
2265 | (cond ((zero? number) #f) ;do not delete generation 0 | |
2266 | ((and (= number current-number) | |
2267 | (not (file-exists? previous-generation))) | |
2268 | (link-to-empty-profile store previous-generation) | |
2269 | (switch-to-previous-generation profile) | |
2270 | (delete-and-return)) | |
2271 | ((= number current-number) | |
2272 | (roll-back store profile) | |
2273 | (delete-and-return)) | |
2274 | (else | |
2275 | (delete-and-return))))) | |
2276 | ||
efcb4441 LC |
2277 | (define %user-profile-directory |
2278 | (and=> (getenv "HOME") | |
2279 | (cut string-append <> "/.guix-profile"))) | |
2280 | ||
2281 | (define %profile-directory | |
2282 | (string-append %state-directory "/profiles/" | |
2283 | (or (and=> (or (getenv "USER") | |
c20ba183 LC |
2284 | (getenv "LOGNAME") |
2285 | (false-if-exception | |
2286 | (passwd:name (getpwuid (getuid))))) | |
efcb4441 LC |
2287 | (cut string-append "per-user/" <>)) |
2288 | "default"))) | |
2289 | ||
2290 | (define %current-profile | |
2291 | ;; Call it `guix-profile', not `profile', to allow Guix profiles to | |
2292 | ;; coexist with Nix profiles. | |
2293 | (string-append %profile-directory "/guix-profile")) | |
2294 | ||
77dcfb4c | 2295 | (define (ensure-profile-directory) |
81c580c8 LC |
2296 | "Attempt to create /…/profiles/per-user/$USER if needed. Nowadays this is |
2297 | taken care of by the daemon." | |
77dcfb4c LC |
2298 | (let ((s (stat %profile-directory #f))) |
2299 | (unless (and s (eq? 'directory (stat:type s))) | |
2300 | (catch 'system-error | |
2301 | (lambda () | |
2302 | (mkdir-p %profile-directory)) | |
2303 | (lambda args | |
2304 | ;; Often, we cannot create %PROFILE-DIRECTORY because its | |
2305 | ;; parent directory is root-owned and we're running | |
2306 | ;; unprivileged. | |
2307 | (raise (condition | |
2308 | (&message | |
2309 | (message | |
2310 | (format #f | |
2311 | (G_ "while creating directory `~a': ~a") | |
2312 | %profile-directory | |
2313 | (strerror (system-error-errno args))))) | |
2314 | (&fix-hint | |
2315 | (hint | |
2316 | (format #f (G_ "Please create the @file{~a} directory, \ | |
2317 | with you as the owner.") | |
2318 | %profile-directory)))))))) | |
2319 | ||
2320 | ;; Bail out if it's not owned by the user. | |
2321 | (unless (or (not s) (= (stat:uid s) (getuid))) | |
2322 | (raise (condition | |
2323 | (&message | |
2324 | (message | |
2325 | (format #f (G_ "directory `~a' is not owned by you") | |
2326 | %profile-directory))) | |
2327 | (&fix-hint | |
2328 | (hint | |
2329 | (format #f (G_ "Please change the owner of @file{~a} \ | |
2330 | to user ~s.") | |
2331 | %profile-directory (or (getenv "USER") | |
2332 | (getenv "LOGNAME") | |
2333 | (getuid)))))))))) | |
2334 | ||
efcb4441 | 2335 | (define (canonicalize-profile profile) |
50c72ecd LC |
2336 | "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that. |
2337 | Otherwise return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' | |
2338 | as if '-p' was omitted." ; see <http://bugs.gnu.org/17939> | |
2339 | ;; Trim trailing slashes so 'readlink' can do its job. | |
efcb4441 | 2340 | (let ((profile (string-trim-right profile #\/))) |
50c72ecd LC |
2341 | (catch 'system-error |
2342 | (lambda () | |
2343 | (let ((target (readlink profile))) | |
2344 | (if (string=? (dirname target) %profile-directory) | |
2345 | target | |
2346 | profile))) | |
2347 | (const profile)))) | |
efcb4441 | 2348 | |
1c795c4f LC |
2349 | (define %known-shorthand-profiles |
2350 | ;; Known shorthand forms for profiles that the user manipulates. | |
2351 | (list (string-append (config-directory #:ensure? #f) "/current") | |
2352 | %user-profile-directory)) | |
2353 | ||
efcb4441 | 2354 | (define (user-friendly-profile profile) |
1c795c4f LC |
2355 | "Return either ~/.guix-profile or ~/.config/guix/current if that's what |
2356 | PROFILE refers to, directly or indirectly, or PROFILE." | |
2357 | (or (find (lambda (shorthand) | |
2358 | (and shorthand | |
2359 | (let ((target (false-if-exception | |
2360 | (readlink shorthand)))) | |
2361 | (and target (string=? target profile))))) | |
2362 | %known-shorthand-profiles) | |
efcb4441 LC |
2363 | profile)) |
2364 | ||
4ff12d1d LC |
2365 | ;;; Local Variables: |
2366 | ;;; eval: (put 'let-fields 'scheme-indent-function 2) | |
2367 | ;;; End: | |
2368 | ||
cc4ecc2d | 2369 | ;;; profiles.scm ends here |