guix/profiles.scm

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