guix/profiles.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
   5 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   6 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
   7 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
   8 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
   9 ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
  10 ;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  11 ;;;
  12 ;;; This file is part of GNU Guix.
  13 ;;;
  14 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  15 ;;; under the terms of the GNU General Public License as published by
  16 ;;; the Free Software Foundation; either version 3 of the License, or (at
  17 ;;; your option) any later version.
  18 ;;;
  19 ;;; GNU Guix is distributed in the hope that it will be useful, but
  20 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;;; GNU General Public License for more details.
  23 ;;;
  24 ;;; You should have received a copy of the GNU General Public License
  25 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 (define-module (guix profiles)
  28   #:use-module ((guix utils) #:hide (package-name->name+version))
  29   #:use-module ((guix build utils)
  30                 #:select (package-name->name+version))
  31   #:use-module (guix records)
  32   #:use-module (guix packages)
  33   #:use-module (guix derivations)
  34   #:use-module (guix search-paths)
  35   #:use-module (guix gexp)
  36   #:use-module (guix monads)
  37   #:use-module (guix store)
  38   #:use-module (ice-9 match)
  39   #:use-module (ice-9 regex)
  40   #:use-module (ice-9 ftw)
  41   #:use-module (ice-9 format)
  42   #:use-module (srfi srfi-1)
  43   #:use-module (srfi srfi-9)
  44   #:use-module (srfi srfi-11)
  45   #:use-module (srfi srfi-19)
  46   #:use-module (srfi srfi-26)
  47   #:use-module (srfi srfi-34)
  48   #:use-module (srfi srfi-35)
  49   #:export (&profile-error
  50             profile-error?
  51             profile-error-profile
  52             &profile-not-found-error
  53             profile-not-found-error?
  54             &missing-generation-error
  55             missing-generation-error?
  56             missing-generation-error-generation
  57
  58             manifest make-manifest
  59             manifest?
  60             manifest-entries
  61
  62             <manifest-entry>              ; FIXME: eventually make it internal
  63             manifest-entry
  64             manifest-entry?
  65             manifest-entry-name
  66             manifest-entry-version
  67             manifest-entry-output
  68             manifest-entry-item
  69             manifest-entry-dependencies
  70             manifest-entry-search-paths
  71             manifest-entry-parent
  72
  73             manifest-pattern
  74             manifest-pattern?
  75             manifest-pattern-name
  76             manifest-pattern-version
  77             manifest-pattern-output
  78
  79             manifest-remove
  80             manifest-add
  81             manifest-lookup
  82             manifest-installed?
  83             manifest-matching-entries
  84
  85             manifest-transaction
  86             manifest-transaction?
  87             manifest-transaction-install
  88             manifest-transaction-remove
  89             manifest-transaction-install-entry
  90             manifest-transaction-remove-pattern
  91             manifest-transaction-null?
  92             manifest-perform-transaction
  93             manifest-transaction-effects
  94
  95             profile-manifest
  96             package->manifest-entry
  97             packages->manifest
  98             ca-certificate-bundle
  99             %default-profile-hooks
 100             profile-derivation
 101
 102             generation-number
 103             generation-numbers
 104             profile-generations
 105             relative-generation-spec->number
 106             relative-generation
 107             previous-generation-number
 108             generation-time
 109             generation-file-name
 110             switch-to-generation
 111             roll-back
 112             delete-generation))
 113
 114 ;;; Commentary:
 115 ;;;
 116 ;;; Tools to create and manipulate profiles---i.e., the representation of a
 117 ;;; set of installed packages.
 118 ;;;
 119 ;;; Code:
 120
 121 \f
 122 ;;;
 123 ;;; Condition types.
 124 ;;;
 125
 126 (define-condition-type &profile-error &error
 127   profile-error?
 128   (profile profile-error-profile))
 129
 130 (define-condition-type &profile-not-found-error &profile-error
 131   profile-not-found-error?)
 132
 133 (define-condition-type &missing-generation-error &profile-error
 134   missing-generation-error?
 135   (generation missing-generation-error-generation))
 136
 137 \f
 138 ;;;
 139 ;;; Manifests.
 140 ;;;
 141
 142 (define-record-type <manifest>
 143   (manifest entries)
 144   manifest?
 145   (entries manifest-entries))                     ; list of <manifest-entry>
 146
 147 ;; Convenient alias, to avoid name clashes.
 148 (define make-manifest manifest)
 149
 150 (define-record-type* <manifest-entry> manifest-entry
 151   make-manifest-entry
 152   manifest-entry?
 153   (name         manifest-entry-name)              ; string
 154   (version      manifest-entry-version)           ; string
 155   (output       manifest-entry-output             ; string
 156                 (default "out"))
 157   (item         manifest-entry-item)              ; package | store path
 158   (dependencies manifest-entry-dependencies       ; <manifest-entry>*
 159                 (default '()))
 160   (search-paths manifest-entry-search-paths       ; search-path-specification*
 161                 (default '()))
 162   (parent       manifest-entry-parent        ; promise (#f | <manifest-entry>)
 163                 (default (delay #f))))
 164
 165 (define-record-type* <manifest-pattern> manifest-pattern
 166   make-manifest-pattern
 167   manifest-pattern?
 168   (name         manifest-pattern-name)            ; string
 169   (version      manifest-pattern-version          ; string | #f
 170                 (default #f))
 171   (output       manifest-pattern-output           ; string | #f
 172                 (default "out")))
 173
 174 (define (profile-manifest profile)
 175   "Return the PROFILE's manifest."
 176   (let ((file (string-append profile "/manifest")))
 177     (if (file-exists? file)
 178         (call-with-input-file file read-manifest)
 179         (manifest '()))))
 180
 181 (define* (package->manifest-entry package #:optional (output "out")
 182                                   #:key (parent (delay #f)))
 183   "Return a manifest entry for the OUTPUT of package PACKAGE."
 184   ;; For each dependency, keep a promise pointing to its "parent" entry.
 185   (letrec* ((deps  (map (match-lambda
 186                           ((label package)
 187                            (package->manifest-entry package
 188                                                     #:parent (delay entry)))
 189                           ((label package output)
 190                            (package->manifest-entry package output
 191                                                     #:parent (delay entry))))
 192                         (package-propagated-inputs package)))
 193             (entry (manifest-entry
 194                      (name (package-name package))
 195                      (version (package-version package))
 196                      (output output)
 197                      (item package)
 198                      (dependencies (delete-duplicates deps))
 199                      (search-paths
 200                       (package-transitive-native-search-paths package))
 201                      (parent parent))))
 202     entry))
 203
 204 (define (packages->manifest packages)
 205   "Return a list of manifest entries, one for each item listed in PACKAGES.
 206 Elements of PACKAGES can be either package objects or package/string tuples
 207 denoting a specific output of a package."
 208   (manifest
 209    (map (match-lambda
 210          ((package output)
 211           (package->manifest-entry package output))
 212          ((? package? package)
 213           (package->manifest-entry package)))
 214         packages)))
 215
 216 (define (manifest->gexp manifest)
 217   "Return a representation of MANIFEST as a gexp."
 218   (define (entry->gexp entry)
 219     (match entry
 220       (($ <manifest-entry> name version output (? string? path)
 221                            (deps ...) (search-paths ...))
 222        #~(#$name #$version #$output #$path
 223                  (propagated-inputs #$(map entry->gexp deps))
 224                  (search-paths #$(map search-path-specification->sexp
 225                                       search-paths))))
 226       (($ <manifest-entry> name version output (? package? package)
 227                            (deps ...) (search-paths ...))
 228        #~(#$name #$version #$output
 229                  (ungexp package (or output "out"))
 230                  (propagated-inputs #$(map entry->gexp deps))
 231                  (search-paths #$(map search-path-specification->sexp
 232                                       search-paths))))))
 233
 234   (match manifest
 235     (($ <manifest> (entries ...))
 236      #~(manifest (version 3)
 237                  (packages #$(map entry->gexp entries))))))
 238
 239 (define (find-package name version)
 240   "Return a package from the distro matching NAME and possibly VERSION.  This
 241 procedure is here for backward-compatibility and will eventually vanish."
 242   (define find-best-packages-by-name              ;break abstractions
 243     (module-ref (resolve-interface '(gnu packages))
 244                 'find-best-packages-by-name))
 245
 246    ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the
 247    ;; former traverses the module tree only once and then allows for efficient
 248    ;; access via a vhash.
 249    (match (find-best-packages-by-name name version)
 250      ((p _ ...) p)
 251      (_
 252       (match (find-best-packages-by-name name #f)
 253         ((p _ ...) p)
 254         (_ #f)))))
 255
 256 (define (sexp->manifest sexp)
 257   "Parse SEXP as a manifest."
 258   (define (infer-search-paths name version)
 259     ;; Infer the search path specifications for NAME-VERSION by looking up a
 260     ;; same-named package in the distro.  Useful for the old manifest formats
 261     ;; that did not store search path info.
 262     (let ((package (find-package name version)))
 263       (if package
 264           (package-native-search-paths package)
 265           '())))
 266
 267   (define (infer-dependency item parent)
 268     ;; Return a <manifest-entry> for ITEM.
 269     (let-values (((name version)
 270                   (package-name->name+version
 271                    (store-path-package-name item))))
 272       (manifest-entry
 273         (name name)
 274         (version version)
 275         (item item)
 276         (parent parent))))
 277
 278   (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
 279     (match sexp
 280       ((name version output path
 281              ('propagated-inputs deps)
 282              ('search-paths search-paths)
 283              extra-stuff ...)
 284        ;; For each of DEPS, keep a promise pointing to ENTRY.
 285        (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry))
 286                              deps))
 287                  (entry (manifest-entry
 288                           (name name)
 289                           (version version)
 290                           (output output)
 291                           (item path)
 292                           (dependencies deps*)
 293                           (search-paths (map sexp->search-path-specification
 294                                              search-paths))
 295                           (parent parent))))
 296          entry))))
 297
 298   (match sexp
 299     (('manifest ('version 0)
 300                 ('packages ((name version output path) ...)))
 301      (manifest
 302       (map (lambda (name version output path)
 303              (manifest-entry
 304                (name name)
 305                (version version)
 306                (output output)
 307                (item path)
 308                (search-paths (infer-search-paths name version))))
 309            name version output path)))
 310
 311     ;; Version 1 adds a list of propagated inputs to the
 312     ;; name/version/output/path tuples.
 313     (('manifest ('version 1)
 314                 ('packages ((name version output path deps) ...)))
 315      (manifest
 316       (map (lambda (name version output path deps)
 317              ;; Up to Guix 0.7 included, dependencies were listed as ("gmp"
 318              ;; "/gnu/store/...-gmp") for instance.  Discard the 'label' in
 319              ;; such lists.
 320              (let ((deps (match deps
 321                            (((labels directories) ...)
 322                             directories)
 323                            ((directories ...)
 324                             directories))))
 325                (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
 326                                      deps))
 327                          (entry (manifest-entry
 328                                   (name name)
 329                                   (version version)
 330                                   (output output)
 331                                   (item path)
 332                                   (dependencies deps*)
 333                                   (search-paths
 334                                    (infer-search-paths name version)))))
 335                  entry)))
 336            name version output path deps)))
 337
 338     ;; Version 2 adds search paths and is slightly more verbose.
 339     (('manifest ('version 2 minor-version ...)
 340                 ('packages ((name version output path
 341                                   ('propagated-inputs deps)
 342                                   ('search-paths search-paths)
 343                                   extra-stuff ...)
 344                             ...)))
 345      (manifest
 346       (map (lambda (name version output path deps search-paths)
 347              (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
 348                                    deps))
 349                        (entry (manifest-entry
 350                                 (name name)
 351                                 (version version)
 352                                 (output output)
 353                                 (item path)
 354                                 (dependencies deps*)
 355                                 (search-paths
 356                                  (map sexp->search-path-specification
 357                                       search-paths)))))
 358                entry))
 359            name version output path deps search-paths)))
 360
 361     ;; Version 3 represents DEPS as full-blown manifest entries.
 362     (('manifest ('version 3 minor-version ...)
 363                 ('packages (entries ...)))
 364      (manifest (map sexp->manifest-entry entries)))
 365     (_
 366      (raise (condition
 367              (&message (message "unsupported manifest format")))))))
 368
 369 (define (read-manifest port)
 370   "Return the packages listed in MANIFEST."
 371   (sexp->manifest (read port)))
 372
 373 (define (entry-predicate pattern)
 374   "Return a procedure that returns #t when passed a manifest entry that
 375 matches NAME/OUTPUT/VERSION.  OUTPUT and VERSION may be #f, in which case they
 376 are ignored."
 377   (match pattern
 378     (($ <manifest-pattern> name version output)
 379      (match-lambda
 380       (($ <manifest-entry> entry-name entry-version entry-output)
 381        (and (string=? entry-name name)
 382             (or (not entry-output) (not output)
 383                 (string=? entry-output output))
 384             (or (not version)
 385                 (string=? entry-version version))))))))
 386
 387 (define (manifest-remove manifest patterns)
 388   "Remove entries for each of PATTERNS from MANIFEST.  Each item in PATTERNS
 389 must be a manifest-pattern."
 390   (define (remove-entry pattern lst)
 391     (remove (entry-predicate pattern) lst))
 392
 393   (make-manifest (fold remove-entry
 394                        (manifest-entries manifest)
 395                        patterns)))
 396
 397 (define (manifest-add manifest entries)
 398   "Add a list of manifest ENTRIES to MANIFEST and return new manifest.
 399 Remove MANIFEST entries that have the same name and output as ENTRIES."
 400   (define (same-entry? entry name output)
 401     (match entry
 402       (($ <manifest-entry> entry-name _ entry-output _ ...)
 403        (and (equal? name entry-name)
 404             (equal? output entry-output)))))
 405
 406   (make-manifest
 407    (append entries
 408            (fold (lambda (entry result)
 409                    (match entry
 410                      (($ <manifest-entry> name _ out _ ...)
 411                       (filter (negate (cut same-entry? <> name out))
 412                               result))))
 413                  (manifest-entries manifest)
 414                  entries))))
 415
 416 (define (manifest-lookup manifest pattern)
 417   "Return the first item of MANIFEST that matches PATTERN, or #f if there is
 418 no match.."
 419   (find (entry-predicate pattern)
 420         (manifest-entries manifest)))
 421
 422 (define (manifest-installed? manifest pattern)
 423   "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
 424 #f otherwise."
 425   (->bool (manifest-lookup manifest pattern)))
 426
 427 (define (manifest-matching-entries manifest patterns)
 428   "Return all the entries of MANIFEST that match one of the PATTERNS."
 429   (define predicates
 430     (map entry-predicate patterns))
 431
 432   (define (matches? entry)
 433     (any (lambda (pred)
 434            (pred entry))
 435          predicates))
 436
 437   (filter matches? (manifest-entries manifest)))
 438
 439 \f
 440 ;;;
 441 ;;; Manifest transactions.
 442 ;;;
 443
 444 (define-record-type* <manifest-transaction> manifest-transaction
 445   make-manifest-transaction
 446   manifest-transaction?
 447   (install manifest-transaction-install ; list of <manifest-entry>
 448            (default '()))
 449   (remove  manifest-transaction-remove  ; list of <manifest-pattern>
 450            (default '())))
 451
 452 (define (manifest-transaction-install-entry entry transaction)
 453   "Augment TRANSACTION's set of installed packages with ENTRY, a
 454 <manifest-entry>."
 455   (manifest-transaction
 456    (inherit transaction)
 457    (install
 458     (cons entry (manifest-transaction-install transaction)))))
 459
 460 (define (manifest-transaction-remove-pattern pattern transaction)
 461   "Add PATTERN to TRANSACTION's list of packages to remove."
 462   (manifest-transaction
 463    (inherit transaction)
 464    (remove
 465     (cons pattern (manifest-transaction-remove transaction)))))
 466
 467 (define (manifest-transaction-null? transaction)
 468   "Return true if TRANSACTION has no effect---i.e., it neither installs nor
 469 remove software."
 470   (match transaction
 471     (($ <manifest-transaction> () ()) #t)
 472     (($ <manifest-transaction> _ _)   #f)))
 473
 474 (define (manifest-transaction-effects manifest transaction)
 475   "Compute the effect of applying TRANSACTION to MANIFEST.  Return 4 values:
 476 the list of packages that would be removed, installed, upgraded, or downgraded
 477 when applying TRANSACTION to MANIFEST.  Upgrades are represented as pairs
 478 where the head is the entry being upgraded and the tail is the entry that will
 479 replace it."
 480   (define (manifest-entry->pattern entry)
 481     (manifest-pattern
 482       (name   (manifest-entry-name entry))
 483       (output (manifest-entry-output entry))))
 484
 485   (let loop ((input     (manifest-transaction-install transaction))
 486              (install   '())
 487              (upgrade   '())
 488              (downgrade '()))
 489     (match input
 490       (()
 491        (let ((remove (manifest-transaction-remove transaction)))
 492          (values (manifest-matching-entries manifest remove)
 493                  (reverse install) (reverse upgrade) (reverse downgrade))))
 494       ((entry rest ...)
 495        ;; Check whether installing ENTRY corresponds to the installation of a
 496        ;; new package or to an upgrade.
 497
 498        ;; XXX: When the exact same output directory is installed, we're not
 499        ;; really upgrading anything.  Add a check for that case.
 500        (let* ((pattern  (manifest-entry->pattern entry))
 501               (previous (manifest-lookup manifest pattern))
 502               (newer?   (and previous
 503                              (version>=? (manifest-entry-version entry)
 504                                          (manifest-entry-version previous)))))
 505          (loop rest
 506                (if previous install (cons entry install))
 507                (if (and previous newer?)
 508                    (alist-cons previous entry upgrade)
 509                    upgrade)
 510                (if (and previous (not newer?))
 511                    (alist-cons previous entry downgrade)
 512                    downgrade)))))))
 513
 514 (define (manifest-perform-transaction manifest transaction)
 515   "Perform TRANSACTION on MANIFEST and return the new manifest."
 516   (let ((install (manifest-transaction-install transaction))
 517         (remove  (manifest-transaction-remove transaction)))
 518     (manifest-add (manifest-remove manifest remove)
 519                   install)))
 520
 521 \f
 522 ;;;
 523 ;;; Profiles.
 524 ;;;
 525
 526 (define (manifest-inputs manifest)
 527   "Return a list of <gexp-input> objects for MANIFEST."
 528   (define entry->input
 529     (match-lambda
 530       (($ <manifest-entry> name version output thing deps)
 531        ;; THING may be a package or a file name.  In the latter case, assume
 532        ;; it's already valid.
 533        (cons (gexp-input thing output)
 534              (append-map entry->input deps)))))
 535
 536   (append-map entry->input (manifest-entries manifest)))
 537
 538 (define* (manifest-lookup-package manifest name #:optional version)
 539   "Return as a monadic value the first package or store path referenced by
 540 MANIFEST that is named NAME and optionally has the given VERSION prefix, or #f
 541 if not found."
 542   ;; Return as a monadic value the package or store path referenced by the
 543   ;; manifest ENTRY, or #f if not referenced.
 544   (define (entry-lookup-package entry)
 545     (define (find-among-inputs inputs)
 546       (find (lambda (input)
 547               (and (package? input)
 548                    (equal? name (package-name input))
 549                    (if version
 550                        (string-prefix? version (package-version input))
 551                        #t)))
 552             inputs))
 553     (define (find-among-store-items items)
 554       (find (lambda (item)
 555               (let-values (((name* version*)
 556                             (package-name->name+version
 557                              (store-path-package-name item))))
 558                 (and (string=? name name*)
 559                      (if version
 560                          (string-prefix? version version*)
 561                          #t))))
 562             items))
 563
 564     (with-monad %store-monad
 565       (match (manifest-entry-item entry)
 566         ((? package? package)
 567          (match (cons (list (package-name package) package)
 568                       (package-transitive-inputs package))
 569            (((labels inputs . _) ...)
 570             (return (find-among-inputs inputs)))))
 571         ((? string? item)
 572          (mlet %store-monad ((refs (references* item)))
 573            (return (find-among-store-items refs)))))))
 574
 575   (anym %store-monad
 576         entry-lookup-package (manifest-entries manifest)))
 577
 578 (define (info-dir-file manifest)
 579   "Return a derivation that builds the 'dir' file for all the entries of
 580 MANIFEST."
 581   (define texinfo                                 ;lazy reference
 582     (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
 583   (define gzip                                    ;lazy reference
 584     (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
 585
 586   (define build
 587     (with-imported-modules '((guix build utils))
 588       #~(begin
 589           (use-modules (guix build utils)
 590                        (srfi srfi-1) (srfi srfi-26)
 591                        (ice-9 ftw))
 592
 593           (define (info-file? file)
 594             (or (string-suffix? ".info" file)
 595                 (string-suffix? ".info.gz" file)))
 596
 597           (define (info-files top)
 598             (let ((infodir (string-append top "/share/info")))
 599               (map (cut string-append infodir "/" <>)
 600                    (or (scandir infodir info-file?) '()))))
 601
 602           (define (install-info info)
 603             (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
 604             (zero?
 605              (system* (string-append #+texinfo "/bin/install-info") "--silent"
 606                       info (string-append #$output "/share/info/dir"))))
 607
 608           (mkdir-p (string-append #$output "/share/info"))
 609           (exit (every install-info
 610                        (append-map info-files
 611                                    '#$(manifest-inputs manifest)))))))
 612
 613   (gexp->derivation "info-dir" build
 614                     #:local-build? #t
 615                     #:substitutable? #f))
 616
 617 (define (ghc-package-cache-file manifest)
 618   "Return a derivation that builds the GHC 'package.cache' file for all the
 619 entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
 620   (define ghc                                     ;lazy reference
 621     (module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
 622
 623   (define build
 624     (with-imported-modules '((guix build utils))
 625       #~(begin
 626           (use-modules (guix build utils)
 627                        (srfi srfi-1) (srfi srfi-26)
 628                        (ice-9 ftw))
 629
 630           (define ghc-name-version
 631             (let* ((base (basename #+ghc)))
 632               (string-drop base
 633                            (+ 1 (string-index base #\-)))))
 634
 635           (define db-subdir
 636             (string-append "lib/" ghc-name-version "/package.conf.d"))
 637
 638           (define db-dir
 639             (string-append #$output "/" db-subdir))
 640
 641           (define (conf-files top)
 642             (let ((db (string-append top "/" db-subdir)))
 643               (if (file-exists? db)
 644                   (find-files db "\\.conf$")
 645                   '())))
 646
 647           (define (copy-conf-file conf)
 648             (let ((base (basename conf)))
 649               (copy-file conf (string-append db-dir "/" base))))
 650
 651           (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
 652           (for-each copy-conf-file
 653                     (append-map conf-files
 654                                 (delete-duplicates
 655                                  '#$(manifest-inputs manifest))))
 656           (let ((success
 657                  (zero?
 658                   (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
 659                            (string-append "--package-db=" db-dir)))))
 660             (for-each delete-file (find-files db-dir "\\.conf$"))
 661             (exit success)))))
 662
 663   (with-monad %store-monad
 664     ;; Don't depend on GHC when there's nothing to do.
 665     (if (any (cut string-prefix? "ghc" <>)
 666              (map manifest-entry-name (manifest-entries manifest)))
 667         (gexp->derivation "ghc-package-cache" build
 668                           #:local-build? #t
 669                           #:substitutable? #f)
 670         (return #f))))
 671
 672 (define (ca-certificate-bundle manifest)
 673   "Return a derivation that builds a single-file bundle containing the CA
 674 certificates in the /etc/ssl/certs sub-directories of the packages in
 675 MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
 676   ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html>
 677   ;; for a discussion.
 678
 679   (define glibc-utf8-locales                      ;lazy reference
 680     (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
 681
 682   (define build
 683     (with-imported-modules '((guix build utils))
 684       #~(begin
 685           (use-modules (guix build utils)
 686                        (rnrs io ports)
 687                        (srfi srfi-1)
 688                        (srfi srfi-26)
 689                        (ice-9 ftw)
 690                        (ice-9 match))
 691
 692           (define (pem-file? file)
 693             (string-suffix? ".pem" file))
 694
 695           (define (ca-files top)
 696             (let ((cert-dir (string-append top "/etc/ssl/certs")))
 697               (map (cut string-append cert-dir "/" <>)
 698                    (or (scandir cert-dir pem-file?) '()))))
 699
 700           (define (concatenate-files files result)
 701             "Make RESULT the concatenation of all of FILES."
 702             (define (dump file port)
 703               (display (call-with-input-file file get-string-all)
 704                        port)
 705               (newline port))  ;required, see <https://bugs.debian.org/635570>
 706
 707             (call-with-output-file result
 708               (lambda (port)
 709                 (for-each (cut dump <> port) files))))
 710
 711           ;; Some file names in the NSS certificates are UTF-8 encoded so
 712           ;; install a UTF-8 locale.
 713           (setenv "LOCPATH"
 714                   (string-append #+glibc-utf8-locales "/lib/locale/"
 715                                  #+(package-version glibc-utf8-locales)))
 716           (setlocale LC_ALL "en_US.utf8")
 717
 718           (match (append-map ca-files '#$(manifest-inputs manifest))
 719             (()
 720              ;; Since there are no CA files, just create an empty directory.  Do
 721              ;; not create the etc/ssl/certs sub-directory, since that would
 722              ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be
 723              ;; defined.
 724              (mkdir #$output)
 725              #t)
 726             ((ca-files ...)
 727              (let ((result (string-append #$output "/etc/ssl/certs")))
 728                (mkdir-p result)
 729                (concatenate-files ca-files
 730                                   (string-append result
 731                                                  "/ca-certificates.crt"))
 732                #t))))))
 733
 734   (gexp->derivation "ca-certificate-bundle" build
 735                     #:local-build? #t
 736                     #:substitutable? #f))
 737
 738 (define (gtk-icon-themes manifest)
 739   "Return a derivation that unions all icon themes from manifest entries and
 740 creates the GTK+ 'icon-theme.cache' file for each theme."
 741   (define gtk+  ; lazy reference
 742     (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+))
 743
 744   (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+"))
 745                       ;; XXX: Can't use gtk-update-icon-cache corresponding
 746                       ;; to the gtk+ referenced by 'manifest'.  Because
 747                       ;; '%gtk+' can be either a package or store path, and
 748                       ;; there's no way to get the "bin" output for the later.
 749                       (gtk-update-icon-cache
 750                        -> #~(string-append #+gtk+:bin
 751                                            "/bin/gtk-update-icon-cache")))
 752
 753     (define build
 754       (with-imported-modules '((guix build utils)
 755                                (guix build union)
 756                                (guix build profiles)
 757                                (guix search-paths)
 758                                (guix records))
 759         #~(begin
 760             (use-modules (guix build utils)
 761                          (guix build union)
 762                          (guix build profiles)
 763                          (srfi srfi-26)
 764                          (ice-9 ftw))
 765
 766             (let* ((destdir  (string-append #$output "/share/icons"))
 767                    (icondirs (filter file-exists?
 768                                      (map (cut string-append <> "/share/icons")
 769                                           '#$(manifest-inputs manifest)))))
 770
 771               ;; Union all the icons.
 772               (mkdir-p (string-append #$output "/share"))
 773               (union-build destdir icondirs
 774                            #:log-port (%make-void-port "w"))
 775
 776               ;; Update the 'icon-theme.cache' file for each icon theme.
 777               (for-each
 778                (lambda (theme)
 779                  (let ((dir (string-append destdir "/" theme)))
 780                    ;; Occasionally DESTDIR contains plain files, such as
 781                    ;; "abiword_48.png".  Ignore these.
 782                    (when (file-is-directory? dir)
 783                      (ensure-writable-directory dir)
 784                      (system* #+gtk-update-icon-cache "-t" dir "--quiet"))))
 785                (scandir destdir (negate (cut member <> '("." "..")))))))))
 786
 787     ;; Don't run the hook when there's nothing to do.
 788     (if %gtk+
 789         (gexp->derivation "gtk-icon-themes" build
 790                           #:local-build? #t
 791                           #:substitutable? #f)
 792         (return #f))))
 793
 794 (define (gtk-im-modules manifest)
 795   "Return a derivation that builds the cache files for input method modules
 796 for both major versions of GTK+."
 797
 798   (mlet %store-monad ((gtk+   (manifest-lookup-package manifest "gtk+" "3"))
 799                       (gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
 800
 801     (define (build gtk gtk-version query)
 802       (let ((major (string-take gtk-version 1)))
 803         (with-imported-modules '((guix build utils)
 804                                  (guix build union)
 805                                  (guix build profiles)
 806                                  (guix search-paths)
 807                                  (guix records))
 808           #~(begin
 809               (use-modules (guix build utils)
 810                            (guix build union)
 811                            (guix build profiles)
 812                            (ice-9 popen)
 813                            (srfi srfi-1)
 814                            (srfi srfi-26))
 815
 816               (let* ((prefix  (string-append "/lib/gtk-" #$major ".0/"
 817                                              #$gtk-version))
 818                      (destdir (string-append #$output prefix))
 819                      (moddirs (cons (string-append #$gtk prefix "/immodules")
 820                                     (filter file-exists?
 821                                             (map (cut string-append <> prefix "/immodules")
 822                                                  '#$(manifest-inputs manifest)))))
 823                      (modules (append-map (cut find-files <> "\\.so$")
 824                                           moddirs)))
 825
 826                 ;; Generate a new immodules cache file.
 827                 (mkdir-p (string-append #$output prefix))
 828                 (let ((pipe    (apply open-pipe* OPEN_READ #$query modules))
 829                       (outfile (string-append #$output prefix
 830                                               "/immodules-gtk" #$major ".cache")))
 831                   (dynamic-wind
 832                     (const #t)
 833                     (lambda ()
 834                       (call-with-output-file outfile
 835                         (lambda (out)
 836                           (while (not (eof-object? (peek-char pipe)))
 837                             (write-char (read-char pipe) out))))
 838                       #t)
 839                     (lambda ()
 840                       (close-pipe pipe)))))))))
 841
 842     ;; Don't run the hook when there's nothing to do.
 843     (let* ((pkg-gtk+ (module-ref        ; lazy reference
 844                       (resolve-interface '(gnu packages gtk)) 'gtk+))
 845            (gexp #~(begin
 846                      #$(if gtk+
 847                            (build
 848                             gtk+ "3.0.0"
 849                             ;; Use 'gtk-query-immodules-3.0' from the 'bin'
 850                             ;; output of latest gtk+ package.
 851                             #~(string-append
 852                                #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0"))
 853                            #t)
 854                      #$(if gtk+-2
 855                            (build
 856                             gtk+-2 "2.10.0"
 857                             #~(string-append
 858                                #$gtk+-2 "/bin/gtk-query-immodules-2.0"))
 859                            #t))))
 860       (if (or gtk+ gtk+-2)
 861           (gexp->derivation "gtk-im-modules" gexp
 862                             #:local-build? #t
 863                             #:substitutable? #f)
 864           (return #f)))))
 865
 866 (define (xdg-desktop-database manifest)
 867   "Return a derivation that builds the @file{mimeinfo.cache} database from
 868 desktop files.  It's used to query what applications can handle a given
 869 MIME type."
 870   (mlet %store-monad ((desktop-file-utils
 871                        (manifest-lookup-package
 872                         manifest "desktop-file-utils")))
 873     (define build
 874       (with-imported-modules '((guix build utils)
 875                                (guix build union))
 876         #~(begin
 877             (use-modules (srfi srfi-26)
 878                          (guix build utils)
 879                          (guix build union))
 880             (let* ((destdir (string-append #$output "/share/applications"))
 881                    (appdirs (filter file-exists?
 882                                     (map (cut string-append <>
 883                                               "/share/applications")
 884                                          '#$(manifest-inputs manifest))))
 885                    (update-desktop-database (string-append
 886                                              #+desktop-file-utils
 887                                              "/bin/update-desktop-database")))
 888               (mkdir-p (string-append #$output "/share"))
 889               (union-build destdir appdirs
 890                            #:log-port (%make-void-port "w"))
 891               (exit (zero? (system* update-desktop-database destdir)))))))
 892
 893     ;; Don't run the hook when 'desktop-file-utils' is not referenced.
 894     (if desktop-file-utils
 895         (gexp->derivation "xdg-desktop-database" build
 896                           #:local-build? #t
 897                           #:substitutable? #f)
 898         (return #f))))
 899
 900 (define (xdg-mime-database manifest)
 901   "Return a derivation that builds the @file{mime.cache} database from manifest
 902 entries.  It's used to query the MIME type of a given file."
 903   (define shared-mime-info  ; lazy reference
 904     (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
 905
 906   (mlet %store-monad ((glib
 907                        (manifest-lookup-package
 908                         manifest "glib")))
 909     (define build
 910       (with-imported-modules  '((guix build utils)
 911                                 (guix build union))
 912         #~(begin
 913             (use-modules (srfi srfi-26)
 914                          (guix build utils)
 915                          (guix build union))
 916             (let* ((datadir (string-append #$output "/share"))
 917                    (destdir (string-append datadir "/mime"))
 918                    (pkgdirs (filter file-exists?
 919                                     (map (cut string-append <>
 920                                               "/share/mime/packages")
 921                                          (cons #+shared-mime-info
 922                                                '#$(manifest-inputs manifest)))))
 923                    (update-mime-database (string-append
 924                                           #+shared-mime-info
 925                                           "/bin/update-mime-database")))
 926               (mkdir-p destdir)
 927               (union-build (string-append destdir "/packages") pkgdirs
 928                            #:log-port (%make-void-port "w"))
 929               (setenv "XDG_DATA_HOME" datadir)
 930               (exit (zero? (system* update-mime-database destdir)))))))
 931
 932     ;; Don't run the hook when there are no GLib based applications.
 933     (if glib
 934         (gexp->derivation "xdg-mime-database" build
 935                           #:local-build? #t
 936                           #:substitutable? #f)
 937         (return #f))))
 938
 939 ;; Several font packages may install font files into same directory, so
 940 ;; fonts.dir and fonts.scale file should be generated here, instead of in
 941 ;; packages.
 942 (define (fonts-dir-file manifest)
 943   "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
 944 files for the fonts of the @var{manifest} entries."
 945   (define mkfontscale
 946     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
 947
 948   (define mkfontdir
 949     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir))
 950
 951   (define build
 952     #~(begin
 953         (use-modules (srfi srfi-26)
 954                      (guix build utils)
 955                      (guix build union))
 956         (let ((fonts-dirs (filter file-exists?
 957                                   (map (cut string-append <>
 958                                             "/share/fonts")
 959                                        '#$(manifest-inputs manifest)))))
 960           (mkdir #$output)
 961           (if (null? fonts-dirs)
 962               (exit #t)
 963               (let* ((share-dir   (string-append #$output "/share"))
 964                      (fonts-dir   (string-append share-dir "/fonts"))
 965                      (mkfontscale (string-append #+mkfontscale
 966                                                  "/bin/mkfontscale"))
 967                      (mkfontdir   (string-append #+mkfontdir
 968                                                  "/bin/mkfontdir"))
 969                      (empty-file? (lambda (filename)
 970                                     (call-with-ascii-input-file filename
 971                                       (lambda (p)
 972                                         (eqv? #\0 (read-char p))))))
 973                      (fonts-dir-file "fonts.dir")
 974                      (fonts-scale-file "fonts.scale"))
 975                 (mkdir-p share-dir)
 976                 ;; Create all sub-directories, because we may create fonts.dir
 977                 ;; and fonts.scale files in the sub-directories.
 978                 (union-build fonts-dir fonts-dirs
 979                              #:log-port (%make-void-port "w")
 980                              #:create-all-directories? #t)
 981                 (let ((directories (find-files fonts-dir
 982                                                (lambda (file stat)
 983                                                  (eq? 'directory (stat:type stat)))
 984                                                #:directories? #t)))
 985                   (for-each (lambda (dir)
 986                               (with-directory-excursion dir
 987                                 (when (file-exists? fonts-scale-file)
 988                                   (delete-file fonts-scale-file))
 989                                 (when (file-exists? fonts-dir-file)
 990                                   (delete-file fonts-dir-file))
 991                                 (unless (and (zero? (system* mkfontscale))
 992                                              (zero? (system* mkfontdir)))
 993                                   (exit #f))
 994                                 (when (empty-file? fonts-scale-file)
 995                                   (delete-file fonts-scale-file))
 996                                 (when (empty-file? fonts-dir-file)
 997                                   (delete-file fonts-dir-file))))
 998                             directories)))))))
 999
1000   (gexp->derivation "fonts-dir" build
1001                     #:modules '((guix build utils)
1002                                 (guix build union)
1003                                 (srfi srfi-26))
1004                     #:local-build? #t
1005                     #:substitutable? #f))
1006
1007 (define (manual-database manifest)
1008   "Return a derivation that builds the manual page database (\"mandb\") for
1009 the entries in MANIFEST."
1010   (define man-db                                  ;lazy reference
1011     (module-ref (resolve-interface '(gnu packages man)) 'man-db))
1012
1013   (define build
1014     #~(begin
1015         (use-modules (guix build utils)
1016                      (srfi srfi-1)
1017                      (srfi srfi-19)
1018                      (srfi srfi-26))
1019
1020         (define entries
1021           (filter-map (lambda (directory)
1022                         (let ((man (string-append directory "/share/man")))
1023                           (and (directory-exists? man)
1024                                man)))
1025                       '#$(manifest-inputs manifest)))
1026
1027         (define manpages-collection-dir
1028           (string-append (getenv "PWD") "/manpages-collection"))
1029
1030         (define man-directory
1031           (string-append #$output "/share/man"))
1032
1033         (define (get-manpage-tail-path manpage-path)
1034           (let ((index (string-contains manpage-path "/share/man/")))
1035             (unless index
1036               (error "Manual path doesn't contain \"/share/man/\":"
1037                      manpage-path))
1038             (string-drop manpage-path (+ index (string-length "/share/man/")))))
1039
1040         (define (populate-manpages-collection-dir entries)
1041           (let ((manpages (append-map (cut find-files <> #:stat stat) entries)))
1042             (for-each (lambda (manpage)
1043                         (let* ((dest-file (string-append
1044                                            manpages-collection-dir "/"
1045                                            (get-manpage-tail-path manpage))))
1046                           (mkdir-p (dirname dest-file))
1047                           (catch 'system-error
1048                             (lambda ()
1049                               (symlink manpage dest-file))
1050                             (lambda args
1051                               ;; Different packages may contain the same
1052                               ;; manpage.  Simply ignore the symlink error.
1053                               #t))))
1054                       manpages)))
1055
1056         (mkdir-p manpages-collection-dir)
1057         (populate-manpages-collection-dir entries)
1058
1059         ;; Create a mandb config file which contains a custom made
1060         ;; manpath. The associated catpath is the location where the database
1061         ;; gets generated.
1062         (copy-file #+(file-append man-db "/etc/man_db.conf")
1063                    "man_db.conf")
1064         (substitute* "man_db.conf"
1065           (("MANDB_MAP  /usr/man                /var/cache/man/fsstnd")
1066            (string-append "MANDB_MAP " manpages-collection-dir " "
1067                           man-directory)))
1068
1069         (mkdir-p man-directory)
1070         (setenv "MANPATH" (string-join entries ":"))
1071
1072         (format #t "Creating manual page database for ~a packages... "
1073                 (length entries))
1074         (force-output)
1075         (let* ((start-time (current-time))
1076                (exit-status (system* #+(file-append man-db "/bin/mandb")
1077                                     "--quiet" "--create"
1078                                     "-C" "man_db.conf"))
1079                (duration (time-difference (current-time) start-time)))
1080           (format #t "done in ~,3f s~%"
1081                   (+ (time-second duration)
1082                      (* (time-nanosecond duration) (expt 10 -9))))
1083           (force-output)
1084           (zero? exit-status))))
1085
1086   (gexp->derivation "manual-database" build
1087                     #:modules '((guix build utils)
1088                                 (srfi srfi-19)
1089                                 (srfi srfi-26))
1090                     #:local-build? #t))
1091
1092 (define %default-profile-hooks
1093   ;; This is the list of derivation-returning procedures that are called by
1094   ;; default when making a non-empty profile.
1095   (list info-dir-file
1096         manual-database
1097         fonts-dir-file
1098         ghc-package-cache-file
1099         ca-certificate-bundle
1100         gtk-icon-themes
1101         gtk-im-modules
1102         xdg-desktop-database
1103         xdg-mime-database))
1104
1105 (define* (profile-derivation manifest
1106                              #:key
1107                              (hooks %default-profile-hooks)
1108                              (locales? #t)
1109                              system target)
1110   "Return a derivation that builds a profile (aka. 'user environment') with
1111 the given MANIFEST.  The profile includes additional derivations returned by
1112 the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
1113
1114 When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
1115 a dependency on the 'glibc-utf8-locales' package.
1116
1117 When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
1118 are cross-built for TARGET."
1119   (mlet %store-monad ((system (if system
1120                                   (return system)
1121                                   (current-system)))
1122                       (extras (if (null? (manifest-entries manifest))
1123                                   (return '())
1124                                   (sequence %store-monad
1125                                             (map (lambda (hook)
1126                                                    (hook manifest))
1127                                                  hooks)))))
1128     (define inputs
1129       (append (filter-map (lambda (drv)
1130                             (and (derivation? drv)
1131                                  (gexp-input drv)))
1132                           extras)
1133               (manifest-inputs manifest)))
1134
1135     (define glibc-utf8-locales                    ;lazy reference
1136       (module-ref (resolve-interface '(gnu packages base))
1137                   'glibc-utf8-locales))
1138
1139     (define set-utf8-locale
1140       ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so
1141       ;; install a UTF-8 locale.
1142       #~(begin
1143           (setenv "LOCPATH"
1144                   #$(file-append glibc-utf8-locales "/lib/locale/"
1145                                  (package-version glibc-utf8-locales)))
1146           (setlocale LC_ALL "en_US.utf8")))
1147
1148     (define builder
1149       (with-imported-modules '((guix build profiles)
1150                                (guix build union)
1151                                (guix build utils)
1152                                (guix search-paths)
1153                                (guix records))
1154         #~(begin
1155             (use-modules (guix build profiles)
1156                          (guix search-paths)
1157                          (srfi srfi-1))
1158
1159             (setvbuf (current-output-port) _IOLBF)
1160             (setvbuf (current-error-port) _IOLBF)
1161
1162             #+(if locales? set-utf8-locale #t)
1163
1164             (define search-paths
1165               ;; Search paths of MANIFEST's packages, converted back to their
1166               ;; record form.
1167               (map sexp->search-path-specification
1168                    (delete-duplicates
1169                     '#$(map search-path-specification->sexp
1170                             (append-map manifest-entry-search-paths
1171                                         (manifest-entries manifest))))))
1172
1173             (build-profile #$output '#$inputs
1174                            #:manifest '#$(manifest->gexp manifest)
1175                            #:search-paths search-paths))))
1176
1177     (gexp->derivation "profile" builder
1178                       #:system system
1179                       #:target target
1180
1181                       ;; Not worth offloading.
1182                       #:local-build? #t
1183
1184                       ;; Disable substitution because it would trigger a
1185                       ;; connection to the substitute server, which is likely
1186                       ;; to have no substitute to offer.
1187                       #:substitutable? #f)))
1188
1189 (define (profile-regexp profile)
1190   "Return a regular expression that matches PROFILE's name and number."
1191   (make-regexp (string-append "^" (regexp-quote (basename profile))
1192                               "-([0-9]+)")))
1193
1194 (define (generation-number profile)
1195   "Return PROFILE's number or 0.  An absolute file name must be used."
1196   (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
1197                                               (basename (readlink profile))))
1198              (compose string->number (cut match:substring <> 1)))
1199       0))
1200
1201 (define (generation-numbers profile)
1202   "Return the sorted list of generation numbers of PROFILE, or '(0) if no
1203 former profiles were found."
1204   (define* (scandir name #:optional (select? (const #t))
1205                     (entry<? (@ (ice-9 i18n) string-locale<?)))
1206     ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
1207     (define (enter? dir stat result)
1208       (and stat (string=? dir name)))
1209
1210     (define (visit basename result)
1211       (if (select? basename)
1212           (cons basename result)
1213           result))
1214
1215     (define (leaf name stat result)
1216       (and result
1217            (visit (basename name) result)))
1218
1219     (define (down name stat result)
1220       (visit "." '()))
1221
1222     (define (up name stat result)
1223       (visit ".." result))
1224
1225     (define (skip name stat result)
1226       ;; All the sub-directories are skipped.
1227       (visit (basename name) result))
1228
1229     (define (error name* stat errno result)
1230       (if (string=? name name*)             ; top-level NAME is unreadable
1231           result
1232           (visit (basename name*) result)))
1233
1234     (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
1235            (lambda (files)
1236              (sort files entry<?))))
1237
1238   (match (scandir (dirname profile)
1239                   (cute regexp-exec (profile-regexp profile) <>))
1240     (#f                                         ; no profile directory
1241      '(0))
1242     (()                                         ; no profiles
1243      '(0))
1244     ((profiles ...)                             ; former profiles around
1245      (sort (map (compose string->number
1246                          (cut match:substring <> 1)
1247                          (cute regexp-exec (profile-regexp profile) <>))
1248                 profiles)
1249            <))))
1250
1251 (define (profile-generations profile)
1252   "Return a list of PROFILE's generations."
1253   (let ((generations (generation-numbers profile)))
1254     (if (equal? generations '(0))
1255         '()
1256         generations)))
1257
1258 (define (relative-generation-spec->number profile spec)
1259   "Return PROFILE's generation specified by SPEC, which is a string.  The SPEC
1260 may be a N, -N, or +N, where N is a number.  If the spec is N, then the number
1261 returned is N.  If it is -N, then the number returned is the profile's current
1262 generation number minus N.  If it is +N, then the number returned is the
1263 profile's current generation number plus N.  Return #f if there is no such
1264 generation."
1265   (let ((number (string->number spec)))
1266     (and number
1267          (case (string-ref spec 0)
1268            ((#\+ #\-)
1269             (relative-generation profile number))
1270            (else (if (memv number (profile-generations profile))
1271                      number
1272                      #f))))))
1273
1274
1275 (define* (relative-generation profile shift #:optional
1276                               (current (generation-number profile)))
1277   "Return PROFILE's generation shifted from the CURRENT generation by SHIFT.
1278 SHIFT is a positive or negative number.
1279 Return #f if there is no such generation."
1280   (let* ((abs-shift (abs shift))
1281          (numbers (profile-generations profile))
1282          (from-current (memq current
1283                              (if (negative? shift)
1284                                  (reverse numbers)
1285                                  numbers))))
1286     (and from-current
1287          (< abs-shift (length from-current))
1288          (list-ref from-current abs-shift))))
1289
1290 (define* (previous-generation-number profile #:optional
1291                                      (number (generation-number profile)))
1292   "Return the number of the generation before generation NUMBER of
1293 PROFILE, or 0 if none exists.  It could be NUMBER - 1, but it's not the
1294 case when generations have been deleted (there are \"holes\")."
1295   (or (relative-generation profile -1 number)
1296       0))
1297
1298 (define (generation-file-name profile generation)
1299   "Return the file name for PROFILE's GENERATION."
1300   (format #f "~a-~a-link" profile generation))
1301
1302 (define (generation-time profile number)
1303   "Return the creation time of a generation in the UTC format."
1304   (make-time time-utc 0
1305              (stat:ctime (stat (generation-file-name profile number)))))
1306
1307 (define (link-to-empty-profile store generation)
1308   "Link GENERATION, a string, to the empty profile.  An error is raised if
1309 that fails."
1310   (let* ((drv  (run-with-store store
1311                  (profile-derivation (manifest '())
1312                                      #:locales? #f)))
1313          (prof (derivation->output-path drv "out")))
1314     (build-derivations store (list drv))
1315     (switch-symlinks generation prof)))
1316
1317 (define (switch-to-generation profile number)
1318   "Atomically switch PROFILE to the generation NUMBER.  Return the number of
1319 the generation that was current before switching."
1320   (let ((current    (generation-number profile))
1321         (generation (generation-file-name profile number)))
1322     (cond ((not (file-exists? profile))
1323            (raise (condition (&profile-not-found-error
1324                               (profile profile)))))
1325           ((not (file-exists? generation))
1326            (raise (condition (&missing-generation-error
1327                               (profile profile)
1328                               (generation number)))))
1329           (else
1330            (switch-symlinks profile generation)
1331            current))))
1332
1333 (define (switch-to-previous-generation profile)
1334   "Atomically switch PROFILE to the previous generation.  Return the former
1335 generation number and the current one."
1336   (let ((previous (previous-generation-number profile)))
1337     (values (switch-to-generation profile previous)
1338             previous)))
1339
1340 (define (roll-back store profile)
1341   "Roll back to the previous generation of PROFILE.  Return the number of the
1342 generation that was current before switching and the new generation number."
1343   (let* ((number              (generation-number profile))
1344          (previous-number     (previous-generation-number profile number))
1345          (previous-generation (generation-file-name profile previous-number)))
1346     (cond ((not (file-exists? profile))           ;invalid profile
1347            (raise (condition (&profile-not-found-error
1348                               (profile profile)))))
1349           ((zero? number)                         ;empty profile
1350            (values number number))
1351           ((or (zero? previous-number)            ;going to emptiness
1352                (not (file-exists? previous-generation)))
1353            (link-to-empty-profile store previous-generation)
1354            (switch-to-previous-generation profile))
1355           (else                                   ;anything else
1356            (switch-to-previous-generation profile)))))
1357
1358 (define (delete-generation store profile number)
1359   "Delete generation with NUMBER from PROFILE.  Return the file name of the
1360 generation that has been deleted, or #f if nothing was done (for instance
1361 because the NUMBER is zero.)"
1362   (define (delete-and-return)
1363     (let ((generation (generation-file-name profile number)))
1364       (delete-file generation)
1365       generation))
1366
1367   (let* ((current-number      (generation-number profile))
1368          (previous-number     (previous-generation-number profile number))
1369          (previous-generation (generation-file-name profile previous-number)))
1370     (cond ((zero? number) #f)                     ;do not delete generation 0
1371           ((and (= number current-number)
1372                 (not (file-exists? previous-generation)))
1373            (link-to-empty-profile store previous-generation)
1374            (switch-to-previous-generation profile)
1375            (delete-and-return))
1376           ((= number current-number)
1377            (roll-back store profile)
1378            (delete-and-return))
1379           (else
1380            (delete-and-return)))))
1381
1382 ;;; profiles.scm ends here