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