guix/profiles.scm

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