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