Commit | Line | Data |
---|---|---|
cc4ecc2d | 1 | ;;; GNU Guix --- Functional package management for GNU |
e5f04c2d | 2 | ;;; Copyright © 2013, 2014, 2015, 2016 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> |
cc4ecc2d LC |
7 | ;;; |
8 | ;;; This file is part of GNU Guix. | |
9 | ;;; | |
10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
11 | ;;; under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
15 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | (define-module (guix profiles) | |
97425486 LC |
24 | #:use-module ((guix utils) #:hide (package-name->name+version)) |
25 | #:use-module ((guix build utils) | |
26 | #:select (package-name->name+version)) | |
cc4ecc2d | 27 | #:use-module (guix records) |
cc4ecc2d | 28 | #:use-module (guix packages) |
e89431bf LC |
29 | #:use-module (guix derivations) |
30 | #:use-module (guix search-paths) | |
a54c94a4 | 31 | #:use-module (guix gexp) |
79ee406d | 32 | #:use-module (guix monads) |
e87f0591 | 33 | #:use-module (guix store) |
cc4ecc2d LC |
34 | #:use-module (ice-9 match) |
35 | #:use-module (ice-9 regex) | |
36 | #:use-module (ice-9 ftw) | |
343745c8 | 37 | #:use-module (ice-9 format) |
cc4ecc2d LC |
38 | #:use-module (srfi srfi-1) |
39 | #:use-module (srfi srfi-9) | |
79601521 | 40 | #:use-module (srfi srfi-11) |
cc4ecc2d LC |
41 | #:use-module (srfi srfi-19) |
42 | #:use-module (srfi srfi-26) | |
c0c018f1 AK |
43 | #:use-module (srfi srfi-34) |
44 | #:use-module (srfi srfi-35) | |
45 | #:export (&profile-error | |
46 | profile-error? | |
47 | profile-error-profile | |
48 | &profile-not-found-error | |
49 | profile-not-found-error? | |
50 | &missing-generation-error | |
51 | missing-generation-error? | |
52 | missing-generation-error-generation | |
53 | ||
54 | manifest make-manifest | |
cc4ecc2d LC |
55 | manifest? |
56 | manifest-entries | |
57 | ||
58 | <manifest-entry> ; FIXME: eventually make it internal | |
59 | manifest-entry | |
60 | manifest-entry? | |
61 | manifest-entry-name | |
62 | manifest-entry-version | |
63 | manifest-entry-output | |
a54c94a4 | 64 | manifest-entry-item |
cc4ecc2d | 65 | manifest-entry-dependencies |
dedb17ad | 66 | manifest-entry-search-paths |
cc4ecc2d | 67 | |
a2078770 LC |
68 | manifest-pattern |
69 | manifest-pattern? | |
03763d64 LC |
70 | manifest-pattern-name |
71 | manifest-pattern-version | |
72 | manifest-pattern-output | |
a2078770 | 73 | |
cc4ecc2d | 74 | manifest-remove |
f7554030 | 75 | manifest-add |
ef8993e2 | 76 | manifest-lookup |
cc4ecc2d | 77 | manifest-installed? |
a2078770 | 78 | manifest-matching-entries |
cc4ecc2d | 79 | |
343745c8 AK |
80 | manifest-transaction |
81 | manifest-transaction? | |
82 | manifest-transaction-install | |
83 | manifest-transaction-remove | |
c8c25704 LC |
84 | manifest-transaction-install-entry |
85 | manifest-transaction-remove-pattern | |
86 | manifest-transaction-null? | |
343745c8 | 87 | manifest-perform-transaction |
79601521 | 88 | manifest-transaction-effects |
343745c8 | 89 | |
cc4ecc2d | 90 | profile-manifest |
462f5cca | 91 | package->manifest-entry |
8404ed5c | 92 | packages->manifest |
aa46a028 | 93 | %default-profile-hooks |
cc4ecc2d | 94 | profile-derivation |
06d45f45 | 95 | |
cc4ecc2d LC |
96 | generation-number |
97 | generation-numbers | |
f452e8ff | 98 | profile-generations |
3ccde087 | 99 | relative-generation |
cc4ecc2d LC |
100 | previous-generation-number |
101 | generation-time | |
06d45f45 LC |
102 | generation-file-name |
103 | switch-to-generation | |
104 | roll-back | |
105 | delete-generation)) | |
cc4ecc2d LC |
106 | |
107 | ;;; Commentary: | |
108 | ;;; | |
109 | ;;; Tools to create and manipulate profiles---i.e., the representation of a | |
110 | ;;; set of installed packages. | |
111 | ;;; | |
112 | ;;; Code: | |
113 | ||
114 | \f | |
c0c018f1 AK |
115 | ;;; |
116 | ;;; Condition types. | |
117 | ;;; | |
118 | ||
119 | (define-condition-type &profile-error &error | |
120 | profile-error? | |
121 | (profile profile-error-profile)) | |
122 | ||
123 | (define-condition-type &profile-not-found-error &profile-error | |
124 | profile-not-found-error?) | |
125 | ||
126 | (define-condition-type &missing-generation-error &profile-error | |
127 | missing-generation-error? | |
128 | (generation missing-generation-error-generation)) | |
129 | ||
130 | \f | |
cc4ecc2d LC |
131 | ;;; |
132 | ;;; Manifests. | |
133 | ;;; | |
134 | ||
135 | (define-record-type <manifest> | |
136 | (manifest entries) | |
137 | manifest? | |
138 | (entries manifest-entries)) ; list of <manifest-entry> | |
139 | ||
140 | ;; Convenient alias, to avoid name clashes. | |
141 | (define make-manifest manifest) | |
142 | ||
143 | (define-record-type* <manifest-entry> manifest-entry | |
144 | make-manifest-entry | |
145 | manifest-entry? | |
146 | (name manifest-entry-name) ; string | |
147 | (version manifest-entry-version) ; string | |
148 | (output manifest-entry-output ; string | |
149 | (default "out")) | |
a54c94a4 | 150 | (item manifest-entry-item) ; package | store path |
4ca0b410 | 151 | (dependencies manifest-entry-dependencies ; (store path | package)* |
dedb17ad LC |
152 | (default '())) |
153 | (search-paths manifest-entry-search-paths ; search-path-specification* | |
4ca0b410 | 154 | (default '()))) |
cc4ecc2d | 155 | |
a2078770 LC |
156 | (define-record-type* <manifest-pattern> manifest-pattern |
157 | make-manifest-pattern | |
158 | manifest-pattern? | |
159 | (name manifest-pattern-name) ; string | |
160 | (version manifest-pattern-version ; string | #f | |
161 | (default #f)) | |
162 | (output manifest-pattern-output ; string | #f | |
163 | (default "out"))) | |
164 | ||
cc4ecc2d LC |
165 | (define (profile-manifest profile) |
166 | "Return the PROFILE's manifest." | |
167 | (let ((file (string-append profile "/manifest"))) | |
168 | (if (file-exists? file) | |
169 | (call-with-input-file file read-manifest) | |
170 | (manifest '())))) | |
171 | ||
9e90fc77 LC |
172 | (define* (package->manifest-entry package #:optional (output "out")) |
173 | "Return a manifest entry for the OUTPUT of package PACKAGE." | |
462f5cca LC |
174 | (let ((deps (map (match-lambda |
175 | ((label package) | |
b4a4bec0 | 176 | (gexp-input package)) |
462f5cca | 177 | ((label package output) |
b4a4bec0 | 178 | (gexp-input package output))) |
462f5cca LC |
179 | (package-transitive-propagated-inputs package)))) |
180 | (manifest-entry | |
181 | (name (package-name package)) | |
182 | (version (package-version package)) | |
9e90fc77 | 183 | (output output) |
462f5cca | 184 | (item package) |
dedb17ad | 185 | (dependencies (delete-duplicates deps)) |
ccda8f7d | 186 | (search-paths (package-transitive-native-search-paths package))))) |
462f5cca | 187 | |
8404ed5c DT |
188 | (define (packages->manifest packages) |
189 | "Return a list of manifest entries, one for each item listed in PACKAGES. | |
190 | Elements of PACKAGES can be either package objects or package/string tuples | |
191 | denoting a specific output of a package." | |
192 | (manifest | |
193 | (map (match-lambda | |
194 | ((package output) | |
195 | (package->manifest-entry package output)) | |
9e90fc77 LC |
196 | ((? package? package) |
197 | (package->manifest-entry package))) | |
8404ed5c DT |
198 | packages))) |
199 | ||
a54c94a4 LC |
200 | (define (manifest->gexp manifest) |
201 | "Return a representation of MANIFEST as a gexp." | |
202 | (define (entry->gexp entry) | |
cc4ecc2d | 203 | (match entry |
dedb17ad LC |
204 | (($ <manifest-entry> name version output (? string? path) |
205 | (deps ...) (search-paths ...)) | |
206 | #~(#$name #$version #$output #$path | |
207 | (propagated-inputs #$deps) | |
208 | (search-paths #$(map search-path-specification->sexp | |
209 | search-paths)))) | |
210 | (($ <manifest-entry> name version output (? package? package) | |
211 | (deps ...) (search-paths ...)) | |
a54c94a4 | 212 | #~(#$name #$version #$output |
dedb17ad LC |
213 | (ungexp package (or output "out")) |
214 | (propagated-inputs #$deps) | |
215 | (search-paths #$(map search-path-specification->sexp | |
216 | search-paths)))))) | |
cc4ecc2d LC |
217 | |
218 | (match manifest | |
219 | (($ <manifest> (entries ...)) | |
dedb17ad | 220 | #~(manifest (version 2) |
a54c94a4 | 221 | (packages #$(map entry->gexp entries)))))) |
cc4ecc2d | 222 | |
dedb17ad LC |
223 | (define (find-package name version) |
224 | "Return a package from the distro matching NAME and possibly VERSION. This | |
225 | procedure is here for backward-compatibility and will eventually vanish." | |
226 | (define find-best-packages-by-name ;break abstractions | |
227 | (module-ref (resolve-interface '(gnu packages)) | |
228 | 'find-best-packages-by-name)) | |
229 | ||
230 | ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the | |
231 | ;; former traverses the module tree only once and then allows for efficient | |
232 | ;; access via a vhash. | |
233 | (match (find-best-packages-by-name name version) | |
234 | ((p _ ...) p) | |
235 | (_ | |
236 | (match (find-best-packages-by-name name #f) | |
237 | ((p _ ...) p) | |
238 | (_ #f))))) | |
239 | ||
cc4ecc2d LC |
240 | (define (sexp->manifest sexp) |
241 | "Parse SEXP as a manifest." | |
dedb17ad LC |
242 | (define (infer-search-paths name version) |
243 | ;; Infer the search path specifications for NAME-VERSION by looking up a | |
244 | ;; same-named package in the distro. Useful for the old manifest formats | |
245 | ;; that did not store search path info. | |
246 | (let ((package (find-package name version))) | |
247 | (if package | |
248 | (package-native-search-paths package) | |
249 | '()))) | |
250 | ||
cc4ecc2d LC |
251 | (match sexp |
252 | (('manifest ('version 0) | |
253 | ('packages ((name version output path) ...))) | |
254 | (manifest | |
255 | (map (lambda (name version output path) | |
256 | (manifest-entry | |
257 | (name name) | |
258 | (version version) | |
259 | (output output) | |
dedb17ad LC |
260 | (item path) |
261 | (search-paths (infer-search-paths name version)))) | |
cc4ecc2d LC |
262 | name version output path))) |
263 | ||
264 | ;; Version 1 adds a list of propagated inputs to the | |
265 | ;; name/version/output/path tuples. | |
266 | (('manifest ('version 1) | |
267 | ('packages ((name version output path deps) ...))) | |
268 | (manifest | |
269 | (map (lambda (name version output path deps) | |
d34736c5 LC |
270 | ;; Up to Guix 0.7 included, dependencies were listed as ("gmp" |
271 | ;; "/gnu/store/...-gmp") for instance. Discard the 'label' in | |
272 | ;; such lists. | |
273 | (let ((deps (match deps | |
274 | (((labels directories) ...) | |
275 | directories) | |
276 | ((directories ...) | |
277 | directories)))) | |
278 | (manifest-entry | |
279 | (name name) | |
280 | (version version) | |
281 | (output output) | |
282 | (item path) | |
dedb17ad LC |
283 | (dependencies deps) |
284 | (search-paths (infer-search-paths name version))))) | |
cc4ecc2d LC |
285 | name version output path deps))) |
286 | ||
dedb17ad LC |
287 | ;; Version 2 adds search paths and is slightly more verbose. |
288 | (('manifest ('version 2 minor-version ...) | |
289 | ('packages ((name version output path | |
290 | ('propagated-inputs deps) | |
291 | ('search-paths search-paths) | |
292 | extra-stuff ...) | |
293 | ...))) | |
294 | (manifest | |
295 | (map (lambda (name version output path deps search-paths) | |
296 | (manifest-entry | |
297 | (name name) | |
298 | (version version) | |
299 | (output output) | |
300 | (item path) | |
301 | (dependencies deps) | |
302 | (search-paths (map sexp->search-path-specification | |
303 | search-paths)))) | |
304 | name version output path deps search-paths))) | |
cc4ecc2d | 305 | (_ |
88aab8e3 LC |
306 | (raise (condition |
307 | (&message (message "unsupported manifest format"))))))) | |
cc4ecc2d LC |
308 | |
309 | (define (read-manifest port) | |
310 | "Return the packages listed in MANIFEST." | |
311 | (sexp->manifest (read port))) | |
312 | ||
a2078770 LC |
313 | (define (entry-predicate pattern) |
314 | "Return a procedure that returns #t when passed a manifest entry that | |
315 | matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they | |
316 | are ignored." | |
317 | (match pattern | |
318 | (($ <manifest-pattern> name version output) | |
319 | (match-lambda | |
320 | (($ <manifest-entry> entry-name entry-version entry-output) | |
321 | (and (string=? entry-name name) | |
322 | (or (not entry-output) (not output) | |
323 | (string=? entry-output output)) | |
324 | (or (not version) | |
325 | (string=? entry-version version)))))))) | |
326 | ||
327 | (define (manifest-remove manifest patterns) | |
328 | "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS | |
329 | must be a manifest-pattern." | |
330 | (define (remove-entry pattern lst) | |
331 | (remove (entry-predicate pattern) lst)) | |
332 | ||
333 | (make-manifest (fold remove-entry | |
cc4ecc2d | 334 | (manifest-entries manifest) |
a2078770 | 335 | patterns))) |
cc4ecc2d | 336 | |
f7554030 AK |
337 | (define (manifest-add manifest entries) |
338 | "Add a list of manifest ENTRIES to MANIFEST and return new manifest. | |
339 | Remove MANIFEST entries that have the same name and output as ENTRIES." | |
340 | (define (same-entry? entry name output) | |
341 | (match entry | |
342 | (($ <manifest-entry> entry-name _ entry-output _ ...) | |
343 | (and (equal? name entry-name) | |
344 | (equal? output entry-output))))) | |
345 | ||
346 | (make-manifest | |
347 | (append entries | |
348 | (fold (lambda (entry result) | |
349 | (match entry | |
350 | (($ <manifest-entry> name _ out _ ...) | |
351 | (filter (negate (cut same-entry? <> name out)) | |
352 | result)))) | |
353 | (manifest-entries manifest) | |
354 | entries)))) | |
355 | ||
ef8993e2 LC |
356 | (define (manifest-lookup manifest pattern) |
357 | "Return the first item of MANIFEST that matches PATTERN, or #f if there is | |
358 | no match.." | |
359 | (find (entry-predicate pattern) | |
360 | (manifest-entries manifest))) | |
361 | ||
a2078770 LC |
362 | (define (manifest-installed? manifest pattern) |
363 | "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), | |
364 | #f otherwise." | |
ef8993e2 | 365 | (->bool (manifest-lookup manifest pattern))) |
cc4ecc2d | 366 | |
a2078770 LC |
367 | (define (manifest-matching-entries manifest patterns) |
368 | "Return all the entries of MANIFEST that match one of the PATTERNS." | |
369 | (define predicates | |
370 | (map entry-predicate patterns)) | |
371 | ||
372 | (define (matches? entry) | |
373 | (any (lambda (pred) | |
374 | (pred entry)) | |
375 | predicates)) | |
376 | ||
377 | (filter matches? (manifest-entries manifest))) | |
378 | ||
cc4ecc2d | 379 | \f |
343745c8 AK |
380 | ;;; |
381 | ;;; Manifest transactions. | |
382 | ;;; | |
383 | ||
384 | (define-record-type* <manifest-transaction> manifest-transaction | |
385 | make-manifest-transaction | |
386 | manifest-transaction? | |
387 | (install manifest-transaction-install ; list of <manifest-entry> | |
388 | (default '())) | |
389 | (remove manifest-transaction-remove ; list of <manifest-pattern> | |
390 | (default '()))) | |
391 | ||
c8c25704 LC |
392 | (define (manifest-transaction-install-entry entry transaction) |
393 | "Augment TRANSACTION's set of installed packages with ENTRY, a | |
394 | <manifest-entry>." | |
395 | (manifest-transaction | |
396 | (inherit transaction) | |
397 | (install | |
398 | (cons entry (manifest-transaction-install transaction))))) | |
399 | ||
400 | (define (manifest-transaction-remove-pattern pattern transaction) | |
401 | "Add PATTERN to TRANSACTION's list of packages to remove." | |
402 | (manifest-transaction | |
403 | (inherit transaction) | |
404 | (remove | |
405 | (cons pattern (manifest-transaction-remove transaction))))) | |
406 | ||
407 | (define (manifest-transaction-null? transaction) | |
408 | "Return true if TRANSACTION has no effect---i.e., it neither installs nor | |
409 | remove software." | |
410 | (match transaction | |
411 | (($ <manifest-transaction> () ()) #t) | |
412 | (($ <manifest-transaction> _ _) #f))) | |
413 | ||
79601521 | 414 | (define (manifest-transaction-effects manifest transaction) |
46b23e1a LC |
415 | "Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values: |
416 | the list of packages that would be removed, installed, upgraded, or downgraded | |
417 | when applying TRANSACTION to MANIFEST. Upgrades are represented as pairs | |
418 | where the head is the entry being upgraded and the tail is the entry that will | |
419 | replace it." | |
79601521 LC |
420 | (define (manifest-entry->pattern entry) |
421 | (manifest-pattern | |
422 | (name (manifest-entry-name entry)) | |
423 | (output (manifest-entry-output entry)))) | |
424 | ||
46b23e1a LC |
425 | (let loop ((input (manifest-transaction-install transaction)) |
426 | (install '()) | |
427 | (upgrade '()) | |
428 | (downgrade '())) | |
79601521 LC |
429 | (match input |
430 | (() | |
431 | (let ((remove (manifest-transaction-remove transaction))) | |
432 | (values (manifest-matching-entries manifest remove) | |
46b23e1a | 433 | (reverse install) (reverse upgrade) (reverse downgrade)))) |
79601521 LC |
434 | ((entry rest ...) |
435 | ;; Check whether installing ENTRY corresponds to the installation of a | |
436 | ;; new package or to an upgrade. | |
437 | ||
438 | ;; XXX: When the exact same output directory is installed, we're not | |
439 | ;; really upgrading anything. Add a check for that case. | |
440 | (let* ((pattern (manifest-entry->pattern entry)) | |
46b23e1a LC |
441 | (previous (manifest-lookup manifest pattern)) |
442 | (newer? (and previous | |
3bea13bb LC |
443 | (version>=? (manifest-entry-version entry) |
444 | (manifest-entry-version previous))))) | |
79601521 | 445 | (loop rest |
ef8993e2 | 446 | (if previous install (cons entry install)) |
46b23e1a | 447 | (if (and previous newer?) |
ef8993e2 | 448 | (alist-cons previous entry upgrade) |
46b23e1a LC |
449 | upgrade) |
450 | (if (and previous (not newer?)) | |
451 | (alist-cons previous entry downgrade) | |
452 | downgrade))))))) | |
79601521 | 453 | |
343745c8 | 454 | (define (manifest-perform-transaction manifest transaction) |
c8c25704 | 455 | "Perform TRANSACTION on MANIFEST and return the new manifest." |
343745c8 AK |
456 | (let ((install (manifest-transaction-install transaction)) |
457 | (remove (manifest-transaction-remove transaction))) | |
458 | (manifest-add (manifest-remove manifest remove) | |
459 | install))) | |
460 | ||
343745c8 | 461 | \f |
cc4ecc2d LC |
462 | ;;; |
463 | ;;; Profiles. | |
464 | ;;; | |
465 | ||
79ee406d | 466 | (define (manifest-inputs manifest) |
b4a4bec0 | 467 | "Return a list of <gexp-input> objects for MANIFEST." |
79ee406d | 468 | (append-map (match-lambda |
b4a4bec0 LC |
469 | (($ <manifest-entry> name version output thing deps) |
470 | ;; THING may be a package or a file name. In the latter case, | |
471 | ;; assume it's already valid. Ditto for DEPS. | |
472 | (cons (gexp-input thing output) deps))) | |
79ee406d LC |
473 | (manifest-entries manifest))) |
474 | ||
2c9f4786 | 475 | (define* (manifest-lookup-package manifest name #:optional version) |
d72d7833 | 476 | "Return as a monadic value the first package or store path referenced by |
2c9f4786 RW |
477 | MANIFEST that is named NAME and optionally has the given VERSION prefix, or #f |
478 | if not found." | |
d72d7833 SB |
479 | ;; Return as a monadic value the package or store path referenced by the |
480 | ;; manifest ENTRY, or #f if not referenced. | |
481 | (define (entry-lookup-package entry) | |
482 | (define (find-among-inputs inputs) | |
483 | (find (lambda (input) | |
484 | (and (package? input) | |
2c9f4786 RW |
485 | (equal? name (package-name input)) |
486 | (if version | |
487 | (string-prefix? version (package-version input)) | |
488 | #t))) | |
d72d7833 SB |
489 | inputs)) |
490 | (define (find-among-store-items items) | |
491 | (find (lambda (item) | |
2c9f4786 RW |
492 | (let-values (((pkg-name pkg-version) |
493 | (package-name->name+version | |
494 | (store-path-package-name item)))) | |
495 | (and (equal? name pkg-name) | |
496 | (if version | |
497 | (string-prefix? version pkg-version) | |
498 | #t)))) | |
d72d7833 SB |
499 | items)) |
500 | ||
501 | ;; TODO: Factorize. | |
502 | (define references* | |
503 | (store-lift references)) | |
504 | ||
505 | (with-monad %store-monad | |
506 | (match (manifest-entry-item entry) | |
507 | ((? package? package) | |
963521a3 SB |
508 | (match (cons (list (package-name package) package) |
509 | (package-transitive-inputs package)) | |
d72d7833 SB |
510 | (((labels inputs . _) ...) |
511 | (return (find-among-inputs inputs))))) | |
512 | ((? string? item) | |
513 | (mlet %store-monad ((refs (references* item))) | |
514 | (return (find-among-store-items refs))))))) | |
515 | ||
516 | (anym %store-monad | |
517 | entry-lookup-package (manifest-entries manifest))) | |
518 | ||
79ee406d LC |
519 | (define (info-dir-file manifest) |
520 | "Return a derivation that builds the 'dir' file for all the entries of | |
521 | MANIFEST." | |
2f0556ae LC |
522 | (define texinfo ;lazy reference |
523 | (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo)) | |
524 | (define gzip ;lazy reference | |
525 | (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) | |
526 | ||
79ee406d | 527 | (define build |
99b231de LC |
528 | (with-imported-modules '((guix build utils)) |
529 | #~(begin | |
530 | (use-modules (guix build utils) | |
531 | (srfi srfi-1) (srfi srfi-26) | |
532 | (ice-9 ftw)) | |
533 | ||
534 | (define (info-file? file) | |
535 | (or (string-suffix? ".info" file) | |
536 | (string-suffix? ".info.gz" file))) | |
537 | ||
538 | (define (info-files top) | |
539 | (let ((infodir (string-append top "/share/info"))) | |
540 | (map (cut string-append infodir "/" <>) | |
541 | (or (scandir infodir info-file?) '())))) | |
542 | ||
543 | (define (install-info info) | |
544 | (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files | |
545 | (zero? | |
546 | (system* (string-append #+texinfo "/bin/install-info") "--silent" | |
547 | info (string-append #$output "/share/info/dir")))) | |
548 | ||
549 | (mkdir-p (string-append #$output "/share/info")) | |
550 | (exit (every install-info | |
551 | (append-map info-files | |
552 | '#$(manifest-inputs manifest))))))) | |
79ee406d | 553 | |
aa46a028 | 554 | (gexp->derivation "info-dir" build |
a7a4fd9a LC |
555 | #:local-build? #t |
556 | #:substitutable? #f)) | |
79ee406d | 557 | |
042bc828 FB |
558 | (define (ghc-package-cache-file manifest) |
559 | "Return a derivation that builds the GHC 'package.cache' file for all the | |
aa46a028 | 560 | entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." |
99b231de | 561 | (define ghc ;lazy reference |
042bc828 FB |
562 | (module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) |
563 | ||
564 | (define build | |
99b231de LC |
565 | (with-imported-modules '((guix build utils)) |
566 | #~(begin | |
567 | (use-modules (guix build utils) | |
568 | (srfi srfi-1) (srfi srfi-26) | |
569 | (ice-9 ftw)) | |
570 | ||
571 | (define ghc-name-version | |
572 | (let* ((base (basename #+ghc))) | |
573 | (string-drop base | |
574 | (+ 1 (string-index base #\-))))) | |
575 | ||
576 | (define db-subdir | |
577 | (string-append "lib/" ghc-name-version "/package.conf.d")) | |
578 | ||
579 | (define db-dir | |
580 | (string-append #$output "/" db-subdir)) | |
581 | ||
582 | (define (conf-files top) | |
583 | (let ((db (string-append top "/" db-subdir))) | |
584 | (if (file-exists? db) | |
585 | (find-files db "\\.conf$") | |
586 | '()))) | |
587 | ||
588 | (define (copy-conf-file conf) | |
589 | (let ((base (basename conf))) | |
590 | (copy-file conf (string-append db-dir "/" base)))) | |
591 | ||
592 | (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) | |
593 | (for-each copy-conf-file | |
594 | (append-map conf-files | |
595 | (delete-duplicates | |
596 | '#$(manifest-inputs manifest)))) | |
597 | (let ((success | |
598 | (zero? | |
599 | (system* (string-append #+ghc "/bin/ghc-pkg") "recache" | |
600 | (string-append "--package-db=" db-dir))))) | |
601 | (for-each delete-file (find-files db-dir "\\.conf$")) | |
602 | (exit success))))) | |
042bc828 | 603 | |
07eaecfa LC |
604 | (with-monad %store-monad |
605 | ;; Don't depend on GHC when there's nothing to do. | |
606 | (if (any (cut string-prefix? "ghc" <>) | |
607 | (map manifest-entry-name (manifest-entries manifest))) | |
608 | (gexp->derivation "ghc-package-cache" build | |
a7a4fd9a LC |
609 | #:local-build? #t |
610 | #:substitutable? #f) | |
07eaecfa | 611 | (return #f)))) |
042bc828 | 612 | |
536c3ee4 MW |
613 | (define (ca-certificate-bundle manifest) |
614 | "Return a derivation that builds a single-file bundle containing the CA | |
615 | certificates in the /etc/ssl/certs sub-directories of the packages in | |
616 | MANIFEST. Single-file bundles are required by programs such as Git and Lynx." | |
617 | ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html> | |
618 | ;; for a discussion. | |
619 | ||
620 | (define glibc-utf8-locales ;lazy reference | |
621 | (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) | |
622 | ||
623 | (define build | |
99b231de LC |
624 | (with-imported-modules '((guix build utils)) |
625 | #~(begin | |
626 | (use-modules (guix build utils) | |
627 | (rnrs io ports) | |
628 | (srfi srfi-1) | |
629 | (srfi srfi-26) | |
630 | (ice-9 ftw) | |
631 | (ice-9 match)) | |
632 | ||
633 | (define (pem-file? file) | |
634 | (string-suffix? ".pem" file)) | |
635 | ||
636 | (define (ca-files top) | |
637 | (let ((cert-dir (string-append top "/etc/ssl/certs"))) | |
638 | (map (cut string-append cert-dir "/" <>) | |
639 | (or (scandir cert-dir pem-file?) '())))) | |
640 | ||
641 | (define (concatenate-files files result) | |
642 | "Make RESULT the concatenation of all of FILES." | |
643 | (define (dump file port) | |
644 | (display (call-with-input-file file get-string-all) | |
645 | port) | |
646 | (newline port)) ;required, see <https://bugs.debian.org/635570> | |
647 | ||
648 | (call-with-output-file result | |
649 | (lambda (port) | |
650 | (for-each (cut dump <> port) files)))) | |
651 | ||
652 | ;; Some file names in the NSS certificates are UTF-8 encoded so | |
653 | ;; install a UTF-8 locale. | |
654 | (setenv "LOCPATH" | |
655 | (string-append #+glibc-utf8-locales "/lib/locale/" | |
656 | #+(package-version glibc-utf8-locales))) | |
657 | (setlocale LC_ALL "en_US.utf8") | |
658 | ||
659 | (match (append-map ca-files '#$(manifest-inputs manifest)) | |
660 | (() | |
661 | ;; Since there are no CA files, just create an empty directory. Do | |
662 | ;; not create the etc/ssl/certs sub-directory, since that would | |
663 | ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be | |
664 | ;; defined. | |
665 | (mkdir #$output) | |
666 | #t) | |
667 | ((ca-files ...) | |
668 | (let ((result (string-append #$output "/etc/ssl/certs"))) | |
669 | (mkdir-p result) | |
670 | (concatenate-files ca-files | |
671 | (string-append result | |
672 | "/ca-certificates.crt")) | |
673 | #t)))))) | |
536c3ee4 | 674 | |
aa46a028 | 675 | (gexp->derivation "ca-certificate-bundle" build |
a7a4fd9a LC |
676 | #:local-build? #t |
677 | #:substitutable? #f)) | |
aa46a028 | 678 | |
b04af0ec SB |
679 | (define (gtk-icon-themes manifest) |
680 | "Return a derivation that unions all icon themes from manifest entries and | |
681 | creates the GTK+ 'icon-theme.cache' file for each theme." | |
d72d7833 | 682 | (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+"))) |
b04af0ec | 683 | (define build |
99b231de LC |
684 | (with-imported-modules '((guix build utils) |
685 | (guix build union) | |
686 | (guix build profiles) | |
687 | (guix search-paths) | |
688 | (guix records)) | |
689 | #~(begin | |
690 | (use-modules (guix build utils) | |
691 | (guix build union) | |
692 | (guix build profiles) | |
693 | (srfi srfi-26) | |
694 | (ice-9 ftw)) | |
695 | ||
696 | (let* ((destdir (string-append #$output "/share/icons")) | |
697 | (icondirs (filter file-exists? | |
698 | (map (cut string-append <> "/share/icons") | |
699 | '#$(manifest-inputs manifest)))) | |
700 | (update-icon-cache (string-append | |
701 | #+gtk+ "/bin/gtk-update-icon-cache"))) | |
702 | ||
703 | ;; Union all the icons. | |
704 | (mkdir-p (string-append #$output "/share")) | |
705 | (union-build destdir icondirs | |
706 | #:log-port (%make-void-port "w")) | |
707 | ||
708 | ;; Update the 'icon-theme.cache' file for each icon theme. | |
709 | (for-each | |
710 | (lambda (theme) | |
711 | (let ((dir (string-append destdir "/" theme))) | |
712 | ;; Occasionally DESTDIR contains plain files, such as | |
713 | ;; "abiword_48.png". Ignore these. | |
714 | (when (file-is-directory? dir) | |
715 | (ensure-writable-directory dir) | |
716 | (system* update-icon-cache "-t" dir "--quiet")))) | |
717 | (scandir destdir (negate (cut member <> '("." ".."))))))))) | |
b04af0ec SB |
718 | |
719 | ;; Don't run the hook when there's nothing to do. | |
720 | (if gtk+ | |
721 | (gexp->derivation "gtk-icon-themes" build | |
a7a4fd9a LC |
722 | #:local-build? #t |
723 | #:substitutable? #f) | |
b04af0ec SB |
724 | (return #f)))) |
725 | ||
842cb820 SB |
726 | (define (xdg-desktop-database manifest) |
727 | "Return a derivation that builds the @file{mimeinfo.cache} database from | |
728 | desktop files. It's used to query what applications can handle a given | |
729 | MIME type." | |
d72d7833 SB |
730 | (mlet %store-monad ((desktop-file-utils |
731 | (manifest-lookup-package | |
732 | manifest "desktop-file-utils"))) | |
733 | (define build | |
99b231de LC |
734 | (with-imported-modules '((guix build utils) |
735 | (guix build union)) | |
736 | #~(begin | |
737 | (use-modules (srfi srfi-26) | |
738 | (guix build utils) | |
739 | (guix build union)) | |
740 | (let* ((destdir (string-append #$output "/share/applications")) | |
741 | (appdirs (filter file-exists? | |
742 | (map (cut string-append <> | |
743 | "/share/applications") | |
744 | '#$(manifest-inputs manifest)))) | |
745 | (update-desktop-database (string-append | |
746 | #+desktop-file-utils | |
747 | "/bin/update-desktop-database"))) | |
748 | (mkdir-p (string-append #$output "/share")) | |
749 | (union-build destdir appdirs | |
750 | #:log-port (%make-void-port "w")) | |
751 | (exit (zero? (system* update-desktop-database destdir))))))) | |
842cb820 | 752 | |
d72d7833 SB |
753 | ;; Don't run the hook when 'desktop-file-utils' is not referenced. |
754 | (if desktop-file-utils | |
755 | (gexp->derivation "xdg-desktop-database" build | |
d72d7833 SB |
756 | #:local-build? #t |
757 | #:substitutable? #f) | |
758 | (return #f)))) | |
842cb820 | 759 | |
6c06b1fd SB |
760 | (define (xdg-mime-database manifest) |
761 | "Return a derivation that builds the @file{mime.cache} database from manifest | |
762 | entries. It's used to query the MIME type of a given file." | |
801d316b SB |
763 | (define shared-mime-info ; lazy reference |
764 | (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info)) | |
765 | ||
766 | (mlet %store-monad ((glib | |
d72d7833 | 767 | (manifest-lookup-package |
801d316b | 768 | manifest "glib"))) |
d72d7833 | 769 | (define build |
99b231de LC |
770 | (with-imported-modules '((guix build utils) |
771 | (guix build union)) | |
772 | #~(begin | |
773 | (use-modules (srfi srfi-26) | |
774 | (guix build utils) | |
775 | (guix build union)) | |
776 | (let* ((datadir (string-append #$output "/share")) | |
777 | (destdir (string-append datadir "/mime")) | |
778 | (pkgdirs (filter file-exists? | |
779 | (map (cut string-append <> | |
780 | "/share/mime/packages") | |
801d316b SB |
781 | (cons #+shared-mime-info |
782 | '#$(manifest-inputs manifest))))) | |
99b231de LC |
783 | (update-mime-database (string-append |
784 | #+shared-mime-info | |
785 | "/bin/update-mime-database"))) | |
786 | (mkdir-p destdir) | |
787 | (union-build (string-append destdir "/packages") pkgdirs | |
788 | #:log-port (%make-void-port "w")) | |
789 | (setenv "XDG_DATA_HOME" datadir) | |
790 | (exit (zero? (system* update-mime-database destdir))))))) | |
d72d7833 | 791 | |
801d316b SB |
792 | ;; Don't run the hook when there are no GLib based applications. |
793 | (if glib | |
d72d7833 | 794 | (gexp->derivation "xdg-mime-database" build |
d72d7833 SB |
795 | #:local-build? #t |
796 | #:substitutable? #f) | |
797 | (return #f)))) | |
6c06b1fd | 798 | |
9eb5a449 AK |
799 | (define (fonts-dir-file manifest) |
800 | "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale} | |
801 | files for the truetype fonts of the @var{manifest} entries." | |
802 | (define mkfontscale | |
803 | (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale)) | |
804 | ||
805 | (define mkfontdir | |
806 | (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir)) | |
807 | ||
808 | (define build | |
809 | #~(begin | |
810 | (use-modules (srfi srfi-26) | |
811 | (guix build utils) | |
812 | (guix build union)) | |
813 | (let ((ttf-dirs (filter file-exists? | |
814 | (map (cut string-append <> | |
815 | "/share/fonts/truetype") | |
816 | '#$(manifest-inputs manifest))))) | |
817 | (mkdir #$output) | |
818 | (if (null? ttf-dirs) | |
819 | (exit #t) | |
820 | (let* ((fonts-dir (string-append #$output "/share/fonts")) | |
821 | (ttf-dir (string-append fonts-dir "/truetype")) | |
822 | (mkfontscale (string-append #+mkfontscale | |
823 | "/bin/mkfontscale")) | |
824 | (mkfontdir (string-append #+mkfontdir | |
825 | "/bin/mkfontdir"))) | |
826 | (mkdir-p fonts-dir) | |
827 | (union-build ttf-dir ttf-dirs | |
828 | #:log-port (%make-void-port "w")) | |
829 | (with-directory-excursion ttf-dir | |
830 | (exit (and (zero? (system* mkfontscale)) | |
831 | (zero? (system* mkfontdir)))))))))) | |
832 | ||
833 | (gexp->derivation "fonts-dir" build | |
834 | #:modules '((guix build utils) | |
835 | (guix build union)) | |
836 | #:local-build? #t | |
837 | #:substitutable? #f)) | |
838 | ||
aa46a028 LC |
839 | (define %default-profile-hooks |
840 | ;; This is the list of derivation-returning procedures that are called by | |
841 | ;; default when making a non-empty profile. | |
842 | (list info-dir-file | |
9eb5a449 | 843 | fonts-dir-file |
aa46a028 | 844 | ghc-package-cache-file |
b04af0ec | 845 | ca-certificate-bundle |
842cb820 | 846 | gtk-icon-themes |
6c06b1fd SB |
847 | xdg-desktop-database |
848 | xdg-mime-database)) | |
536c3ee4 MW |
849 | |
850 | (define* (profile-derivation manifest | |
851 | #:key | |
e5f04c2d LC |
852 | (hooks %default-profile-hooks) |
853 | system) | |
79ee406d | 854 | "Return a derivation that builds a profile (aka. 'user environment') with |
aa46a028 LC |
855 | the given MANIFEST. The profile includes additional derivations returned by |
856 | the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." | |
e5f04c2d LC |
857 | (mlet %store-monad ((system (if system |
858 | (return system) | |
859 | (current-system))) | |
860 | (extras (if (null? (manifest-entries manifest)) | |
aa46a028 LC |
861 | (return '()) |
862 | (sequence %store-monad | |
07eaecfa LC |
863 | (map (lambda (hook) |
864 | (hook manifest)) | |
865 | hooks))))) | |
79ee406d | 866 | (define inputs |
eeae0b3c SB |
867 | (append (filter-map (lambda (drv) |
868 | (and (derivation? drv) | |
869 | (gexp-input drv))) | |
07eaecfa | 870 | extras) |
536c3ee4 | 871 | (manifest-inputs manifest))) |
79ee406d LC |
872 | |
873 | (define builder | |
99b231de LC |
874 | (with-imported-modules '((guix build profiles) |
875 | (guix build union) | |
876 | (guix build utils) | |
877 | (guix search-paths) | |
878 | (guix records)) | |
879 | #~(begin | |
880 | (use-modules (guix build profiles) | |
881 | (guix search-paths) | |
882 | (srfi srfi-1)) | |
883 | ||
884 | (setvbuf (current-output-port) _IOLBF) | |
885 | (setvbuf (current-error-port) _IOLBF) | |
886 | ||
887 | (define search-paths | |
888 | ;; Search paths of MANIFEST's packages, converted back to their | |
889 | ;; record form. | |
890 | (map sexp->search-path-specification | |
891 | (delete-duplicates | |
892 | '#$(map search-path-specification->sexp | |
893 | (append-map manifest-entry-search-paths | |
894 | (manifest-entries manifest)))))) | |
895 | ||
896 | (build-profile #$output '#$inputs | |
897 | #:manifest '#$(manifest->gexp manifest) | |
898 | #:search-paths search-paths)))) | |
79ee406d LC |
899 | |
900 | (gexp->derivation "profile" builder | |
40d71e44 | 901 | #:system system |
a7a4fd9a LC |
902 | |
903 | ;; Not worth offloading. | |
904 | #:local-build? #t | |
905 | ||
906 | ;; Disable substitution because it would trigger a | |
907 | ;; connection to the substitute server, which is likely | |
908 | ;; to have no substitute to offer. | |
909 | #:substitutable? #f))) | |
cc4ecc2d LC |
910 | |
911 | (define (profile-regexp profile) | |
912 | "Return a regular expression that matches PROFILE's name and number." | |
913 | (make-regexp (string-append "^" (regexp-quote (basename profile)) | |
914 | "-([0-9]+)"))) | |
915 | ||
916 | (define (generation-number profile) | |
917 | "Return PROFILE's number or 0. An absolute file name must be used." | |
918 | (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) | |
919 | (basename (readlink profile)))) | |
920 | (compose string->number (cut match:substring <> 1))) | |
921 | 0)) | |
922 | ||
923 | (define (generation-numbers profile) | |
924 | "Return the sorted list of generation numbers of PROFILE, or '(0) if no | |
925 | former profiles were found." | |
926 | (define* (scandir name #:optional (select? (const #t)) | |
927 | (entry<? (@ (ice-9 i18n) string-locale<?))) | |
928 | ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. | |
929 | (define (enter? dir stat result) | |
930 | (and stat (string=? dir name))) | |
931 | ||
932 | (define (visit basename result) | |
933 | (if (select? basename) | |
934 | (cons basename result) | |
935 | result)) | |
936 | ||
937 | (define (leaf name stat result) | |
938 | (and result | |
939 | (visit (basename name) result))) | |
940 | ||
941 | (define (down name stat result) | |
942 | (visit "." '())) | |
943 | ||
944 | (define (up name stat result) | |
945 | (visit ".." result)) | |
946 | ||
947 | (define (skip name stat result) | |
948 | ;; All the sub-directories are skipped. | |
949 | (visit (basename name) result)) | |
950 | ||
951 | (define (error name* stat errno result) | |
952 | (if (string=? name name*) ; top-level NAME is unreadable | |
953 | result | |
954 | (visit (basename name*) result))) | |
955 | ||
956 | (and=> (file-system-fold enter? leaf down up skip error #f name lstat) | |
957 | (lambda (files) | |
958 | (sort files entry<?)))) | |
959 | ||
960 | (match (scandir (dirname profile) | |
961 | (cute regexp-exec (profile-regexp profile) <>)) | |
962 | (#f ; no profile directory | |
963 | '(0)) | |
964 | (() ; no profiles | |
965 | '(0)) | |
966 | ((profiles ...) ; former profiles around | |
967 | (sort (map (compose string->number | |
968 | (cut match:substring <> 1) | |
969 | (cute regexp-exec (profile-regexp profile) <>)) | |
970 | profiles) | |
971 | <)))) | |
972 | ||
f452e8ff AK |
973 | (define (profile-generations profile) |
974 | "Return a list of PROFILE's generations." | |
975 | (let ((generations (generation-numbers profile))) | |
976 | (if (equal? generations '(0)) | |
977 | '() | |
978 | generations))) | |
979 | ||
3ccde087 AK |
980 | (define* (relative-generation profile shift #:optional |
981 | (current (generation-number profile))) | |
982 | "Return PROFILE's generation shifted from the CURRENT generation by SHIFT. | |
983 | SHIFT is a positive or negative number. | |
984 | Return #f if there is no such generation." | |
985 | (let* ((abs-shift (abs shift)) | |
986 | (numbers (profile-generations profile)) | |
987 | (from-current (memq current | |
988 | (if (negative? shift) | |
989 | (reverse numbers) | |
990 | numbers)))) | |
991 | (and from-current | |
992 | (< abs-shift (length from-current)) | |
993 | (list-ref from-current abs-shift)))) | |
994 | ||
995 | (define* (previous-generation-number profile #:optional | |
996 | (number (generation-number profile))) | |
cc4ecc2d LC |
997 | "Return the number of the generation before generation NUMBER of |
998 | PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the | |
999 | case when generations have been deleted (there are \"holes\")." | |
3ccde087 AK |
1000 | (or (relative-generation profile -1 number) |
1001 | 0)) | |
cc4ecc2d LC |
1002 | |
1003 | (define (generation-file-name profile generation) | |
1004 | "Return the file name for PROFILE's GENERATION." | |
1005 | (format #f "~a-~a-link" profile generation)) | |
1006 | ||
1007 | (define (generation-time profile number) | |
1008 | "Return the creation time of a generation in the UTC format." | |
1009 | (make-time time-utc 0 | |
1010 | (stat:ctime (stat (generation-file-name profile number))))) | |
1011 | ||
06d45f45 LC |
1012 | (define (link-to-empty-profile store generation) |
1013 | "Link GENERATION, a string, to the empty profile. An error is raised if | |
1014 | that fails." | |
1015 | (let* ((drv (run-with-store store | |
1016 | (profile-derivation (manifest '())))) | |
1017 | (prof (derivation->output-path drv "out"))) | |
1018 | (build-derivations store (list drv)) | |
1019 | (switch-symlinks generation prof))) | |
1020 | ||
1021 | (define (switch-to-generation profile number) | |
1022 | "Atomically switch PROFILE to the generation NUMBER. Return the number of | |
1023 | the generation that was current before switching." | |
1024 | (let ((current (generation-number profile)) | |
1025 | (generation (generation-file-name profile number))) | |
1026 | (cond ((not (file-exists? profile)) | |
1027 | (raise (condition (&profile-not-found-error | |
1028 | (profile profile))))) | |
1029 | ((not (file-exists? generation)) | |
1030 | (raise (condition (&missing-generation-error | |
1031 | (profile profile) | |
1032 | (generation number))))) | |
1033 | (else | |
1034 | (switch-symlinks profile generation) | |
1035 | current)))) | |
1036 | ||
1037 | (define (switch-to-previous-generation profile) | |
1038 | "Atomically switch PROFILE to the previous generation. Return the former | |
1039 | generation number and the current one." | |
1040 | (let ((previous (previous-generation-number profile))) | |
1041 | (values (switch-to-generation profile previous) | |
1042 | previous))) | |
1043 | ||
1044 | (define (roll-back store profile) | |
1045 | "Roll back to the previous generation of PROFILE. Return the number of the | |
1046 | generation that was current before switching and the new generation number." | |
1047 | (let* ((number (generation-number profile)) | |
1048 | (previous-number (previous-generation-number profile number)) | |
1049 | (previous-generation (generation-file-name profile previous-number))) | |
1050 | (cond ((not (file-exists? profile)) ;invalid profile | |
1051 | (raise (condition (&profile-not-found-error | |
1052 | (profile profile))))) | |
1053 | ((zero? number) ;empty profile | |
1054 | (values number number)) | |
1055 | ((or (zero? previous-number) ;going to emptiness | |
1056 | (not (file-exists? previous-generation))) | |
1057 | (link-to-empty-profile store previous-generation) | |
1058 | (switch-to-previous-generation profile)) | |
1059 | (else ;anything else | |
1060 | (switch-to-previous-generation profile))))) | |
1061 | ||
1062 | (define (delete-generation store profile number) | |
1063 | "Delete generation with NUMBER from PROFILE. Return the file name of the | |
1064 | generation that has been deleted, or #f if nothing was done (for instance | |
1065 | because the NUMBER is zero.)" | |
1066 | (define (delete-and-return) | |
1067 | (let ((generation (generation-file-name profile number))) | |
1068 | (delete-file generation) | |
1069 | generation)) | |
1070 | ||
1071 | (let* ((current-number (generation-number profile)) | |
1072 | (previous-number (previous-generation-number profile number)) | |
1073 | (previous-generation (generation-file-name profile previous-number))) | |
1074 | (cond ((zero? number) #f) ;do not delete generation 0 | |
1075 | ((and (= number current-number) | |
1076 | (not (file-exists? previous-generation))) | |
1077 | (link-to-empty-profile store previous-generation) | |
1078 | (switch-to-previous-generation profile) | |
1079 | (delete-and-return)) | |
1080 | ((= number current-number) | |
1081 | (roll-back store profile) | |
1082 | (delete-and-return)) | |
1083 | (else | |
1084 | (delete-and-return))))) | |
1085 | ||
cc4ecc2d | 1086 | ;;; profiles.scm ends here |