guix/profiles.scm

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