Commit | Line | Data |
---|---|---|
cc4ecc2d | 1 | ;;; GNU Guix --- Functional package management for GNU |
e87f0591 | 2 | ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
cc4ecc2d | 3 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
343745c8 | 4 | ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> |
536c3ee4 | 5 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> |
cc4ecc2d LC |
6 | ;;; |
7 | ;;; This file is part of GNU Guix. | |
8 | ;;; | |
9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
10 | ;;; under the terms of the GNU General Public License as published by | |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
14 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | (define-module (guix profiles) | |
23 | #:use-module (guix utils) | |
24 | #:use-module (guix records) | |
25 | #:use-module (guix derivations) | |
26 | #:use-module (guix packages) | |
a54c94a4 | 27 | #:use-module (guix gexp) |
79ee406d | 28 | #:use-module (guix monads) |
e87f0591 | 29 | #:use-module (guix store) |
cc4ecc2d LC |
30 | #:use-module (ice-9 match) |
31 | #:use-module (ice-9 regex) | |
32 | #:use-module (ice-9 ftw) | |
343745c8 | 33 | #:use-module (ice-9 format) |
cc4ecc2d LC |
34 | #:use-module (srfi srfi-1) |
35 | #:use-module (srfi srfi-9) | |
79601521 | 36 | #:use-module (srfi srfi-11) |
cc4ecc2d LC |
37 | #:use-module (srfi srfi-19) |
38 | #:use-module (srfi srfi-26) | |
c0c018f1 AK |
39 | #:use-module (srfi srfi-34) |
40 | #:use-module (srfi srfi-35) | |
41 | #:export (&profile-error | |
42 | profile-error? | |
43 | profile-error-profile | |
44 | &profile-not-found-error | |
45 | profile-not-found-error? | |
46 | &missing-generation-error | |
47 | missing-generation-error? | |
48 | missing-generation-error-generation | |
49 | ||
50 | manifest make-manifest | |
cc4ecc2d LC |
51 | manifest? |
52 | manifest-entries | |
53 | ||
54 | <manifest-entry> ; FIXME: eventually make it internal | |
55 | manifest-entry | |
56 | manifest-entry? | |
57 | manifest-entry-name | |
58 | manifest-entry-version | |
59 | manifest-entry-output | |
a54c94a4 | 60 | manifest-entry-item |
cc4ecc2d LC |
61 | manifest-entry-dependencies |
62 | ||
a2078770 LC |
63 | manifest-pattern |
64 | manifest-pattern? | |
65 | ||
cc4ecc2d | 66 | manifest-remove |
f7554030 | 67 | manifest-add |
ef8993e2 | 68 | manifest-lookup |
cc4ecc2d | 69 | manifest-installed? |
a2078770 | 70 | manifest-matching-entries |
cc4ecc2d | 71 | |
343745c8 AK |
72 | manifest-transaction |
73 | manifest-transaction? | |
74 | manifest-transaction-install | |
75 | manifest-transaction-remove | |
76 | manifest-perform-transaction | |
79601521 | 77 | manifest-transaction-effects |
343745c8 | 78 | |
cc4ecc2d | 79 | profile-manifest |
462f5cca | 80 | package->manifest-entry |
aa46a028 | 81 | %default-profile-hooks |
cc4ecc2d LC |
82 | profile-derivation |
83 | generation-number | |
84 | generation-numbers | |
f452e8ff | 85 | profile-generations |
3ccde087 | 86 | relative-generation |
cc4ecc2d LC |
87 | previous-generation-number |
88 | generation-time | |
89 | generation-file-name)) | |
90 | ||
91 | ;;; Commentary: | |
92 | ;;; | |
93 | ;;; Tools to create and manipulate profiles---i.e., the representation of a | |
94 | ;;; set of installed packages. | |
95 | ;;; | |
96 | ;;; Code: | |
97 | ||
98 | \f | |
c0c018f1 AK |
99 | ;;; |
100 | ;;; Condition types. | |
101 | ;;; | |
102 | ||
103 | (define-condition-type &profile-error &error | |
104 | profile-error? | |
105 | (profile profile-error-profile)) | |
106 | ||
107 | (define-condition-type &profile-not-found-error &profile-error | |
108 | profile-not-found-error?) | |
109 | ||
110 | (define-condition-type &missing-generation-error &profile-error | |
111 | missing-generation-error? | |
112 | (generation missing-generation-error-generation)) | |
113 | ||
114 | \f | |
cc4ecc2d LC |
115 | ;;; |
116 | ;;; Manifests. | |
117 | ;;; | |
118 | ||
119 | (define-record-type <manifest> | |
120 | (manifest entries) | |
121 | manifest? | |
122 | (entries manifest-entries)) ; list of <manifest-entry> | |
123 | ||
124 | ;; Convenient alias, to avoid name clashes. | |
125 | (define make-manifest manifest) | |
126 | ||
127 | (define-record-type* <manifest-entry> manifest-entry | |
128 | make-manifest-entry | |
129 | manifest-entry? | |
130 | (name manifest-entry-name) ; string | |
131 | (version manifest-entry-version) ; string | |
132 | (output manifest-entry-output ; string | |
133 | (default "out")) | |
a54c94a4 | 134 | (item manifest-entry-item) ; package | store path |
4ca0b410 LC |
135 | (dependencies manifest-entry-dependencies ; (store path | package)* |
136 | (default '()))) | |
cc4ecc2d | 137 | |
a2078770 LC |
138 | (define-record-type* <manifest-pattern> manifest-pattern |
139 | make-manifest-pattern | |
140 | manifest-pattern? | |
141 | (name manifest-pattern-name) ; string | |
142 | (version manifest-pattern-version ; string | #f | |
143 | (default #f)) | |
144 | (output manifest-pattern-output ; string | #f | |
145 | (default "out"))) | |
146 | ||
cc4ecc2d LC |
147 | (define (profile-manifest profile) |
148 | "Return the PROFILE's manifest." | |
149 | (let ((file (string-append profile "/manifest"))) | |
150 | (if (file-exists? file) | |
151 | (call-with-input-file file read-manifest) | |
152 | (manifest '())))) | |
153 | ||
462f5cca LC |
154 | (define* (package->manifest-entry package #:optional output) |
155 | "Return a manifest entry for the OUTPUT of package PACKAGE. When OUTPUT is | |
156 | omitted or #f, use the first output of PACKAGE." | |
157 | (let ((deps (map (match-lambda | |
158 | ((label package) | |
b4a4bec0 | 159 | (gexp-input package)) |
462f5cca | 160 | ((label package output) |
b4a4bec0 | 161 | (gexp-input package output))) |
462f5cca LC |
162 | (package-transitive-propagated-inputs package)))) |
163 | (manifest-entry | |
164 | (name (package-name package)) | |
165 | (version (package-version package)) | |
166 | (output (or output (car (package-outputs package)))) | |
167 | (item package) | |
168 | (dependencies (delete-duplicates deps))))) | |
169 | ||
a54c94a4 LC |
170 | (define (manifest->gexp manifest) |
171 | "Return a representation of MANIFEST as a gexp." | |
172 | (define (entry->gexp entry) | |
cc4ecc2d | 173 | (match entry |
a54c94a4 LC |
174 | (($ <manifest-entry> name version output (? string? path) (deps ...)) |
175 | #~(#$name #$version #$output #$path #$deps)) | |
176 | (($ <manifest-entry> name version output (? package? package) (deps ...)) | |
177 | #~(#$name #$version #$output | |
178 | (ungexp package (or output "out")) #$deps)))) | |
cc4ecc2d LC |
179 | |
180 | (match manifest | |
181 | (($ <manifest> (entries ...)) | |
a54c94a4 LC |
182 | #~(manifest (version 1) |
183 | (packages #$(map entry->gexp entries)))))) | |
cc4ecc2d LC |
184 | |
185 | (define (sexp->manifest sexp) | |
186 | "Parse SEXP as a manifest." | |
187 | (match sexp | |
188 | (('manifest ('version 0) | |
189 | ('packages ((name version output path) ...))) | |
190 | (manifest | |
191 | (map (lambda (name version output path) | |
192 | (manifest-entry | |
193 | (name name) | |
194 | (version version) | |
195 | (output output) | |
a54c94a4 | 196 | (item path))) |
cc4ecc2d LC |
197 | name version output path))) |
198 | ||
199 | ;; Version 1 adds a list of propagated inputs to the | |
200 | ;; name/version/output/path tuples. | |
201 | (('manifest ('version 1) | |
202 | ('packages ((name version output path deps) ...))) | |
203 | (manifest | |
204 | (map (lambda (name version output path deps) | |
d34736c5 LC |
205 | ;; Up to Guix 0.7 included, dependencies were listed as ("gmp" |
206 | ;; "/gnu/store/...-gmp") for instance. Discard the 'label' in | |
207 | ;; such lists. | |
208 | (let ((deps (match deps | |
209 | (((labels directories) ...) | |
210 | directories) | |
211 | ((directories ...) | |
212 | directories)))) | |
213 | (manifest-entry | |
214 | (name name) | |
215 | (version version) | |
216 | (output output) | |
217 | (item path) | |
218 | (dependencies deps)))) | |
cc4ecc2d LC |
219 | name version output path deps))) |
220 | ||
221 | (_ | |
222 | (error "unsupported manifest format" manifest)))) | |
223 | ||
224 | (define (read-manifest port) | |
225 | "Return the packages listed in MANIFEST." | |
226 | (sexp->manifest (read port))) | |
227 | ||
a2078770 LC |
228 | (define (entry-predicate pattern) |
229 | "Return a procedure that returns #t when passed a manifest entry that | |
230 | matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they | |
231 | are ignored." | |
232 | (match pattern | |
233 | (($ <manifest-pattern> name version output) | |
234 | (match-lambda | |
235 | (($ <manifest-entry> entry-name entry-version entry-output) | |
236 | (and (string=? entry-name name) | |
237 | (or (not entry-output) (not output) | |
238 | (string=? entry-output output)) | |
239 | (or (not version) | |
240 | (string=? entry-version version)))))))) | |
241 | ||
242 | (define (manifest-remove manifest patterns) | |
243 | "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS | |
244 | must be a manifest-pattern." | |
245 | (define (remove-entry pattern lst) | |
246 | (remove (entry-predicate pattern) lst)) | |
247 | ||
248 | (make-manifest (fold remove-entry | |
cc4ecc2d | 249 | (manifest-entries manifest) |
a2078770 | 250 | patterns))) |
cc4ecc2d | 251 | |
f7554030 AK |
252 | (define (manifest-add manifest entries) |
253 | "Add a list of manifest ENTRIES to MANIFEST and return new manifest. | |
254 | Remove MANIFEST entries that have the same name and output as ENTRIES." | |
255 | (define (same-entry? entry name output) | |
256 | (match entry | |
257 | (($ <manifest-entry> entry-name _ entry-output _ ...) | |
258 | (and (equal? name entry-name) | |
259 | (equal? output entry-output))))) | |
260 | ||
261 | (make-manifest | |
262 | (append entries | |
263 | (fold (lambda (entry result) | |
264 | (match entry | |
265 | (($ <manifest-entry> name _ out _ ...) | |
266 | (filter (negate (cut same-entry? <> name out)) | |
267 | result)))) | |
268 | (manifest-entries manifest) | |
269 | entries)))) | |
270 | ||
ef8993e2 LC |
271 | (define (manifest-lookup manifest pattern) |
272 | "Return the first item of MANIFEST that matches PATTERN, or #f if there is | |
273 | no match.." | |
274 | (find (entry-predicate pattern) | |
275 | (manifest-entries manifest))) | |
276 | ||
a2078770 LC |
277 | (define (manifest-installed? manifest pattern) |
278 | "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), | |
279 | #f otherwise." | |
ef8993e2 | 280 | (->bool (manifest-lookup manifest pattern))) |
cc4ecc2d | 281 | |
a2078770 LC |
282 | (define (manifest-matching-entries manifest patterns) |
283 | "Return all the entries of MANIFEST that match one of the PATTERNS." | |
284 | (define predicates | |
285 | (map entry-predicate patterns)) | |
286 | ||
287 | (define (matches? entry) | |
288 | (any (lambda (pred) | |
289 | (pred entry)) | |
290 | predicates)) | |
291 | ||
292 | (filter matches? (manifest-entries manifest))) | |
293 | ||
cc4ecc2d | 294 | \f |
343745c8 AK |
295 | ;;; |
296 | ;;; Manifest transactions. | |
297 | ;;; | |
298 | ||
299 | (define-record-type* <manifest-transaction> manifest-transaction | |
300 | make-manifest-transaction | |
301 | manifest-transaction? | |
302 | (install manifest-transaction-install ; list of <manifest-entry> | |
303 | (default '())) | |
304 | (remove manifest-transaction-remove ; list of <manifest-pattern> | |
305 | (default '()))) | |
306 | ||
79601521 | 307 | (define (manifest-transaction-effects manifest transaction) |
46b23e1a LC |
308 | "Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values: |
309 | the list of packages that would be removed, installed, upgraded, or downgraded | |
310 | when applying TRANSACTION to MANIFEST. Upgrades are represented as pairs | |
311 | where the head is the entry being upgraded and the tail is the entry that will | |
312 | replace it." | |
79601521 LC |
313 | (define (manifest-entry->pattern entry) |
314 | (manifest-pattern | |
315 | (name (manifest-entry-name entry)) | |
316 | (output (manifest-entry-output entry)))) | |
317 | ||
46b23e1a LC |
318 | (let loop ((input (manifest-transaction-install transaction)) |
319 | (install '()) | |
320 | (upgrade '()) | |
321 | (downgrade '())) | |
79601521 LC |
322 | (match input |
323 | (() | |
324 | (let ((remove (manifest-transaction-remove transaction))) | |
325 | (values (manifest-matching-entries manifest remove) | |
46b23e1a | 326 | (reverse install) (reverse upgrade) (reverse downgrade)))) |
79601521 LC |
327 | ((entry rest ...) |
328 | ;; Check whether installing ENTRY corresponds to the installation of a | |
329 | ;; new package or to an upgrade. | |
330 | ||
331 | ;; XXX: When the exact same output directory is installed, we're not | |
332 | ;; really upgrading anything. Add a check for that case. | |
333 | (let* ((pattern (manifest-entry->pattern entry)) | |
46b23e1a LC |
334 | (previous (manifest-lookup manifest pattern)) |
335 | (newer? (and previous | |
3bea13bb LC |
336 | (version>=? (manifest-entry-version entry) |
337 | (manifest-entry-version previous))))) | |
79601521 | 338 | (loop rest |
ef8993e2 | 339 | (if previous install (cons entry install)) |
46b23e1a | 340 | (if (and previous newer?) |
ef8993e2 | 341 | (alist-cons previous entry upgrade) |
46b23e1a LC |
342 | upgrade) |
343 | (if (and previous (not newer?)) | |
344 | (alist-cons previous entry downgrade) | |
345 | downgrade))))))) | |
79601521 | 346 | |
343745c8 AK |
347 | (define (manifest-perform-transaction manifest transaction) |
348 | "Perform TRANSACTION on MANIFEST and return new manifest." | |
349 | (let ((install (manifest-transaction-install transaction)) | |
350 | (remove (manifest-transaction-remove transaction))) | |
351 | (manifest-add (manifest-remove manifest remove) | |
352 | install))) | |
353 | ||
343745c8 | 354 | \f |
cc4ecc2d LC |
355 | ;;; |
356 | ;;; Profiles. | |
357 | ;;; | |
358 | ||
79ee406d | 359 | (define (manifest-inputs manifest) |
b4a4bec0 | 360 | "Return a list of <gexp-input> objects for MANIFEST." |
79ee406d | 361 | (append-map (match-lambda |
b4a4bec0 LC |
362 | (($ <manifest-entry> name version output thing deps) |
363 | ;; THING may be a package or a file name. In the latter case, | |
364 | ;; assume it's already valid. Ditto for DEPS. | |
365 | (cons (gexp-input thing output) deps))) | |
79ee406d LC |
366 | (manifest-entries manifest))) |
367 | ||
368 | (define (info-dir-file manifest) | |
369 | "Return a derivation that builds the 'dir' file for all the entries of | |
370 | MANIFEST." | |
2f0556ae LC |
371 | (define texinfo ;lazy reference |
372 | (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo)) | |
373 | (define gzip ;lazy reference | |
374 | (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) | |
375 | ||
79ee406d | 376 | (define build |
a54c94a4 | 377 | #~(begin |
79ee406d LC |
378 | (use-modules (guix build utils) |
379 | (srfi srfi-1) (srfi srfi-26) | |
380 | (ice-9 ftw)) | |
381 | ||
382 | (define (info-file? file) | |
383 | (or (string-suffix? ".info" file) | |
384 | (string-suffix? ".info.gz" file))) | |
385 | ||
386 | (define (info-files top) | |
387 | (let ((infodir (string-append top "/share/info"))) | |
388 | (map (cut string-append infodir "/" <>) | |
c2815c0f | 389 | (or (scandir infodir info-file?) '())))) |
79ee406d LC |
390 | |
391 | (define (install-info info) | |
2f0556ae | 392 | (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files |
79ee406d LC |
393 | (zero? |
394 | (system* (string-append #+texinfo "/bin/install-info") | |
395 | info (string-append #$output "/share/info/dir")))) | |
396 | ||
397 | (mkdir-p (string-append #$output "/share/info")) | |
398 | (every install-info | |
399 | (append-map info-files | |
400 | '#$(manifest-inputs manifest))))) | |
401 | ||
aa46a028 LC |
402 | (gexp->derivation "info-dir" build |
403 | #:modules '((guix build utils)))) | |
79ee406d | 404 | |
042bc828 FB |
405 | (define (ghc-package-cache-file manifest) |
406 | "Return a derivation that builds the GHC 'package.cache' file for all the | |
aa46a028 | 407 | entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." |
042bc828 FB |
408 | (define ghc ;lazy reference |
409 | (module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) | |
410 | ||
411 | (define build | |
412 | #~(begin | |
413 | (use-modules (guix build utils) | |
414 | (srfi srfi-1) (srfi srfi-26) | |
415 | (ice-9 ftw)) | |
416 | ||
417 | (define ghc-name-version | |
418 | (let* ((base (basename #+ghc))) | |
419 | (string-drop base | |
420 | (+ 1 (string-index base #\-))))) | |
421 | ||
422 | (define db-subdir | |
423 | (string-append "lib/" ghc-name-version "/package.conf.d")) | |
424 | ||
425 | (define db-dir | |
426 | (string-append #$output "/" db-subdir)) | |
427 | ||
428 | (define (conf-files top) | |
429 | (find-files (string-append top "/" db-subdir) "\\.conf$")) | |
430 | ||
431 | (define (copy-conf-file conf) | |
432 | (let ((base (basename conf))) | |
433 | (copy-file conf (string-append db-dir "/" base)))) | |
434 | ||
435 | (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) | |
436 | (for-each copy-conf-file | |
437 | (append-map conf-files | |
438 | '#$(manifest-inputs manifest))) | |
439 | (let ((success | |
440 | (zero? | |
441 | (system* (string-append #+ghc "/bin/ghc-pkg") "recache" | |
442 | (string-append "--package-db=" db-dir))))) | |
443 | (for-each delete-file (find-files db-dir "\\.conf$")) | |
444 | success))) | |
445 | ||
446 | ;; Don't depend on GHC when there's nothing to do. | |
aa46a028 LC |
447 | (and (any (cut string-prefix? "ghc" <>) |
448 | (map manifest-entry-name (manifest-entries manifest))) | |
449 | (gexp->derivation "ghc-package-cache" build | |
450 | #:modules '((guix build utils)) | |
451 | #:local-build? #t))) | |
042bc828 | 452 | |
536c3ee4 MW |
453 | (define (ca-certificate-bundle manifest) |
454 | "Return a derivation that builds a single-file bundle containing the CA | |
455 | certificates in the /etc/ssl/certs sub-directories of the packages in | |
456 | MANIFEST. Single-file bundles are required by programs such as Git and Lynx." | |
457 | ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html> | |
458 | ;; for a discussion. | |
459 | ||
460 | (define glibc-utf8-locales ;lazy reference | |
461 | (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) | |
462 | ||
463 | (define build | |
464 | #~(begin | |
465 | (use-modules (guix build utils) | |
466 | (rnrs io ports) | |
467 | (srfi srfi-1) | |
468 | (srfi srfi-26) | |
c568191a LC |
469 | (ice-9 ftw) |
470 | (ice-9 match)) | |
536c3ee4 MW |
471 | |
472 | (define (pem-file? file) | |
473 | (string-suffix? ".pem" file)) | |
474 | ||
475 | (define (ca-files top) | |
476 | (let ((cert-dir (string-append top "/etc/ssl/certs"))) | |
477 | (map (cut string-append cert-dir "/" <>) | |
478 | (or (scandir cert-dir pem-file?) '())))) | |
479 | ||
480 | (define (concatenate-files files result) | |
481 | "Make RESULT the concatenation of all of FILES." | |
482 | (define (dump file port) | |
483 | (display (call-with-input-file file get-string-all) | |
484 | port) | |
485 | (newline port)) ;required, see <https://bugs.debian.org/635570> | |
486 | ||
487 | (call-with-output-file result | |
488 | (lambda (port) | |
489 | (for-each (cut dump <> port) files)))) | |
490 | ||
491 | ;; Some file names in the NSS certificates are UTF-8 encoded so | |
492 | ;; install a UTF-8 locale. | |
493 | (setenv "LOCPATH" (string-append #+glibc-utf8-locales "/lib/locale")) | |
494 | (setlocale LC_ALL "en_US.UTF-8") | |
495 | ||
c568191a LC |
496 | (match (append-map ca-files '#$(manifest-inputs manifest)) |
497 | (() | |
498 | ;; Since there are no CA files, just create an empty directory. Do | |
499 | ;; not create the etc/ssl/certs sub-directory, since that would | |
500 | ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be | |
501 | ;; defined. | |
502 | (mkdir #$output) | |
503 | #t) | |
504 | ((ca-files ...) | |
505 | (let ((result (string-append #$output "/etc/ssl/certs"))) | |
506 | (mkdir-p result) | |
507 | (concatenate-files ca-files | |
508 | (string-append result | |
509 | "/ca-certificates.crt")) | |
510 | #t))))) | |
536c3ee4 | 511 | |
aa46a028 LC |
512 | (gexp->derivation "ca-certificate-bundle" build |
513 | #:modules '((guix build utils)) | |
514 | #:local-build? #t)) | |
515 | ||
516 | (define %default-profile-hooks | |
517 | ;; This is the list of derivation-returning procedures that are called by | |
518 | ;; default when making a non-empty profile. | |
519 | (list info-dir-file | |
520 | ghc-package-cache-file | |
521 | ca-certificate-bundle)) | |
536c3ee4 MW |
522 | |
523 | (define* (profile-derivation manifest | |
524 | #:key | |
aa46a028 | 525 | (hooks %default-profile-hooks)) |
79ee406d | 526 | "Return a derivation that builds a profile (aka. 'user environment') with |
aa46a028 LC |
527 | the given MANIFEST. The profile includes additional derivations returned by |
528 | the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." | |
529 | (mlet %store-monad ((extras (if (null? (manifest-entries manifest)) | |
530 | (return '()) | |
531 | (sequence %store-monad | |
532 | (filter-map (lambda (hook) | |
533 | (hook manifest)) | |
534 | hooks))))) | |
79ee406d | 535 | (define inputs |
aa46a028 | 536 | (append (map gexp-input extras) |
536c3ee4 | 537 | (manifest-inputs manifest))) |
79ee406d LC |
538 | |
539 | (define builder | |
540 | #~(begin | |
541 | (use-modules (ice-9 pretty-print) | |
542 | (guix build union)) | |
543 | ||
544 | (setvbuf (current-output-port) _IOLBF) | |
545 | (setvbuf (current-error-port) _IOLBF) | |
546 | ||
547 | (union-build #$output '#$inputs | |
548 | #:log-port (%make-void-port "w")) | |
549 | (call-with-output-file (string-append #$output "/manifest") | |
550 | (lambda (p) | |
551 | (pretty-print '#$(manifest->gexp manifest) p))))) | |
552 | ||
553 | (gexp->derivation "profile" builder | |
554 | #:modules '((guix build union)) | |
555 | #:local-build? #t))) | |
cc4ecc2d LC |
556 | |
557 | (define (profile-regexp profile) | |
558 | "Return a regular expression that matches PROFILE's name and number." | |
559 | (make-regexp (string-append "^" (regexp-quote (basename profile)) | |
560 | "-([0-9]+)"))) | |
561 | ||
562 | (define (generation-number profile) | |
563 | "Return PROFILE's number or 0. An absolute file name must be used." | |
564 | (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) | |
565 | (basename (readlink profile)))) | |
566 | (compose string->number (cut match:substring <> 1))) | |
567 | 0)) | |
568 | ||
569 | (define (generation-numbers profile) | |
570 | "Return the sorted list of generation numbers of PROFILE, or '(0) if no | |
571 | former profiles were found." | |
572 | (define* (scandir name #:optional (select? (const #t)) | |
573 | (entry<? (@ (ice-9 i18n) string-locale<?))) | |
574 | ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. | |
575 | (define (enter? dir stat result) | |
576 | (and stat (string=? dir name))) | |
577 | ||
578 | (define (visit basename result) | |
579 | (if (select? basename) | |
580 | (cons basename result) | |
581 | result)) | |
582 | ||
583 | (define (leaf name stat result) | |
584 | (and result | |
585 | (visit (basename name) result))) | |
586 | ||
587 | (define (down name stat result) | |
588 | (visit "." '())) | |
589 | ||
590 | (define (up name stat result) | |
591 | (visit ".." result)) | |
592 | ||
593 | (define (skip name stat result) | |
594 | ;; All the sub-directories are skipped. | |
595 | (visit (basename name) result)) | |
596 | ||
597 | (define (error name* stat errno result) | |
598 | (if (string=? name name*) ; top-level NAME is unreadable | |
599 | result | |
600 | (visit (basename name*) result))) | |
601 | ||
602 | (and=> (file-system-fold enter? leaf down up skip error #f name lstat) | |
603 | (lambda (files) | |
604 | (sort files entry<?)))) | |
605 | ||
606 | (match (scandir (dirname profile) | |
607 | (cute regexp-exec (profile-regexp profile) <>)) | |
608 | (#f ; no profile directory | |
609 | '(0)) | |
610 | (() ; no profiles | |
611 | '(0)) | |
612 | ((profiles ...) ; former profiles around | |
613 | (sort (map (compose string->number | |
614 | (cut match:substring <> 1) | |
615 | (cute regexp-exec (profile-regexp profile) <>)) | |
616 | profiles) | |
617 | <)))) | |
618 | ||
f452e8ff AK |
619 | (define (profile-generations profile) |
620 | "Return a list of PROFILE's generations." | |
621 | (let ((generations (generation-numbers profile))) | |
622 | (if (equal? generations '(0)) | |
623 | '() | |
624 | generations))) | |
625 | ||
3ccde087 AK |
626 | (define* (relative-generation profile shift #:optional |
627 | (current (generation-number profile))) | |
628 | "Return PROFILE's generation shifted from the CURRENT generation by SHIFT. | |
629 | SHIFT is a positive or negative number. | |
630 | Return #f if there is no such generation." | |
631 | (let* ((abs-shift (abs shift)) | |
632 | (numbers (profile-generations profile)) | |
633 | (from-current (memq current | |
634 | (if (negative? shift) | |
635 | (reverse numbers) | |
636 | numbers)))) | |
637 | (and from-current | |
638 | (< abs-shift (length from-current)) | |
639 | (list-ref from-current abs-shift)))) | |
640 | ||
641 | (define* (previous-generation-number profile #:optional | |
642 | (number (generation-number profile))) | |
cc4ecc2d LC |
643 | "Return the number of the generation before generation NUMBER of |
644 | PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the | |
645 | case when generations have been deleted (there are \"holes\")." | |
3ccde087 AK |
646 | (or (relative-generation profile -1 number) |
647 | 0)) | |
cc4ecc2d LC |
648 | |
649 | (define (generation-file-name profile generation) | |
650 | "Return the file name for PROFILE's GENERATION." | |
651 | (format #f "~a-~a-link" profile generation)) | |
652 | ||
653 | (define (generation-time profile number) | |
654 | "Return the creation time of a generation in the UTC format." | |
655 | (make-time time-utc 0 | |
656 | (stat:ctime (stat (generation-file-name profile number))))) | |
657 | ||
658 | ;;; profiles.scm ends here |