guix/profiles.scm

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