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