guix/profiles.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 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, 2018, 2019 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 ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com>
  12 ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
  13 ;;;
  14 ;;; This file is part of GNU Guix.
  15 ;;;
  16 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  17 ;;; under the terms of the GNU General Public License as published by
  18 ;;; the Free Software Foundation; either version 3 of the License, or (at
  19 ;;; your option) any later version.
  20 ;;;
  21 ;;; GNU Guix is distributed in the hope that it will be useful, but
  22 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;;; GNU General Public License for more details.
  25 ;;;
  26 ;;; You should have received a copy of the GNU General Public License
  27 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  28
  29 (define-module (guix profiles)
  30   #:use-module ((guix config) #:select (%state-directory))
  31   #:use-module ((guix utils) #:hide (package-name->name+version))
  32   #:use-module ((guix build utils)
  33                 #:select (package-name->name+version mkdir-p))
  34   #:use-module (guix i18n)
  35   #:use-module (guix records)
  36   #:use-module (guix packages)
  37   #:use-module (guix derivations)
  38   #:use-module (guix search-paths)
  39   #:use-module (guix gexp)
  40   #:use-module (guix modules)
  41   #:use-module (guix monads)
  42   #:use-module (guix store)
  43   #:use-module (guix sets)
  44   #:use-module (ice-9 vlist)
  45   #:use-module (ice-9 match)
  46   #:use-module (ice-9 regex)
  47   #:use-module (ice-9 ftw)
  48   #:use-module (ice-9 format)
  49   #:use-module (srfi srfi-1)
  50   #:use-module (srfi srfi-9)
  51   #:use-module (srfi srfi-11)
  52   #:use-module (srfi srfi-19)
  53   #:use-module (srfi srfi-26)
  54   #:use-module (srfi srfi-34)
  55   #:use-module (srfi srfi-35)
  56   #:export (&profile-error
  57             profile-error?
  58             profile-error-profile
  59             &profile-not-found-error
  60             profile-not-found-error?
  61             &profile-collision-error
  62             profile-collision-error?
  63             profile-collision-error-entry
  64             profile-collision-error-conflict
  65             &missing-generation-error
  66             missing-generation-error?
  67             missing-generation-error-generation
  68             &unmatched-pattern-error
  69             unmatched-pattern-error?
  70             unmatched-pattern-error-pattern
  71             unmatched-pattern-error-manifest
  72
  73             manifest make-manifest
  74             manifest?
  75             manifest-entries
  76             manifest-transitive-entries
  77
  78             <manifest-entry>              ; FIXME: eventually make it internal
  79             manifest-entry
  80             manifest-entry?
  81             manifest-entry-name
  82             manifest-entry-version
  83             manifest-entry-output
  84             manifest-entry-item
  85             manifest-entry-dependencies
  86             manifest-entry-search-paths
  87             manifest-entry-parent
  88             manifest-entry-properties
  89
  90             manifest-pattern
  91             manifest-pattern?
  92             manifest-pattern-name
  93             manifest-pattern-version
  94             manifest-pattern-output
  95
  96             concatenate-manifests
  97             map-manifest-entries
  98             manifest-remove
  99             manifest-add
 100             manifest-lookup
 101             manifest-installed?
 102             manifest-matching-entries
 103             manifest-search-paths
 104
 105             manifest-transaction
 106             manifest-transaction?
 107             manifest-transaction-install
 108             manifest-transaction-remove
 109             manifest-transaction-install-entry
 110             manifest-transaction-remove-pattern
 111             manifest-transaction-null?
 112             manifest-transaction-removal-candidate?
 113             manifest-perform-transaction
 114             manifest-transaction-effects
 115
 116             profile-manifest
 117             package->manifest-entry
 118             packages->manifest
 119             ca-certificate-bundle
 120             %default-profile-hooks
 121             profile-derivation
 122             profile-search-paths
 123
 124             generation-number
 125             generation-profile
 126             generation-numbers
 127             profile-generations
 128             relative-generation-spec->number
 129             relative-generation
 130             previous-generation-number
 131             generation-time
 132             generation-file-name
 133             switch-to-generation
 134             roll-back
 135             delete-generation
 136
 137             %user-profile-directory
 138             %profile-directory
 139             %current-profile
 140             ensure-profile-directory
 141             canonicalize-profile
 142             user-friendly-profile))
 143
 144 ;;; Commentary:
 145 ;;;
 146 ;;; Tools to create and manipulate profiles---i.e., the representation of a
 147 ;;; set of installed packages.
 148 ;;;
 149 ;;; Code:
 150
 151 \f
 152 ;;;
 153 ;;; Condition types.
 154 ;;;
 155
 156 (define-condition-type &profile-error &error
 157   profile-error?
 158   (profile profile-error-profile))
 159
 160 (define-condition-type &profile-not-found-error &profile-error
 161   profile-not-found-error?)
 162
 163 (define-condition-type &profile-collision-error &error
 164   profile-collision-error?
 165   (entry    profile-collision-error-entry)        ;<manifest-entry>
 166   (conflict profile-collision-error-conflict))    ;<manifest-entry>
 167
 168 (define-condition-type &unmatched-pattern-error &error
 169   unmatched-pattern-error?
 170   (pattern  unmatched-pattern-error-pattern)      ;<manifest-pattern>
 171   (manifest unmatched-pattern-error-manifest))    ;<manifest>
 172
 173 (define-condition-type &missing-generation-error &profile-error
 174   missing-generation-error?
 175   (generation missing-generation-error-generation))
 176
 177 \f
 178 ;;;
 179 ;;; Manifests.
 180 ;;;
 181
 182 (define-record-type <manifest>
 183   (manifest entries)
 184   manifest?
 185   (entries manifest-entries))                     ; list of <manifest-entry>
 186
 187 ;; Convenient alias, to avoid name clashes.
 188 (define make-manifest manifest)
 189
 190 (define-record-type* <manifest-entry> manifest-entry
 191   make-manifest-entry
 192   manifest-entry?
 193   (name         manifest-entry-name)              ; string
 194   (version      manifest-entry-version)           ; string
 195   (output       manifest-entry-output             ; string
 196                 (default "out"))
 197   (item         manifest-entry-item)              ; package | file-like | store path
 198   (dependencies manifest-entry-dependencies       ; <manifest-entry>*
 199                 (default '()))
 200   (search-paths manifest-entry-search-paths       ; search-path-specification*
 201                 (default '()))
 202   (parent       manifest-entry-parent        ; promise (#f | <manifest-entry>)
 203                 (default (delay #f)))
 204   (properties   manifest-entry-properties         ; list of symbol/value pairs
 205                 (default '())))
 206
 207 (define-record-type* <manifest-pattern> manifest-pattern
 208   make-manifest-pattern
 209   manifest-pattern?
 210   (name         manifest-pattern-name)            ; string
 211   (version      manifest-pattern-version          ; string | #f
 212                 (default #f))
 213   (output       manifest-pattern-output           ; string | #f
 214                 (default "out")))
 215
 216 (define (manifest-transitive-entries manifest)
 217   "Return the entries of MANIFEST along with their propagated inputs,
 218 recursively."
 219   (let loop ((entries (manifest-entries manifest))
 220              (result  '())
 221              (visited (set)))                     ;compare with 'equal?'
 222     (match entries
 223       (()
 224        (reverse result))
 225       ((head . tail)
 226        (if (set-contains? visited head)
 227            (loop tail result visited)
 228            (loop (append (manifest-entry-dependencies head)
 229                          tail)
 230                  (cons head result)
 231                  (set-insert head visited)))))))
 232
 233 (define (profile-manifest profile)
 234   "Return the PROFILE's manifest."
 235   (let ((file (string-append profile "/manifest")))
 236     (if (file-exists? file)
 237         (call-with-input-file file read-manifest)
 238         (manifest '()))))
 239
 240 (define (manifest-entry-lookup manifest)
 241   "Return a lookup procedure for the entries of MANIFEST.  The lookup
 242 procedure takes two arguments: the entry name and output."
 243   (define mapping
 244     (let loop ((entries (manifest-entries manifest))
 245                (mapping vlist-null))
 246       (fold (lambda (entry result)
 247               (vhash-cons (cons (manifest-entry-name entry)
 248                                 (manifest-entry-output entry))
 249                           entry
 250                           (loop (manifest-entry-dependencies entry)
 251                                 result)))
 252             mapping
 253             entries)))
 254
 255   (lambda (name output)
 256     (match (vhash-assoc (cons name output) mapping)
 257       ((_ . entry) entry)
 258       (#f          #f))))
 259
 260 (define* (lower-manifest-entry entry system #:key target)
 261   "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store
 262 file name."
 263   (let ((item (manifest-entry-item entry)))
 264     (if (string? item)
 265         (with-monad %store-monad
 266           (return entry))
 267         (mlet %store-monad ((drv (lower-object item system
 268                                                #:target target))
 269                             (output -> (manifest-entry-output entry)))
 270           (return (manifest-entry
 271                     (inherit entry)
 272                     (item (derivation->output-path drv output))))))))
 273
 274 (define* (check-for-collisions manifest system #:key target)
 275   "Check whether the entries of MANIFEST conflict with one another; raise a
 276 '&profile-collision-error' when a conflict is encountered."
 277   (define lookup
 278     (manifest-entry-lookup manifest))
 279
 280   (with-monad %store-monad
 281     (foldm %store-monad
 282            (lambda (entry result)
 283              (match (lookup (manifest-entry-name entry)
 284                             (manifest-entry-output entry))
 285                ((? manifest-entry? second)        ;potential conflict
 286                 (mlet %store-monad ((first (lower-manifest-entry entry system
 287                                                                  #:target
 288                                                                  target))
 289                                     (second (lower-manifest-entry second system
 290                                                                   #:target
 291                                                                   target)))
 292                   (if (string=? (manifest-entry-item first)
 293                                 (manifest-entry-item second))
 294                       (return result)
 295                       (raise (condition
 296                               (&profile-collision-error
 297                                (entry first)
 298                                (conflict second)))))))
 299                (#f                                ;no conflict
 300                 (return result))))
 301            #t
 302            (manifest-transitive-entries manifest))))
 303
 304 (define* (package->manifest-entry package #:optional (output "out")
 305                                   #:key (parent (delay #f))
 306                                   (properties '()))
 307   "Return a manifest entry for the OUTPUT of package PACKAGE."
 308   ;; For each dependency, keep a promise pointing to its "parent" entry.
 309   (letrec* ((deps  (map (match-lambda
 310                           ((label package)
 311                            (package->manifest-entry package
 312                                                     #:parent (delay entry)))
 313                           ((label package output)
 314                            (package->manifest-entry package output
 315                                                     #:parent (delay entry))))
 316                         (package-propagated-inputs package)))
 317             (entry (manifest-entry
 318                      (name (package-name package))
 319                      (version (package-version package))
 320                      (output output)
 321                      (item package)
 322                      (dependencies (delete-duplicates deps))
 323                      (search-paths
 324                       (package-transitive-native-search-paths package))
 325                      (parent parent)
 326                      (properties properties))))
 327     entry))
 328
 329 (define (packages->manifest packages)
 330   "Return a list of manifest entries, one for each item listed in PACKAGES.
 331 Elements of PACKAGES can be either package objects or package/string tuples
 332 denoting a specific output of a package."
 333   (define inferiors-loaded?
 334     ;; This hack allows us to provide seamless integration for inferior
 335     ;; packages while not having a hard dependency on (guix inferior).
 336     (resolve-module '(guix inferior) #f #f #:ensure #f))
 337
 338   (define (inferior->entry)
 339     (module-ref (resolve-interface '(guix inferior))
 340                 'inferior-package->manifest-entry))
 341
 342   (manifest
 343    (map (match-lambda
 344           (((? package? package) output)
 345            (package->manifest-entry package output))
 346           ((? package? package)
 347            (package->manifest-entry package))
 348           ((thing output)
 349            (if inferiors-loaded?
 350                ((inferior->entry) thing output)
 351                (throw 'wrong-type-arg 'packages->manifest
 352                       "Wrong package object: ~S" (list thing) (list thing))))
 353           (thing
 354            (if inferiors-loaded?
 355                ((inferior->entry) thing)
 356                (throw 'wrong-type-arg 'packages->manifest
 357                       "Wrong package object: ~S" (list thing) (list thing)))))
 358         packages)))
 359
 360 (define (manifest->gexp manifest)
 361   "Return a representation of MANIFEST as a gexp."
 362   (define (entry->gexp entry)
 363     (match entry
 364       (($ <manifest-entry> name version output (? string? path)
 365                            (deps ...) (search-paths ...) _ (properties ...))
 366        #~(#$name #$version #$output #$path
 367                  (propagated-inputs #$(map entry->gexp deps))
 368                  (search-paths #$(map search-path-specification->sexp
 369                                       search-paths))
 370                  (properties . #$properties)))
 371       (($ <manifest-entry> name version output package
 372                            (deps ...) (search-paths ...) _ (properties ...))
 373        #~(#$name #$version #$output
 374                  (ungexp package (or output "out"))
 375                  (propagated-inputs #$(map entry->gexp deps))
 376                  (search-paths #$(map search-path-specification->sexp
 377                                       search-paths))
 378                  (properties . #$properties)))))
 379
 380   (match manifest
 381     (($ <manifest> (entries ...))
 382      #~(manifest (version 3)
 383                  (packages #$(map entry->gexp entries))))))
 384
 385 (define (find-package name version)
 386   "Return a package from the distro matching NAME and possibly VERSION.  This
 387 procedure is here for backward-compatibility and will eventually vanish."
 388   (define find-best-packages-by-name              ;break abstractions
 389     (module-ref (resolve-interface '(gnu packages))
 390                 'find-best-packages-by-name))
 391
 392    ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the
 393    ;; former traverses the module tree only once and then allows for efficient
 394    ;; access via a vhash.
 395    (match (find-best-packages-by-name name version)
 396      ((p _ ...) p)
 397      (_
 398       (match (find-best-packages-by-name name #f)
 399         ((p _ ...) p)
 400         (_ #f)))))
 401
 402 (define (sexp->manifest sexp)
 403   "Parse SEXP as a manifest."
 404   (define (infer-search-paths name version)
 405     ;; Infer the search path specifications for NAME-VERSION by looking up a
 406     ;; same-named package in the distro.  Useful for the old manifest formats
 407     ;; that did not store search path info.
 408     (let ((package (find-package name version)))
 409       (if package
 410           (package-native-search-paths package)
 411           '())))
 412
 413   (define (infer-dependency item parent)
 414     ;; Return a <manifest-entry> for ITEM.
 415     (let-values (((name version)
 416                   (package-name->name+version
 417                    (store-path-package-name item))))
 418       (manifest-entry
 419         (name name)
 420         (version version)
 421         (item item)
 422         (parent parent))))
 423
 424   (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
 425     (match sexp
 426       ((name version output path
 427              ('propagated-inputs deps)
 428              ('search-paths search-paths)
 429              extra-stuff ...)
 430        ;; For each of DEPS, keep a promise pointing to ENTRY.
 431        (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry))
 432                              deps))
 433                  (entry (manifest-entry
 434                           (name name)
 435                           (version version)
 436                           (output output)
 437                           (item path)
 438                           (dependencies deps*)
 439                           (search-paths (map sexp->search-path-specification
 440                                              search-paths))
 441                           (parent parent)
 442                           (properties (or (assoc-ref extra-stuff 'properties)
 443                                           '())))))
 444          entry))))
 445
 446   (match sexp
 447     (('manifest ('version 0)
 448                 ('packages ((name version output path) ...)))
 449      (manifest
 450       (map (lambda (name version output path)
 451              (manifest-entry
 452                (name name)
 453                (version version)
 454                (output output)
 455                (item path)
 456                (search-paths (infer-search-paths name version))))
 457            name version output path)))
 458
 459     ;; Version 1 adds a list of propagated inputs to the
 460     ;; name/version/output/path tuples.
 461     (('manifest ('version 1)
 462                 ('packages ((name version output path deps) ...)))
 463      (manifest
 464       (map (lambda (name version output path deps)
 465              ;; Up to Guix 0.7 included, dependencies were listed as ("gmp"
 466              ;; "/gnu/store/...-gmp") for instance.  Discard the 'label' in
 467              ;; such lists.
 468              (let ((deps (match deps
 469                            (((labels directories) ...)
 470                             directories)
 471                            ((directories ...)
 472                             directories))))
 473                (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
 474                                      deps))
 475                          (entry (manifest-entry
 476                                   (name name)
 477                                   (version version)
 478                                   (output output)
 479                                   (item path)
 480                                   (dependencies deps*)
 481                                   (search-paths
 482                                    (infer-search-paths name version)))))
 483                  entry)))
 484            name version output path deps)))
 485
 486     ;; Version 2 adds search paths and is slightly more verbose.
 487     (('manifest ('version 2 minor-version ...)
 488                 ('packages ((name version output path
 489                                   ('propagated-inputs deps)
 490                                   ('search-paths search-paths)
 491                                   extra-stuff ...)
 492                             ...)))
 493      (manifest
 494       (map (lambda (name version output path deps search-paths)
 495              (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
 496                                    deps))
 497                        (entry (manifest-entry
 498                                 (name name)
 499                                 (version version)
 500                                 (output output)
 501                                 (item path)
 502                                 (dependencies deps*)
 503                                 (search-paths
 504                                  (map sexp->search-path-specification
 505                                       search-paths)))))
 506                entry))
 507            name version output path deps search-paths)))
 508
 509     ;; Version 3 represents DEPS as full-blown manifest entries.
 510     (('manifest ('version 3 minor-version ...)
 511                 ('packages (entries ...)))
 512      (manifest (map sexp->manifest-entry entries)))
 513     (_
 514      (raise (condition
 515              (&message (message "unsupported manifest format")))))))
 516
 517 (define (read-manifest port)
 518   "Return the packages listed in MANIFEST."
 519   (sexp->manifest (read port)))
 520
 521 (define (concatenate-manifests lst)
 522   "Concatenate the manifests listed in LST and return the resulting manifest."
 523   (manifest (append-map manifest-entries lst)))
 524
 525 (define (map-manifest-entries proc manifest)
 526   "Apply PROC to all the entries of MANIFEST and return a new manifest."
 527   (make-manifest
 528    (map proc (manifest-entries manifest))))
 529
 530 (define (entry-predicate pattern)
 531   "Return a procedure that returns #t when passed a manifest entry that
 532 matches NAME/OUTPUT/VERSION.  OUTPUT and VERSION may be #f, in which case they
 533 are ignored."
 534   (match pattern
 535     (($ <manifest-pattern> name version output)
 536      (match-lambda
 537       (($ <manifest-entry> entry-name entry-version entry-output)
 538        (and (string=? entry-name name)
 539             (or (not entry-output) (not output)
 540                 (string=? entry-output output))
 541             (or (not version)
 542                 (string=? entry-version version))))))))
 543
 544 (define (manifest-remove manifest patterns)
 545   "Remove entries for each of PATTERNS from MANIFEST.  Each item in PATTERNS
 546 must be a manifest-pattern."
 547   (define (remove-entry pattern lst)
 548     (remove (entry-predicate pattern) lst))
 549
 550   (make-manifest (fold remove-entry
 551                        (manifest-entries manifest)
 552                        patterns)))
 553
 554 (define (manifest-add manifest entries)
 555   "Add a list of manifest ENTRIES to MANIFEST and return new manifest.
 556 Remove MANIFEST entries that have the same name and output as ENTRIES."
 557   (define (same-entry? entry name output)
 558     (match entry
 559       (($ <manifest-entry> entry-name _ entry-output _)
 560        (and (equal? name entry-name)
 561             (equal? output entry-output)))))
 562
 563   (make-manifest
 564    (fold (lambda (entry result)                   ;XXX: quadratic
 565            (match entry
 566              (($ <manifest-entry> name _ out _)
 567               (cons entry
 568                     (remove (cut same-entry? <> name out)
 569                             result)))))
 570          (manifest-entries manifest)
 571          entries)))
 572
 573 (define (manifest-lookup manifest pattern)
 574   "Return the first item of MANIFEST that matches PATTERN, or #f if there is
 575 no match.."
 576   (find (entry-predicate pattern)
 577         (manifest-entries manifest)))
 578
 579 (define (manifest-installed? manifest pattern)
 580   "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
 581 #f otherwise."
 582   (->bool (manifest-lookup manifest pattern)))
 583
 584 (define (manifest-matching-entries manifest patterns)
 585   "Return all the entries of MANIFEST that match one of the PATTERNS.  Raise
 586 an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one
 587 of PATTERNS."
 588   (fold-right (lambda (pattern matches)
 589                 (match (filter (entry-predicate pattern)
 590                                (manifest-entries manifest))
 591                   (()
 592                    (raise (condition
 593                            (&unmatched-pattern-error
 594                             (pattern pattern)
 595                             (manifest manifest)))))
 596                   (lst
 597                    (append lst matches))))
 598               '()
 599               patterns))
 600
 601 (define (manifest-search-paths manifest)
 602   "Return the list of search path specifications that apply to MANIFEST,
 603 including the search path specification for $PATH."
 604   (delete-duplicates
 605    (cons $PATH
 606          (append-map manifest-entry-search-paths
 607                      (manifest-entries manifest)))))
 608
 609 \f
 610 ;;;
 611 ;;; Manifest transactions.
 612 ;;;
 613
 614 (define-record-type* <manifest-transaction> manifest-transaction
 615   make-manifest-transaction
 616   manifest-transaction?
 617   (install manifest-transaction-install ; list of <manifest-entry>
 618            (default '()))
 619   (remove  manifest-transaction-remove  ; list of <manifest-pattern>
 620            (default '())))
 621
 622 (define (manifest-transaction-install-entry entry transaction)
 623   "Augment TRANSACTION's set of installed packages with ENTRY, a
 624 <manifest-entry>."
 625   (manifest-transaction
 626    (inherit transaction)
 627    (install
 628     (cons entry (manifest-transaction-install transaction)))))
 629
 630 (define (manifest-transaction-remove-pattern pattern transaction)
 631   "Add PATTERN to TRANSACTION's list of packages to remove."
 632   (manifest-transaction
 633    (inherit transaction)
 634    (remove
 635     (cons pattern (manifest-transaction-remove transaction)))))
 636
 637 (define (manifest-transaction-null? transaction)
 638   "Return true if TRANSACTION has no effect---i.e., it neither installs nor
 639 remove software."
 640   (match transaction
 641     (($ <manifest-transaction> () ()) #t)
 642     (($ <manifest-transaction> _ _)   #f)))
 643
 644 (define (manifest-transaction-removal-candidate? entry transaction)
 645   "Return true if ENTRY is a candidate for removal in TRANSACTION."
 646   (any (lambda (pattern)
 647          ((entry-predicate pattern) entry))
 648        (manifest-transaction-remove transaction)))
 649
 650 (define (manifest-transaction-effects manifest transaction)
 651   "Compute the effect of applying TRANSACTION to MANIFEST.  Return 4 values:
 652 the list of packages that would be removed, installed, upgraded, or downgraded
 653 when applying TRANSACTION to MANIFEST.  Upgrades are represented as pairs
 654 where the head is the entry being upgraded and the tail is the entry that will
 655 replace it."
 656   (define (manifest-entry->pattern entry)
 657     (manifest-pattern
 658       (name   (manifest-entry-name entry))
 659       (output (manifest-entry-output entry))))
 660
 661   (let loop ((input     (manifest-transaction-install transaction))
 662              (install   '())
 663              (upgrade   '())
 664              (downgrade '()))
 665     (match input
 666       (()
 667        (let ((remove (manifest-transaction-remove transaction)))
 668          (values (manifest-matching-entries manifest remove)
 669                  (reverse install) (reverse upgrade) (reverse downgrade))))
 670       ((entry rest ...)
 671        ;; Check whether installing ENTRY corresponds to the installation of a
 672        ;; new package or to an upgrade.
 673
 674        ;; XXX: When the exact same output directory is installed, we're not
 675        ;; really upgrading anything.  Add a check for that case.
 676        (let* ((pattern  (manifest-entry->pattern entry))
 677               (previous (manifest-lookup manifest pattern))
 678               (newer?   (and previous
 679                              (version>=? (manifest-entry-version entry)
 680                                          (manifest-entry-version previous)))))
 681          (loop rest
 682                (if previous install (cons entry install))
 683                (if (and previous newer?)
 684                    (alist-cons previous entry upgrade)
 685                    upgrade)
 686                (if (and previous (not newer?))
 687                    (alist-cons previous entry downgrade)
 688                    downgrade)))))))
 689
 690 (define (manifest-perform-transaction manifest transaction)
 691   "Perform TRANSACTION on MANIFEST and return the new manifest."
 692   (let ((install (manifest-transaction-install transaction))
 693         (remove  (manifest-transaction-remove transaction)))
 694     (manifest-add (manifest-remove manifest remove)
 695                   install)))
 696
 697 \f
 698 ;;;
 699 ;;; Profiles.
 700 ;;;
 701
 702 (define (manifest-inputs manifest)
 703   "Return a list of <gexp-input> objects for MANIFEST."
 704   (define entry->input
 705     (match-lambda
 706       (($ <manifest-entry> name version output thing deps)
 707        ;; THING may be a package or a file name.  In the latter case, assume
 708        ;; it's already valid.
 709        (cons (gexp-input thing output)
 710              (append-map entry->input deps)))))
 711
 712   (append-map entry->input (manifest-entries manifest)))
 713
 714 (define* (manifest-lookup-package manifest name #:optional version)
 715   "Return as a monadic value the first package or store path referenced by
 716 MANIFEST that is named NAME and optionally has the given VERSION prefix, or #f
 717 if not found."
 718   ;; Return as a monadic value the package or store path referenced by the
 719   ;; manifest ENTRY, or #f if not referenced.
 720   (define (entry-lookup-package entry)
 721     (define (find-among-inputs inputs)
 722       (find (lambda (input)
 723               (and (package? input)
 724                    (equal? name (package-name input))
 725                    (if version
 726                        (string-prefix? version (package-version input))
 727                        #t)))
 728             inputs))
 729     (define (find-among-store-items items)
 730       (find (lambda (item)
 731               (let-values (((name* version*)
 732                             (package-name->name+version
 733                              (store-path-package-name item))))
 734                 (and (string=? name name*)
 735                      (if version
 736                          (string-prefix? version version*)
 737                          #t))))
 738             items))
 739
 740     (with-monad %store-monad
 741       (match (manifest-entry-item entry)
 742         ((? package? package)
 743          (match (cons (list (package-name package) package)
 744                       (package-transitive-inputs package))
 745            (((labels inputs . _) ...)
 746             (return (find-among-inputs inputs)))))
 747         ((? string? item)
 748          (mlet %store-monad ((refs (references* item)))
 749            (return (find-among-store-items refs))))
 750         (item
 751          ;; XXX: ITEM might be a 'computed-file' or anything like that, in
 752          ;; which case we don't know what to do.  The fix may be to check
 753          ;; references once ITEM is compiled, as proposed at
 754          ;; <https://bugs.gnu.org/29927>.
 755          (return #f)))))
 756
 757   (anym %store-monad
 758         entry-lookup-package (manifest-entries manifest)))
 759
 760 (define (info-dir-file manifest)
 761   "Return a derivation that builds the 'dir' file for all the entries of
 762 MANIFEST."
 763   (define texinfo                                 ;lazy reference
 764     (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
 765   (define gzip                                    ;lazy reference
 766     (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
 767   (define glibc-utf8-locales                      ;lazy reference
 768     (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
 769
 770   (define build
 771     (with-imported-modules '((guix build utils))
 772       #~(begin
 773           (use-modules (guix build utils)
 774                        (srfi srfi-1) (srfi srfi-26)
 775                        (ice-9 ftw))
 776
 777           (define (info-file? file)
 778             (or (string-suffix? ".info" file)
 779                 (string-suffix? ".info.gz" file)))
 780
 781           (define (info-files top)
 782             (let ((infodir (string-append top "/share/info")))
 783               (map (cut string-append infodir "/" <>)
 784                    (or (scandir infodir info-file?) '()))))
 785
 786           (define (info-file-language file)
 787             (let* ((base (if (string-suffix? ".gz" file)
 788                              (basename file ".info.gz")
 789                              (basename file ".info")))
 790                    (dot  (string-rindex base #\.)))
 791               (if dot
 792                   (string-drop base (+ 1 dot))
 793                   "en")))
 794
 795           (define (install-info info)
 796             (let ((language (info-file-language info)))
 797               ;; We need to choose a valid locale for $LANGUAGE to be honored.
 798               (setenv "LC_ALL" "en_US.utf8")
 799               (setenv "LANGUAGE" language)
 800               (zero?
 801                (system* #+(file-append texinfo "/bin/install-info")
 802                         "--silent" info
 803                         (apply string-append #$output "/share/info/dir"
 804                                (if (string=? "en" language)
 805                                    '("")
 806                                    `("." ,language)))))))
 807
 808           (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
 809           (setenv "GUIX_LOCPATH"
 810                   #+(file-append glibc-utf8-locales "/lib/locale"))
 811
 812           (mkdir-p (string-append #$output "/share/info"))
 813           (exit (every install-info
 814                        (append-map info-files
 815                                    '#$(manifest-inputs manifest)))))))
 816
 817   (gexp->derivation "info-dir" build
 818                     #:local-build? #t
 819                     #:substitutable? #f
 820                     #:properties
 821                     `((type . profile-hook)
 822                       (hook . info-dir))))
 823
 824 (define (ghc-package-cache-file manifest)
 825   "Return a derivation that builds the GHC 'package.cache' file for all the
 826 entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
 827   (define ghc                                     ;lazy reference
 828     (module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
 829
 830   (define build
 831     (with-imported-modules '((guix build utils))
 832       #~(begin
 833           (use-modules (guix build utils)
 834                        (srfi srfi-1) (srfi srfi-26)
 835                        (ice-9 ftw))
 836
 837           (define ghc-name-version
 838             (let* ((base (basename #+ghc)))
 839               (string-drop base
 840                            (+ 1 (string-index base #\-)))))
 841
 842           (define db-subdir
 843             (string-append "lib/" ghc-name-version "/package.conf.d"))
 844
 845           (define db-dir
 846             (string-append #$output "/" db-subdir))
 847
 848           (define (conf-files top)
 849             (let ((db (string-append top "/" db-subdir)))
 850               (if (file-exists? db)
 851                   (find-files db "\\.conf$")
 852                   '())))
 853
 854           (define (copy-conf-file conf)
 855             (let ((base (basename conf)))
 856               (copy-file conf (string-append db-dir "/" base))))
 857
 858           (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
 859           (for-each copy-conf-file
 860                     (append-map conf-files
 861                                 (delete-duplicates
 862                                  '#$(manifest-inputs manifest))))
 863           (let ((success
 864                  (zero?
 865                   (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
 866                            (string-append "--package-db=" db-dir)))))
 867             (for-each delete-file (find-files db-dir "\\.conf$"))
 868             (exit success)))))
 869
 870   (with-monad %store-monad
 871     ;; Don't depend on GHC when there's nothing to do.
 872     (if (any (cut string-prefix? "ghc" <>)
 873              (map manifest-entry-name (manifest-entries manifest)))
 874         (gexp->derivation "ghc-package-cache" build
 875                           #:local-build? #t
 876                           #:substitutable? #f
 877                           #:properties
 878                           `((type . profile-hook)
 879                             (hook . ghc-package-cache)))
 880         (return #f))))
 881
 882 (define (ca-certificate-bundle manifest)
 883   "Return a derivation that builds a single-file bundle containing the CA
 884 certificates in the /etc/ssl/certs sub-directories of the packages in
 885 MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
 886   ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html>
 887   ;; for a discussion.
 888
 889   (define glibc-utf8-locales                      ;lazy reference
 890     (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
 891
 892   (define build
 893     (with-imported-modules '((guix build utils))
 894       #~(begin
 895           (use-modules (guix build utils)
 896                        (rnrs io ports)
 897                        (srfi srfi-1)
 898                        (srfi srfi-26)
 899                        (ice-9 ftw)
 900                        (ice-9 match))
 901
 902           (define (pem-file? file)
 903             (string-suffix? ".pem" file))
 904
 905           (define (ca-files top)
 906             (let ((cert-dir (string-append top "/etc/ssl/certs")))
 907               (map (cut string-append cert-dir "/" <>)
 908                    (or (scandir cert-dir pem-file?) '()))))
 909
 910           (define (concatenate-files files result)
 911             "Make RESULT the concatenation of all of FILES."
 912             (define (dump file port)
 913               (display (call-with-input-file file get-string-all)
 914                        port)
 915               (newline port))  ;required, see <https://bugs.debian.org/635570>
 916
 917             (call-with-output-file result
 918               (lambda (port)
 919                 (for-each (cut dump <> port) files))))
 920
 921           ;; Some file names in the NSS certificates are UTF-8 encoded so
 922           ;; install a UTF-8 locale.
 923           (setenv "LOCPATH"
 924                   (string-append #+glibc-utf8-locales "/lib/locale/"
 925                                  #+(version-major+minor
 926                                     (package-version glibc-utf8-locales))))
 927           (setlocale LC_ALL "en_US.utf8")
 928
 929           (match (append-map ca-files '#$(manifest-inputs manifest))
 930             (()
 931              ;; Since there are no CA files, just create an empty directory.  Do
 932              ;; not create the etc/ssl/certs sub-directory, since that would
 933              ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be
 934              ;; defined.
 935              (mkdir #$output)
 936              #t)
 937             ((ca-files ...)
 938              (let ((result (string-append #$output "/etc/ssl/certs")))
 939                (mkdir-p result)
 940                (concatenate-files ca-files
 941                                   (string-append result
 942                                                  "/ca-certificates.crt"))
 943                #t))))))
 944
 945   (gexp->derivation "ca-certificate-bundle" build
 946                     #:local-build? #t
 947                     #:substitutable? #f
 948                     #:properties
 949                     `((type . profile-hook)
 950                       (hook . ca-certificate-bundle))))
 951
 952 (define (glib-schemas manifest)
 953   "Return a derivation that unions all schemas from manifest entries and
 954 creates the Glib 'gschemas.compiled' file."
 955   (define glib  ; lazy reference
 956     (module-ref (resolve-interface '(gnu packages glib)) 'glib))
 957
 958   (mlet %store-monad ((%glib (manifest-lookup-package manifest "glib"))
 959                       ;; XXX: Can't use glib-compile-schemas corresponding
 960                       ;; to the glib referenced by 'manifest'.  Because
 961                       ;; '%glib' can be either a package or store path, and
 962                       ;; there's no way to get the "bin" output for the later.
 963                       (glib-compile-schemas
 964                        -> #~(string-append #+glib:bin
 965                                            "/bin/glib-compile-schemas")))
 966
 967     (define build
 968       (with-imported-modules '((guix build utils)
 969                                (guix build union)
 970                                (guix build profiles)
 971                                (guix search-paths)
 972                                (guix records))
 973         #~(begin
 974             (use-modules (guix build utils)
 975                          (guix build union)
 976                          (guix build profiles)
 977                          (srfi srfi-26))
 978
 979             (let* ((destdir  (string-append #$output "/share/glib-2.0/schemas"))
 980                    (schemadirs (filter file-exists?
 981                                      (map (cut string-append <> "/share/glib-2.0/schemas")
 982                                           '#$(manifest-inputs manifest)))))
 983
 984               ;; Union all the schemas.
 985               (mkdir-p (string-append #$output "/share/glib-2.0"))
 986               (union-build destdir schemadirs
 987                            #:log-port (%make-void-port "w"))
 988
 989               (let ((dir destdir))
 990                  (when (file-is-directory? dir)
 991                    (ensure-writable-directory dir)
 992                    (invoke #+glib-compile-schemas
 993                            (string-append "--targetdir=" dir)
 994                            dir)))))))
 995
 996     ;; Don't run the hook when there's nothing to do.
 997     (if %glib
 998         (gexp->derivation "glib-schemas" build
 999                           #:local-build? #t
1000                           #:substitutable? #f
1001                           #:properties
1002                           `((type . profile-hook)
1003                             (hook . glib-schemas)))
1004         (return #f))))
1005
1006 (define (gtk-icon-themes manifest)
1007   "Return a derivation that unions all icon themes from manifest entries and
1008 creates the GTK+ 'icon-theme.cache' file for each theme."
1009   (define gtk+  ; lazy reference
1010     (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+))
1011
1012   (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+"))
1013                       ;; XXX: Can't use gtk-update-icon-cache corresponding
1014                       ;; to the gtk+ referenced by 'manifest'.  Because
1015                       ;; '%gtk+' can be either a package or store path, and
1016                       ;; there's no way to get the "bin" output for the later.
1017                       (gtk-update-icon-cache
1018                        -> #~(string-append #+gtk+:bin
1019                                            "/bin/gtk-update-icon-cache")))
1020
1021     (define build
1022       (with-imported-modules '((guix build utils)
1023                                (guix build union)
1024                                (guix build profiles)
1025                                (guix search-paths)
1026                                (guix records))
1027         #~(begin
1028             (use-modules (guix build utils)
1029                          (guix build union)
1030                          (guix build profiles)
1031                          (srfi srfi-26)
1032                          (ice-9 ftw))
1033
1034             (let* ((destdir  (string-append #$output "/share/icons"))
1035                    (icondirs (filter file-exists?
1036                                      (map (cut string-append <> "/share/icons")
1037                                           '#$(manifest-inputs manifest)))))
1038
1039               ;; Union all the icons.
1040               (mkdir-p (string-append #$output "/share"))
1041               (union-build destdir icondirs
1042                            #:log-port (%make-void-port "w"))
1043
1044               ;; Update the 'icon-theme.cache' file for each icon theme.
1045               (for-each
1046                (lambda (theme)
1047                  (let ((dir (string-append destdir "/" theme)))
1048                    ;; Occasionally DESTDIR contains plain files, such as
1049                    ;; "abiword_48.png".  Ignore these.
1050                    (when (file-is-directory? dir)
1051                      (ensure-writable-directory dir)
1052                      (system* #+gtk-update-icon-cache "-t" dir "--quiet"))))
1053                (scandir destdir (negate (cut member <> '("." "..")))))))))
1054
1055     ;; Don't run the hook when there's nothing to do.
1056     (if %gtk+
1057         (gexp->derivation "gtk-icon-themes" build
1058                           #:local-build? #t
1059                           #:substitutable? #f
1060                           #:properties
1061                           `((type . profile-hook)
1062                             (hook . gtk-icon-themes)))
1063         (return #f))))
1064
1065 (define (gtk-im-modules manifest)
1066   "Return a derivation that builds the cache files for input method modules
1067 for both major versions of GTK+."
1068
1069   (mlet %store-monad ((gtk+   (manifest-lookup-package manifest "gtk+" "3"))
1070                       (gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
1071
1072     (define (build gtk gtk-version query)
1073       (let ((major (string-take gtk-version 1)))
1074         (with-imported-modules '((guix build utils)
1075                                  (guix build union)
1076                                  (guix build profiles)
1077                                  (guix search-paths)
1078                                  (guix records))
1079           #~(begin
1080               (use-modules (guix build utils)
1081                            (guix build union)
1082                            (guix build profiles)
1083                            (ice-9 popen)
1084                            (srfi srfi-1)
1085                            (srfi srfi-26))
1086
1087               (let* ((prefix  (string-append "/lib/gtk-" #$major ".0/"
1088                                              #$gtk-version))
1089                      (destdir (string-append #$output prefix))
1090                      (moddirs (cons (string-append #$gtk prefix "/immodules")
1091                                     (filter file-exists?
1092                                             (map (cut string-append <> prefix "/immodules")
1093                                                  '#$(manifest-inputs manifest)))))
1094                      (modules (append-map (cut find-files <> "\\.so$")
1095                                           moddirs)))
1096
1097                 ;; Generate a new immodules cache file.
1098                 (mkdir-p (string-append #$output prefix))
1099                 (let ((pipe    (apply open-pipe* OPEN_READ #$query modules))
1100                       (outfile (string-append #$output prefix
1101                                               "/immodules-gtk" #$major ".cache")))
1102                   (dynamic-wind
1103                     (const #t)
1104                     (lambda ()
1105                       (call-with-output-file outfile
1106                         (lambda (out)
1107                           (while (not (eof-object? (peek-char pipe)))
1108                             (write-char (read-char pipe) out))))
1109                       #t)
1110                     (lambda ()
1111                       (close-pipe pipe)))))))))
1112
1113     ;; Don't run the hook when there's nothing to do.
1114     (let* ((pkg-gtk+ (module-ref        ; lazy reference
1115                       (resolve-interface '(gnu packages gtk)) 'gtk+))
1116            (gexp #~(begin
1117                      #$(if gtk+
1118                            (build
1119                             gtk+ "3.0.0"
1120                             ;; Use 'gtk-query-immodules-3.0' from the 'bin'
1121                             ;; output of latest gtk+ package.
1122                             #~(string-append
1123                                #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0"))
1124                            #t)
1125                      #$(if gtk+-2
1126                            (build
1127                             gtk+-2 "2.10.0"
1128                             #~(string-append
1129                                #$gtk+-2 "/bin/gtk-query-immodules-2.0"))
1130                            #t))))
1131       (if (or gtk+ gtk+-2)
1132           (gexp->derivation "gtk-im-modules" gexp
1133                             #:local-build? #t
1134                             #:substitutable? #f
1135                             #:properties
1136                             `((type . profile-hook)
1137                               (hook . gtk-im-modules)))
1138           (return #f)))))
1139
1140 (define (xdg-desktop-database manifest)
1141   "Return a derivation that builds the @file{mimeinfo.cache} database from
1142 desktop files.  It's used to query what applications can handle a given
1143 MIME type."
1144   (define desktop-file-utils            ; lazy reference
1145     (module-ref (resolve-interface '(gnu packages freedesktop))
1146                 'desktop-file-utils))
1147
1148   (mlet %store-monad ((glib
1149                        (manifest-lookup-package
1150                         manifest "glib")))
1151     (define build
1152       (with-imported-modules '((guix build utils)
1153                                (guix build union))
1154         #~(begin
1155             (use-modules (srfi srfi-26)
1156                          (guix build utils)
1157                          (guix build union))
1158             (let* ((destdir (string-append #$output "/share/applications"))
1159                    (appdirs (filter file-exists?
1160                                     (map (cut string-append <>
1161                                               "/share/applications")
1162                                          '#$(manifest-inputs manifest))))
1163                    (update-desktop-database (string-append
1164                                              #+desktop-file-utils
1165                                              "/bin/update-desktop-database")))
1166               (mkdir-p (string-append #$output "/share"))
1167               (union-build destdir appdirs
1168                            #:log-port (%make-void-port "w"))
1169               (exit (zero? (system* update-desktop-database destdir)))))))
1170
1171     ;; Don't run the hook when 'glib' is not referenced.
1172     (if glib
1173         (gexp->derivation "xdg-desktop-database" build
1174                           #:local-build? #t
1175                           #:substitutable? #f
1176                           #:properties
1177                           `((type . profile-hook)
1178                             (hook . xdg-desktop-database)))
1179         (return #f))))
1180
1181 (define (xdg-mime-database manifest)
1182   "Return a derivation that builds the @file{mime.cache} database from manifest
1183 entries.  It's used to query the MIME type of a given file."
1184   (define shared-mime-info  ; lazy reference
1185     (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
1186
1187   (mlet %store-monad ((glib
1188                        (manifest-lookup-package
1189                         manifest "glib")))
1190     (define build
1191       (with-imported-modules  '((guix build utils)
1192                                 (guix build union))
1193         #~(begin
1194             (use-modules (srfi srfi-26)
1195                          (guix build utils)
1196                          (guix build union))
1197             (let* ((datadir (string-append #$output "/share"))
1198                    (destdir (string-append datadir "/mime"))
1199                    (pkgdirs (filter file-exists?
1200                                     (map (cut string-append <>
1201                                               "/share/mime/packages")
1202                                          (cons #+shared-mime-info
1203                                                '#$(manifest-inputs manifest)))))
1204                    (update-mime-database (string-append
1205                                           #+shared-mime-info
1206                                           "/bin/update-mime-database")))
1207               (mkdir-p destdir)
1208               (union-build (string-append destdir "/packages") pkgdirs
1209                            #:log-port (%make-void-port "w"))
1210               (setenv "XDG_DATA_HOME" datadir)
1211               (exit (zero? (system* update-mime-database destdir)))))))
1212
1213     ;; Don't run the hook when there are no GLib based applications.
1214     (if glib
1215         (gexp->derivation "xdg-mime-database" build
1216                           #:local-build? #t
1217                           #:substitutable? #f
1218                           #:properties
1219                           `((type . profile-hook)
1220                             (hook . xdg-mime-database)))
1221         (return #f))))
1222
1223 ;; Several font packages may install font files into same directory, so
1224 ;; fonts.dir and fonts.scale file should be generated here, instead of in
1225 ;; packages.
1226 (define (fonts-dir-file manifest)
1227   "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
1228 files for the fonts of the @var{manifest} entries."
1229   (define mkfontscale
1230     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
1231
1232   (define mkfontdir
1233     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir))
1234
1235   (define build
1236     #~(begin
1237         (use-modules (srfi srfi-26)
1238                      (guix build utils)
1239                      (guix build union))
1240         (let ((fonts-dirs (filter file-exists?
1241                                   (map (cut string-append <>
1242                                             "/share/fonts")
1243                                        '#$(manifest-inputs manifest)))))
1244           (mkdir #$output)
1245           (if (null? fonts-dirs)
1246               (exit #t)
1247               (let* ((share-dir   (string-append #$output "/share"))
1248                      (fonts-dir   (string-append share-dir "/fonts"))
1249                      (mkfontscale (string-append #+mkfontscale
1250                                                  "/bin/mkfontscale"))
1251                      (mkfontdir   (string-append #+mkfontdir
1252                                                  "/bin/mkfontdir"))
1253                      (empty-file? (lambda (filename)
1254                                     (call-with-ascii-input-file filename
1255                                       (lambda (p)
1256                                         (eqv? #\0 (read-char p))))))
1257                      (fonts-dir-file "fonts.dir")
1258                      (fonts-scale-file "fonts.scale"))
1259                 (mkdir-p share-dir)
1260                 ;; Create all sub-directories, because we may create fonts.dir
1261                 ;; and fonts.scale files in the sub-directories.
1262                 (union-build fonts-dir fonts-dirs
1263                              #:log-port (%make-void-port "w")
1264                              #:create-all-directories? #t)
1265                 (let ((directories (find-files fonts-dir
1266                                                (lambda (file stat)
1267                                                  (eq? 'directory (stat:type stat)))
1268                                                #:directories? #t)))
1269                   (for-each (lambda (dir)
1270                               (with-directory-excursion dir
1271                                 (when (file-exists? fonts-scale-file)
1272                                   (delete-file fonts-scale-file))
1273                                 (when (file-exists? fonts-dir-file)
1274                                   (delete-file fonts-dir-file))
1275                                 (unless (and (zero? (system* mkfontscale))
1276                                              (zero? (system* mkfontdir)))
1277                                   (exit #f))
1278                                 (when (and (file-exists? fonts-scale-file)
1279                                            (empty-file? fonts-scale-file))
1280                                   (delete-file fonts-scale-file))
1281                                 (when (and (file-exists? fonts-dir-file)
1282                                            (empty-file? fonts-dir-file))
1283                                   (delete-file fonts-dir-file))))
1284                             directories)))))))
1285
1286   (gexp->derivation "fonts-dir" build
1287                     #:modules '((guix build utils)
1288                                 (guix build union)
1289                                 (srfi srfi-26))
1290                     #:local-build? #t
1291                     #:substitutable? #f
1292                     #:properties
1293                     `((type . profile-hook)
1294                       (hook . fonts-dir))))
1295
1296 (define (manual-database manifest)
1297   "Return a derivation that builds the manual page database (\"mandb\") for
1298 the entries in MANIFEST."
1299   (define gdbm-ffi
1300     (module-ref (resolve-interface '(gnu packages guile))
1301                 'guile-gdbm-ffi))
1302
1303   (define zlib
1304     (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
1305
1306   (define config.scm
1307     (scheme-file "config.scm"
1308                  #~(begin
1309                      (define-module #$'(guix config) ;placate Geiser
1310                        #:export (%libz))
1311
1312                      (define %libz
1313                        #+(file-append zlib "/lib/libz")))))
1314
1315   (define modules
1316     (cons `((guix config) => ,config.scm)
1317           (delete '(guix config)
1318                   (source-module-closure `((guix build utils)
1319                                            (guix man-db))))))
1320
1321   (define build
1322     (with-imported-modules modules
1323       (with-extensions (list gdbm-ffi)            ;for (guix man-db)
1324         #~(begin
1325             (use-modules (guix man-db)
1326                          (guix build utils)
1327                          (srfi srfi-1)
1328                          (srfi srfi-19))
1329
1330             (define (compute-entries)
1331               ;; This is the most expensive part (I/O and CPU, due to
1332               ;; decompression), so report progress as we traverse INPUTS.
1333               (let* ((inputs '#$(manifest-inputs manifest))
1334                      (total  (length inputs)))
1335                 (append-map (lambda (directory count)
1336                               (format #t "\r[~3d/~3d] building list of \
1337 man-db entries..."
1338                                       count total)
1339                               (force-output)
1340                               (let ((man (string-append directory
1341                                                         "/share/man")))
1342                                 (if (directory-exists? man)
1343                                     (mandb-entries man)
1344                                     '())))
1345                             inputs
1346                             (iota total 1))))
1347
1348             (define man-directory
1349               (string-append #$output "/share/man"))
1350
1351             (mkdir-p man-directory)
1352
1353             (format #t "Creating manual page database...~%")
1354             (force-output)
1355             (let* ((start    (current-time))
1356                    (entries  (compute-entries))
1357                    (_        (write-mandb-database (string-append man-directory
1358                                                                   "/index.db")
1359                                                    entries))
1360                    (duration (time-difference (current-time) start)))
1361               (newline)
1362               (format #t "~a entries processed in ~,1f s~%"
1363                       (length entries)
1364                       (+ (time-second duration)
1365                          (* (time-nanosecond duration) (expt 10 -9))))
1366               (force-output))))))
1367
1368   (gexp->derivation "manual-database" build
1369
1370                     ;; Work around GDBM 1.13 issue whereby uninitialized bytes
1371                     ;; get written to disk:
1372                     ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
1373                     #:env-vars `(("MALLOC_PERTURB_" . "1"))
1374
1375                     #:local-build? #t
1376                     #:properties
1377                     `((type . profile-hook)
1378                       (hook . manual-database))))
1379
1380 (define (texlive-configuration manifest)
1381   "Return a derivation that builds a TeXlive configuration for the entries in
1382 MANIFEST."
1383   (define entry->texlive-input
1384     (match-lambda
1385       (($ <manifest-entry> name version output thing deps)
1386        (if (string-prefix? "texlive-" name)
1387            (cons (gexp-input thing output)
1388                  (append-map entry->texlive-input deps))
1389            '()))))
1390   (define build
1391     (with-imported-modules '((guix build utils)
1392                              (guix build union))
1393       #~(begin
1394           (use-modules (guix build utils)
1395                        (guix build union))
1396
1397           ;; Build a modifiable union of all texlive inputs.  We do this so
1398           ;; that TeX live can resolve the parent and grandparent directories
1399           ;; correctly.  There might be a more elegant way to accomplish this.
1400           (union-build #$output
1401                        '#$(append-map entry->texlive-input
1402                                       (manifest-entries manifest))
1403                        #:create-all-directories? #t
1404                        #:log-port (%make-void-port "w"))
1405           (let ((texmf.cnf (string-append
1406                             #$output
1407                             "/share/texmf-dist/web2c/texmf.cnf")))
1408             (when (file-exists? texmf.cnf)
1409               (substitute* texmf.cnf
1410                 (("^TEXMFROOT = .*")
1411                  (string-append "TEXMFROOT = " #$output "/share\n"))
1412                 (("^TEXMF = .*")
1413                  "TEXMF = $TEXMFROOT/share/texmf-dist\n"))))
1414           #t)))
1415
1416     (with-monad %store-monad
1417       (if (any (cut string-prefix? "texlive-" <>)
1418                (map manifest-entry-name (manifest-entries manifest)))
1419           (gexp->derivation "texlive-configuration" build
1420                             #:substitutable? #f
1421                             #:local-build? #t
1422                             #:properties
1423                             `((type . profile-hook)
1424                               (hook . texlive-configuration)))
1425           (return #f))))
1426
1427 (define %default-profile-hooks
1428   ;; This is the list of derivation-returning procedures that are called by
1429   ;; default when making a non-empty profile.
1430   (list info-dir-file
1431         manual-database
1432         fonts-dir-file
1433         ghc-package-cache-file
1434         ca-certificate-bundle
1435         glib-schemas
1436         gtk-icon-themes
1437         gtk-im-modules
1438         texlive-configuration
1439         xdg-desktop-database
1440         xdg-mime-database))
1441
1442 (define* (profile-derivation manifest
1443                              #:key
1444                              (hooks %default-profile-hooks)
1445                              (locales? #t)
1446                              (allow-collisions? #f)
1447                              (relative-symlinks? #f)
1448                              system target)
1449   "Return a derivation that builds a profile (aka. 'user environment') with
1450 the given MANIFEST.  The profile includes additional derivations returned by
1451 the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
1452 Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if
1453 entries in MANIFEST collide (for instance if there are two same-name packages
1454 with a different version number.)
1455
1456 When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
1457 a dependency on the 'glibc-utf8-locales' package.
1458
1459 When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets.
1460 This is one of the things to do for the result to be relocatable.
1461
1462 When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
1463 are cross-built for TARGET."
1464   (mlet* %store-monad ((system (if system
1465                                    (return system)
1466                                    (current-system)))
1467                        (target (if target
1468                                    (return target)
1469                                    (current-target-system)))
1470                        (ok?    (if allow-collisions?
1471                                    (return #t)
1472                                    (check-for-collisions manifest system
1473                                                          #:target target)))
1474                        (extras (if (null? (manifest-entries manifest))
1475                                    (return '())
1476                                    (mapm %store-monad
1477                                          (lambda (hook)
1478                                            (hook manifest))
1479                                          hooks))))
1480     (define inputs
1481       (append (filter-map (lambda (drv)
1482                             (and (derivation? drv)
1483                                  (gexp-input drv)))
1484                           extras)
1485               (manifest-inputs manifest)))
1486
1487     (define glibc-utf8-locales                    ;lazy reference
1488       (module-ref (resolve-interface '(gnu packages base))
1489                   'glibc-utf8-locales))
1490
1491     (define set-utf8-locale
1492       ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so
1493       ;; install a UTF-8 locale.
1494       #~(begin
1495           (setenv "LOCPATH"
1496                   #$(file-append glibc-utf8-locales "/lib/locale/"
1497                                  (version-major+minor
1498                                   (package-version glibc-utf8-locales))))
1499           (setlocale LC_ALL "en_US.utf8")))
1500
1501     (define builder
1502       (with-imported-modules '((guix build profiles)
1503                                (guix build union)
1504                                (guix build utils)
1505                                (guix search-paths)
1506                                (guix records))
1507         #~(begin
1508             (use-modules (guix build profiles)
1509                          (guix search-paths)
1510                          (srfi srfi-1))
1511
1512             (setvbuf (current-output-port) _IOLBF)
1513             (setvbuf (current-error-port) _IOLBF)
1514
1515             #+(if locales? set-utf8-locale #t)
1516
1517             (define search-paths
1518               ;; Search paths of MANIFEST's packages, converted back to their
1519               ;; record form.
1520               (map sexp->search-path-specification
1521                    (delete-duplicates
1522                     '#$(map search-path-specification->sexp
1523                             (manifest-search-paths manifest)))))
1524
1525             (build-profile #$output '#$inputs
1526                            #:symlink #$(if relative-symlinks?
1527                                            #~symlink-relative
1528                                            #~symlink)
1529                            #:manifest '#$(manifest->gexp manifest)
1530                            #:search-paths search-paths))))
1531
1532     (gexp->derivation "profile" builder
1533                       #:system system
1534                       #:target target
1535
1536                       ;; Don't complain about _IO* on Guile 2.2.
1537                       #:env-vars '(("GUILE_WARN_DEPRECATED" . "no"))
1538
1539                       ;; Not worth offloading.
1540                       #:local-build? #t
1541
1542                       ;; Disable substitution because it would trigger a
1543                       ;; connection to the substitute server, which is likely
1544                       ;; to have no substitute to offer.
1545                       #:substitutable? #f)))
1546
1547 (define* (profile-search-paths profile
1548                                #:optional (manifest (profile-manifest profile))
1549                                #:key (getenv (const #f)))
1550   "Read the manifest of PROFILE and evaluate the values of search path
1551 environment variables required by PROFILE; return a list of
1552 specification/value pairs.  If MANIFEST is not #f, it is assumed to be the
1553 manifest of PROFILE, which avoids rereading it.
1554
1555 Use GETENV to determine the current settings and report only settings not
1556 already effective."
1557   (evaluate-search-paths (manifest-search-paths manifest)
1558                          (list profile) getenv))
1559
1560 (define (profile-regexp profile)
1561   "Return a regular expression that matches PROFILE's name and number."
1562   (make-regexp (string-append "^" (regexp-quote (basename profile))
1563                               "-([0-9]+)")))
1564
1565 (define (generation-number profile)
1566   "Return PROFILE's number or 0.  An absolute file name must be used."
1567   (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
1568                                               (basename (readlink profile))))
1569              (compose string->number (cut match:substring <> 1)))
1570       0))
1571
1572 (define %profile-generation-rx
1573   ;; Regexp that matches profile generation.
1574   (make-regexp "(.*)-([0-9]+)-link$"))
1575
1576 (define (generation-profile file)
1577   "If FILE is a profile generation GC root such as \"guix-profile-42-link\",
1578 return its corresponding profile---e.g., \"guix-profile\".  Otherwise return
1579 #f."
1580   (match (regexp-exec %profile-generation-rx file)
1581     (#f #f)
1582     (m  (let ((profile (match:substring m 1)))
1583           (and (file-exists? (string-append profile "/manifest"))
1584                profile)))))
1585
1586 (define (generation-numbers profile)
1587   "Return the sorted list of generation numbers of PROFILE, or '(0) if no
1588 former profiles were found."
1589   (match (scandir (dirname profile)
1590                   (cute regexp-exec (profile-regexp profile) <>))
1591     (#f                                         ; no profile directory
1592      '(0))
1593     (()                                         ; no profiles
1594      '(0))
1595     ((profiles ...)                             ; former profiles around
1596      (sort (map (compose string->number
1597                          (cut match:substring <> 1)
1598                          (cute regexp-exec (profile-regexp profile) <>))
1599                 profiles)
1600            <))))
1601
1602 (define (profile-generations profile)
1603   "Return a list of PROFILE's generations."
1604   (let ((generations (generation-numbers profile)))
1605     (if (equal? generations '(0))
1606         '()
1607         generations)))
1608
1609 (define (relative-generation-spec->number profile spec)
1610   "Return PROFILE's generation specified by SPEC, which is a string.  The SPEC
1611 may be a N, -N, or +N, where N is a number.  If the spec is N, then the number
1612 returned is N.  If it is -N, then the number returned is the profile's current
1613 generation number minus N.  If it is +N, then the number returned is the
1614 profile's current generation number plus N.  Return #f if there is no such
1615 generation."
1616   (let ((number (string->number spec)))
1617     (and number
1618          (case (string-ref spec 0)
1619            ((#\+ #\-)
1620             (relative-generation profile number))
1621            (else (if (memv number (profile-generations profile))
1622                      number
1623                      #f))))))
1624
1625
1626 (define* (relative-generation profile shift #:optional
1627                               (current (generation-number profile)))
1628   "Return PROFILE's generation shifted from the CURRENT generation by SHIFT.
1629 SHIFT is a positive or negative number.
1630 Return #f if there is no such generation."
1631   (let* ((abs-shift (abs shift))
1632          (numbers (profile-generations profile))
1633          (from-current (memq current
1634                              (if (negative? shift)
1635                                  (reverse numbers)
1636                                  numbers))))
1637     (and from-current
1638          (< abs-shift (length from-current))
1639          (list-ref from-current abs-shift))))
1640
1641 (define* (previous-generation-number profile #:optional
1642                                      (number (generation-number profile)))
1643   "Return the number of the generation before generation NUMBER of
1644 PROFILE, or 0 if none exists.  It could be NUMBER - 1, but it's not the
1645 case when generations have been deleted (there are \"holes\")."
1646   (or (relative-generation profile -1 number)
1647       0))
1648
1649 (define (generation-file-name profile generation)
1650   "Return the file name for PROFILE's GENERATION."
1651   (format #f "~a-~a-link" profile generation))
1652
1653 (define (generation-time profile number)
1654   "Return the creation time of a generation in the UTC format."
1655   (make-time time-utc 0
1656              (stat:ctime (stat (generation-file-name profile number)))))
1657
1658 (define (link-to-empty-profile store generation)
1659   "Link GENERATION, a string, to the empty profile.  An error is raised if
1660 that fails."
1661   (let* ((drv  (run-with-store store
1662                  (profile-derivation (manifest '())
1663                                      #:locales? #f)))
1664          (prof (derivation->output-path drv "out")))
1665     (build-derivations store (list drv))
1666     (switch-symlinks generation prof)))
1667
1668 (define (switch-to-generation profile number)
1669   "Atomically switch PROFILE to the generation NUMBER.  Return the number of
1670 the generation that was current before switching."
1671   (let ((current    (generation-number profile))
1672         (generation (generation-file-name profile number)))
1673     (cond ((not (file-exists? profile))
1674            (raise (condition (&profile-not-found-error
1675                               (profile profile)))))
1676           ((not (file-exists? generation))
1677            (raise (condition (&missing-generation-error
1678                               (profile profile)
1679                               (generation number)))))
1680           (else
1681            (switch-symlinks profile (basename generation))
1682            current))))
1683
1684 (define (switch-to-previous-generation profile)
1685   "Atomically switch PROFILE to the previous generation.  Return the former
1686 generation number and the current one."
1687   (let ((previous (previous-generation-number profile)))
1688     (values (switch-to-generation profile previous)
1689             previous)))
1690
1691 (define (roll-back store profile)
1692   "Roll back to the previous generation of PROFILE.  Return the number of the
1693 generation that was current before switching and the new generation number."
1694   (let* ((number              (generation-number profile))
1695          (previous-number     (previous-generation-number profile number))
1696          (previous-generation (generation-file-name profile previous-number)))
1697     (cond ((not (file-exists? profile))           ;invalid profile
1698            (raise (condition (&profile-not-found-error
1699                               (profile profile)))))
1700           ((zero? number)                         ;empty profile
1701            (values number number))
1702           ((or (zero? previous-number)            ;going to emptiness
1703                (not (file-exists? previous-generation)))
1704            (link-to-empty-profile store previous-generation)
1705            (switch-to-previous-generation profile))
1706           (else                                   ;anything else
1707            (switch-to-previous-generation profile)))))
1708
1709 (define (delete-generation store profile number)
1710   "Delete generation with NUMBER from PROFILE.  Return the file name of the
1711 generation that has been deleted, or #f if nothing was done (for instance
1712 because the NUMBER is zero.)"
1713   (define (delete-and-return)
1714     (let ((generation (generation-file-name profile number)))
1715       (delete-file generation)
1716       generation))
1717
1718   (let* ((current-number      (generation-number profile))
1719          (previous-number     (previous-generation-number profile number))
1720          (previous-generation (generation-file-name profile previous-number)))
1721     (cond ((zero? number) #f)                     ;do not delete generation 0
1722           ((and (= number current-number)
1723                 (not (file-exists? previous-generation)))
1724            (link-to-empty-profile store previous-generation)
1725            (switch-to-previous-generation profile)
1726            (delete-and-return))
1727           ((= number current-number)
1728            (roll-back store profile)
1729            (delete-and-return))
1730           (else
1731            (delete-and-return)))))
1732
1733 (define %user-profile-directory
1734   (and=> (getenv "HOME")
1735          (cut string-append <> "/.guix-profile")))
1736
1737 (define %profile-directory
1738   (string-append %state-directory "/profiles/"
1739                  (or (and=> (or (getenv "USER")
1740                                 (getenv "LOGNAME")
1741                                 (false-if-exception
1742                                  (passwd:name (getpwuid (getuid)))))
1743                             (cut string-append "per-user/" <>))
1744                      "default")))
1745
1746 (define %current-profile
1747   ;; Call it `guix-profile', not `profile', to allow Guix profiles to
1748   ;; coexist with Nix profiles.
1749   (string-append %profile-directory "/guix-profile"))
1750
1751 (define (ensure-profile-directory)
1752   "Attempt to create /…/profiles/per-user/$USER if needed.  Nowadays this is
1753 taken care of by the daemon."
1754   (let ((s (stat %profile-directory #f)))
1755     (unless (and s (eq? 'directory (stat:type s)))
1756       (catch 'system-error
1757         (lambda ()
1758           (mkdir-p %profile-directory))
1759         (lambda args
1760           ;; Often, we cannot create %PROFILE-DIRECTORY because its
1761           ;; parent directory is root-owned and we're running
1762           ;; unprivileged.
1763           (raise (condition
1764                   (&message
1765                    (message
1766                     (format #f
1767                             (G_ "while creating directory `~a': ~a")
1768                             %profile-directory
1769                             (strerror (system-error-errno args)))))
1770                   (&fix-hint
1771                    (hint
1772                     (format #f (G_ "Please create the @file{~a} directory, \
1773 with you as the owner.")
1774                             %profile-directory))))))))
1775
1776     ;; Bail out if it's not owned by the user.
1777     (unless (or (not s) (= (stat:uid s) (getuid)))
1778       (raise (condition
1779               (&message
1780                (message
1781                 (format #f (G_ "directory `~a' is not owned by you")
1782                         %profile-directory)))
1783               (&fix-hint
1784                (hint
1785                 (format #f (G_ "Please change the owner of @file{~a} \
1786 to user ~s.")
1787                         %profile-directory (or (getenv "USER")
1788                                                (getenv "LOGNAME")
1789                                                (getuid))))))))))
1790
1791 (define (canonicalize-profile profile)
1792   "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that.
1793 Otherwise return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile'
1794 as if '-p' was omitted."  ; see <http://bugs.gnu.org/17939>
1795   ;; Trim trailing slashes so 'readlink' can do its job.
1796   (let ((profile (string-trim-right profile #\/)))
1797     (catch 'system-error
1798       (lambda ()
1799         (let ((target (readlink profile)))
1800           (if (string=? (dirname target) %profile-directory)
1801               target
1802               profile)))
1803       (const profile))))
1804
1805 (define %known-shorthand-profiles
1806   ;; Known shorthand forms for profiles that the user manipulates.
1807   (list (string-append (config-directory #:ensure? #f) "/current")
1808         %user-profile-directory))
1809
1810 (define (user-friendly-profile profile)
1811   "Return either ~/.guix-profile or ~/.config/guix/current if that's what
1812 PROFILE refers to, directly or indirectly, or PROFILE."
1813   (or (find (lambda (shorthand)
1814               (and shorthand
1815                    (let ((target (false-if-exception
1816                                   (readlink shorthand))))
1817                      (and target (string=? target profile)))))
1818             %known-shorthand-profiles)
1819       profile))
1820
1821 ;;; profiles.scm ends here