guix/profiles.scm

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