guix/profiles.scm

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