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
1209   (define guile-zlib
1210     (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
1211
1212   (define build
1213     (with-imported-modules (source-module-closure
1214                             '((guix build utils)
1215                               (gnu build linux-modules)))
1216       (with-extensions (list guile-zlib)
1217         #~(begin
1218             (use-modules (ice-9 ftw)
1219                          (ice-9 match)
1220                          (srfi srfi-1)              ; append-map
1221                          (gnu build linux-modules))
1222
1223             (let* ((inputs '#$(manifest-inputs manifest))
1224                    (module-directories
1225                     (map (lambda (directory)
1226                            (string-append directory "/lib/modules"))
1227                          inputs))
1228                    (directory-entries
1229                     (lambda (directory)
1230                       (or (scandir directory
1231                                    (lambda (basename)
1232                                      (not (string-prefix? "." basename))))
1233                           '())))
1234                    ;; Note: Should usually result in one entry.
1235                    (versions (delete-duplicates
1236                               (append-map directory-entries
1237                                           module-directories))))
1238               (match versions
1239                 ((version)
1240                  (let ((old-path (getenv "PATH")))
1241                    (setenv "PATH" #+(file-append kmod "/bin"))
1242                    (make-linux-module-directory inputs version #$output)
1243                    (setenv "PATH" old-path)))
1244                 (()
1245                  ;; Nothing here, maybe because this is a kernel with
1246                  ;; CONFIG_MODULES=n.
1247                  (mkdir #$output))
1248                 (_ (error "Specified Linux kernel and Linux kernel modules
1249 are not all of the same version"))))))))
1250   (gexp->derivation "linux-module-database" build
1251                     #:local-build? #t
1252                     #:substitutable? #f
1253                     #:properties
1254                     `((type . profile-hook)
1255                       (hook . linux-module-database))))
1256
1257 (define (xdg-desktop-database manifest)
1258   "Return a derivation that builds the @file{mimeinfo.cache} database from
1259 desktop files.  It's used to query what applications can handle a given
1260 MIME type."
1261   (define desktop-file-utils            ; lazy reference
1262     (module-ref (resolve-interface '(gnu packages freedesktop))
1263                 'desktop-file-utils))
1264
1265   (mlet %store-monad ((glib
1266                        (manifest-lookup-package
1267                         manifest "glib")))
1268     (define build
1269       (with-imported-modules '((guix build utils)
1270                                (guix build union))
1271         #~(begin
1272             (use-modules (srfi srfi-26)
1273                          (guix build utils)
1274                          (guix build union))
1275             (let* ((destdir (string-append #$output "/share/applications"))
1276                    (appdirs (filter file-exists?
1277                                     (map (cut string-append <>
1278                                               "/share/applications")
1279                                          '#$(manifest-inputs manifest))))
1280                    (update-desktop-database (string-append
1281                                              #+desktop-file-utils
1282                                              "/bin/update-desktop-database")))
1283               (mkdir-p (string-append #$output "/share"))
1284               (union-build destdir appdirs
1285                            #:log-port (%make-void-port "w"))
1286               (exit (zero? (system* update-desktop-database destdir)))))))
1287
1288     ;; Don't run the hook when 'glib' is not referenced.
1289     (if glib
1290         (gexp->derivation "xdg-desktop-database" build
1291                           #:local-build? #t
1292                           #:substitutable? #f
1293                           #:properties
1294                           `((type . profile-hook)
1295                             (hook . xdg-desktop-database)))
1296         (return #f))))
1297
1298 (define (xdg-mime-database manifest)
1299   "Return a derivation that builds the @file{mime.cache} database from manifest
1300 entries.  It's used to query the MIME type of a given file."
1301   (define shared-mime-info  ; lazy reference
1302     (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
1303
1304   (mlet %store-monad ((glib
1305                        (manifest-lookup-package
1306                         manifest "glib")))
1307     (define build
1308       (with-imported-modules  '((guix build utils)
1309                                 (guix build union))
1310         #~(begin
1311             (use-modules (srfi srfi-26)
1312                          (guix build utils)
1313                          (guix build union))
1314             (let* ((datadir (string-append #$output "/share"))
1315                    (destdir (string-append datadir "/mime"))
1316                    (pkgdirs (filter file-exists?
1317                                     (map (cut string-append <>
1318                                               "/share/mime/packages")
1319                                          (cons #+shared-mime-info
1320                                                '#$(manifest-inputs manifest)))))
1321                    (update-mime-database (string-append
1322                                           #+shared-mime-info
1323                                           "/bin/update-mime-database")))
1324               (mkdir-p destdir)
1325               (union-build (string-append destdir "/packages") pkgdirs
1326                            #:log-port (%make-void-port "w"))
1327               (setenv "XDG_DATA_HOME" datadir)
1328               (exit (zero? (system* update-mime-database destdir)))))))
1329
1330     ;; Don't run the hook when there are no GLib based applications.
1331     (if glib
1332         (gexp->derivation "xdg-mime-database" build
1333                           #:local-build? #t
1334                           #:substitutable? #f
1335                           #:properties
1336                           `((type . profile-hook)
1337                             (hook . xdg-mime-database)))
1338         (return #f))))
1339
1340 ;; Several font packages may install font files into same directory, so
1341 ;; fonts.dir and fonts.scale file should be generated here, instead of in
1342 ;; packages.
1343 (define (fonts-dir-file manifest)
1344   "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
1345 files for the fonts of the @var{manifest} entries."
1346   (define mkfontscale
1347     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
1348
1349   (define mkfontdir
1350     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir))
1351
1352   (define build
1353     #~(begin
1354         (use-modules (srfi srfi-26)
1355                      (guix build utils)
1356                      (guix build union))
1357         (let ((fonts-dirs (filter file-exists?
1358                                   (map (cut string-append <>
1359                                             "/share/fonts")
1360                                        '#$(manifest-inputs manifest)))))
1361           (mkdir #$output)
1362           (if (null? fonts-dirs)
1363               (exit #t)
1364               (let* ((share-dir   (string-append #$output "/share"))
1365                      (fonts-dir   (string-append share-dir "/fonts"))
1366                      (mkfontscale (string-append #+mkfontscale
1367                                                  "/bin/mkfontscale"))
1368                      (mkfontdir   (string-append #+mkfontdir
1369                                                  "/bin/mkfontdir"))
1370                      (empty-file? (lambda (filename)
1371                                     (call-with-ascii-input-file filename
1372                                       (lambda (p)
1373                                         (eqv? #\0 (read-char p))))))
1374                      (fonts-dir-file "fonts.dir")
1375                      (fonts-scale-file "fonts.scale"))
1376                 (mkdir-p share-dir)
1377                 ;; Create all sub-directories, because we may create fonts.dir
1378                 ;; and fonts.scale files in the sub-directories.
1379                 (union-build fonts-dir fonts-dirs
1380                              #:log-port (%make-void-port "w")
1381                              #:create-all-directories? #t)
1382                 (let ((directories (find-files fonts-dir
1383                                                (lambda (file stat)
1384                                                  (eq? 'directory (stat:type stat)))
1385                                                #:directories? #t)))
1386                   (for-each (lambda (dir)
1387                               (with-directory-excursion dir
1388                                 (when (file-exists? fonts-scale-file)
1389                                   (delete-file fonts-scale-file))
1390                                 (when (file-exists? fonts-dir-file)
1391                                   (delete-file fonts-dir-file))
1392                                 (unless (and (zero? (system* mkfontscale))
1393                                              (zero? (system* mkfontdir)))
1394                                   (exit #f))
1395                                 (when (and (file-exists? fonts-scale-file)
1396                                            (empty-file? fonts-scale-file))
1397                                   (delete-file fonts-scale-file))
1398                                 (when (and (file-exists? fonts-dir-file)
1399                                            (empty-file? fonts-dir-file))
1400                                   (delete-file fonts-dir-file))))
1401                             directories)))))))
1402
1403   (gexp->derivation "fonts-dir" build
1404                     #:modules '((guix build utils)
1405                                 (guix build union)
1406                                 (srfi srfi-26))
1407                     #:local-build? #t
1408                     #:substitutable? #f
1409                     #:properties
1410                     `((type . profile-hook)
1411                       (hook . fonts-dir))))
1412
1413 (define (manual-database manifest)
1414   "Return a derivation that builds the manual page database (\"mandb\") for
1415 the entries in MANIFEST."
1416   (define gdbm-ffi
1417     (module-ref (resolve-interface '(gnu packages guile))
1418                 'guile-gdbm-ffi))
1419
1420   (define guile-zlib
1421     (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
1422
1423   (define modules
1424     (delete '(guix config)
1425             (source-module-closure `((guix build utils)
1426                                      (guix man-db)))))
1427
1428   (define build
1429     (with-imported-modules modules
1430       (with-extensions (list gdbm-ffi           ;for (guix man-db)
1431                              guile-zlib)
1432         #~(begin
1433             (use-modules (guix man-db)
1434                          (guix build utils)
1435                          (ice-9 threads)
1436                          (srfi srfi-1)
1437                          (srfi srfi-19))
1438
1439             (define (print-string msg)
1440               (display msg)
1441               (force-output))
1442
1443             (define-syntax-rule (print fmt args ...)
1444               ;; Build up the string and display it at once.
1445               (print-string (format #f fmt args ...)))
1446
1447             (define (compute-entry directory count total)
1448               (print "\r[~3d/~3d] building list of man-db entries..."
1449                      count total)
1450               (let ((man (string-append directory "/share/man")))
1451                 (if (directory-exists? man)
1452                     (mandb-entries man)
1453                     '())))
1454
1455             (define (compute-entries)
1456               ;; This is the most expensive part (I/O and CPU, due to
1457               ;; decompression), so report progress as we traverse INPUTS.
1458               ;; Cap at 4 threads because we don't see any speedup beyond that
1459               ;; on an SSD laptop.
1460               (let* ((inputs  '#$(manifest-inputs manifest))
1461                      (total   (length inputs))
1462                      (threads (min (parallel-job-count) 4)))
1463                 (concatenate
1464                  (n-par-map threads compute-entry inputs
1465                             (iota total 1)
1466                             (make-list total total)))))
1467
1468             (define man-directory
1469               (string-append #$output "/share/man"))
1470
1471             (mkdir-p man-directory)
1472
1473             (format #t "Creating manual page database...~%")
1474             (force-output)
1475             (let* ((start    (current-time))
1476                    (entries  (compute-entries))
1477                    (_        (write-mandb-database (string-append man-directory
1478                                                                   "/index.db")
1479                                                    entries))
1480                    (duration (time-difference (current-time) start)))
1481               (newline)
1482               (format #t "~a entries processed in ~,1f s~%"
1483                       (length entries)
1484                       (+ (time-second duration)
1485                          (* (time-nanosecond duration) (expt 10 -9))))
1486               (force-output))))))
1487
1488   (gexp->derivation "manual-database" build
1489
1490                     ;; Work around GDBM 1.13 issue whereby uninitialized bytes
1491                     ;; get written to disk:
1492                     ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
1493                     #:env-vars `(("MALLOC_PERTURB_" . "1"))
1494
1495                     #:substitutable? #f
1496                     #:local-build? #t
1497                     #:properties
1498                     `((type . profile-hook)
1499                       (hook . manual-database))))
1500
1501 (define (texlive-configuration manifest)
1502   "Return a derivation that builds a TeXlive configuration for the entries in
1503 MANIFEST."
1504   (define entry->texlive-input
1505     (match-lambda
1506       (($ <manifest-entry> name version output thing deps)
1507        (if (string-prefix? "texlive-" name)
1508            (cons (gexp-input thing output)
1509                  (append-map entry->texlive-input deps))
1510            '()))))
1511   (define build
1512     (with-imported-modules '((guix build utils)
1513                              (guix build union))
1514       #~(begin
1515           (use-modules (guix build utils)
1516                        (guix build union))
1517
1518           ;; Build a modifiable union of all texlive inputs.  We do this so
1519           ;; that TeX live can resolve the parent and grandparent directories
1520           ;; correctly.  There might be a more elegant way to accomplish this.
1521           (union-build #$output
1522                        '#$(append-map entry->texlive-input
1523                                       (manifest-entries manifest))
1524                        #:create-all-directories? #t
1525                        #:log-port (%make-void-port "w"))
1526           (let ((texmf.cnf (string-append
1527                             #$output
1528                             "/share/texmf-dist/web2c/texmf.cnf")))
1529             (when (file-exists? texmf.cnf)
1530               (substitute* texmf.cnf
1531                 (("^TEXMFROOT = .*")
1532                  (string-append "TEXMFROOT = " #$output "/share\n"))
1533                 (("^TEXMF = .*")
1534                  "TEXMF = $TEXMFROOT/share/texmf-dist\n"))))
1535           #t)))
1536
1537     (with-monad %store-monad
1538       (if (any (cut string-prefix? "texlive-" <>)
1539                (map manifest-entry-name (manifest-entries manifest)))
1540           (gexp->derivation "texlive-configuration" build
1541                             #:substitutable? #f
1542                             #:local-build? #t
1543                             #:properties
1544                             `((type . profile-hook)
1545                               (hook . texlive-configuration)))
1546           (return #f))))
1547
1548 (define %default-profile-hooks
1549   ;; This is the list of derivation-returning procedures that are called by
1550   ;; default when making a non-empty profile.
1551   (list info-dir-file
1552         manual-database
1553         fonts-dir-file
1554         ghc-package-cache-file
1555         ca-certificate-bundle
1556         glib-schemas
1557         gtk-icon-themes
1558         gtk-im-modules
1559         texlive-configuration
1560         xdg-desktop-database
1561         xdg-mime-database))
1562
1563 (define* (profile-derivation manifest
1564                              #:key
1565                              (name "profile")
1566                              (hooks %default-profile-hooks)
1567                              (locales? #t)
1568                              (allow-collisions? #f)
1569                              (relative-symlinks? #f)
1570                              system target)
1571   "Return a derivation that builds a profile (aka. 'user environment') with
1572 the given MANIFEST.  The profile includes additional derivations returned by
1573 the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
1574 Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if
1575 entries in MANIFEST collide (for instance if there are two same-name packages
1576 with a different version number.)
1577
1578 When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
1579 a dependency on the 'glibc-utf8-locales' package.
1580
1581 When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets.
1582 This is one of the things to do for the result to be relocatable.
1583
1584 When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
1585 are cross-built for TARGET."
1586   (mlet* %store-monad ((system (if system
1587                                    (return system)
1588                                    (current-system)))
1589                        (target (if target
1590                                    (return target)
1591                                    (current-target-system)))
1592                        (ok?    (if allow-collisions?
1593                                    (return #t)
1594                                    (check-for-collisions manifest system
1595                                                          #:target target)))
1596                        (extras (if (null? (manifest-entries manifest))
1597                                    (return '())
1598                                    (mapm/accumulate-builds (lambda (hook)
1599                                                              (hook manifest))
1600                                                            hooks))))
1601     (define inputs
1602       (append (filter-map (lambda (drv)
1603                             (and (derivation? drv)
1604                                  (gexp-input drv)))
1605                           extras)
1606               (manifest-inputs manifest)))
1607
1608     (define glibc-utf8-locales                    ;lazy reference
1609       (module-ref (resolve-interface '(gnu packages base))
1610                   'glibc-utf8-locales))
1611
1612     (define set-utf8-locale
1613       ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so
1614       ;; install a UTF-8 locale.
1615       #~(begin
1616           (setenv "LOCPATH"
1617                   #$(file-append glibc-utf8-locales "/lib/locale/"
1618                                  (version-major+minor
1619                                   (package-version glibc-utf8-locales))))
1620           (setlocale LC_ALL "en_US.utf8")))
1621
1622     (define builder
1623       (with-imported-modules '((guix build profiles)
1624                                (guix build union)
1625                                (guix build utils)
1626                                (guix search-paths)
1627                                (guix records))
1628         #~(begin
1629             (use-modules (guix build profiles)
1630                          (guix search-paths)
1631                          (srfi srfi-1))
1632
1633             (let ((line (cond-expand (guile-2.2 'line)
1634                                      (else _IOLBF)))) ;Guile 2.0
1635               (setvbuf (current-output-port) line)
1636               (setvbuf (current-error-port) line))
1637
1638             #+(if locales? set-utf8-locale #t)
1639
1640             (define search-paths
1641               ;; Search paths of MANIFEST's packages, converted back to their
1642               ;; record form.
1643               (map sexp->search-path-specification
1644                    (delete-duplicates
1645                     '#$(map search-path-specification->sexp
1646                             (manifest-search-paths manifest)))))
1647
1648             (build-profile #$output '#$inputs
1649                            #:symlink #$(if relative-symlinks?
1650                                            #~symlink-relative
1651                                            #~symlink)
1652                            #:manifest '#$(manifest->gexp manifest)
1653                            #:search-paths search-paths))))
1654
1655     (gexp->derivation name builder
1656                       #:system system
1657                       #:target target
1658
1659                       ;; Don't complain about _IO* on Guile 2.2.
1660                       #:env-vars '(("GUILE_WARN_DEPRECATED" . "no"))
1661
1662                       ;; Not worth offloading.
1663                       #:local-build? #t
1664
1665                       ;; Disable substitution because it would trigger a
1666                       ;; connection to the substitute server, which is likely
1667                       ;; to have no substitute to offer.
1668                       #:substitutable? #f
1669
1670                       #:properties `((type . profile)
1671                                      (profile
1672                                       (count
1673                                        . ,(length
1674                                            (manifest-entries manifest))))))))
1675
1676 ;; Declarative profile.
1677 (define-record-type* <profile> profile make-profile
1678   profile?
1679   (name               profile-name (default "profile")) ;string
1680   (content            profile-content)                  ;<manifest>
1681   (hooks              profile-hooks                     ;list of procedures
1682                       (default %default-profile-hooks))
1683   (locales?           profile-locales?            ;Boolean
1684                       (default #t))
1685   (allow-collisions?  profile-allow-collisions?   ;Boolean
1686                       (default #f))
1687   (relative-symlinks? profile-relative-symlinks?  ;Boolean
1688                       (default #f)))
1689
1690 (define-gexp-compiler (profile-compiler (profile <profile>) system target)
1691   "Compile PROFILE to a derivation."
1692   (match profile
1693     (($ <profile> name manifest hooks
1694                   locales? allow-collisions? relative-symlinks?)
1695      (profile-derivation manifest
1696                          #:name name
1697                          #:hooks hooks
1698                          #:locales? locales?
1699                          #:allow-collisions? allow-collisions?
1700                          #:relative-symlinks? relative-symlinks?
1701                          #:system system #:target target))))
1702
1703 (define* (profile-search-paths profile
1704                                #:optional (manifest (profile-manifest profile))
1705                                #:key (getenv (const #f)))
1706   "Read the manifest of PROFILE and evaluate the values of search path
1707 environment variables required by PROFILE; return a list of
1708 specification/value pairs.  If MANIFEST is not #f, it is assumed to be the
1709 manifest of PROFILE, which avoids rereading it.
1710
1711 Use GETENV to determine the current settings and report only settings not
1712 already effective."
1713   (evaluate-search-paths (manifest-search-paths manifest)
1714                          (list profile) getenv))
1715
1716 (define (profile-regexp profile)
1717   "Return a regular expression that matches PROFILE's name and number."
1718   (make-regexp (string-append "^" (regexp-quote (basename profile))
1719                               "-([0-9]+)")))
1720
1721 (define (generation-number profile)
1722   "Return PROFILE's number or 0.  An absolute file name must be used."
1723   (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
1724                                               (basename (readlink profile))))
1725              (compose string->number (cut match:substring <> 1)))
1726       0))
1727
1728 (define %profile-generation-rx
1729   ;; Regexp that matches profile generation.
1730   (make-regexp "(.*)-([0-9]+)-link$"))
1731
1732 (define (generation-profile file)
1733   "If FILE is a profile generation GC root such as \"guix-profile-42-link\",
1734 return its corresponding profile---e.g., \"guix-profile\".  Otherwise return
1735 #f."
1736   (match (regexp-exec %profile-generation-rx file)
1737     (#f #f)
1738     (m  (let ((profile (match:substring m 1)))
1739           (and (file-exists? (string-append profile "/manifest"))
1740                profile)))))
1741
1742 (define (generation-numbers profile)
1743   "Return the sorted list of generation numbers of PROFILE, or '(0) if no
1744 former profiles were found."
1745   (match (scandir (dirname profile)
1746                   (cute regexp-exec (profile-regexp profile) <>))
1747     (#f                                         ; no profile directory
1748      '(0))
1749     (()                                         ; no profiles
1750      '(0))
1751     ((profiles ...)                             ; former profiles around
1752      (sort (map (compose string->number
1753                          (cut match:substring <> 1)
1754                          (cute regexp-exec (profile-regexp profile) <>))
1755                 profiles)
1756            <))))
1757
1758 (define (profile-generations profile)
1759   "Return a list of PROFILE's generations."
1760   (let ((generations (generation-numbers profile)))
1761     (if (equal? generations '(0))
1762         '()
1763         generations)))
1764
1765 (define (relative-generation-spec->number profile spec)
1766   "Return PROFILE's generation specified by SPEC, which is a string.  The SPEC
1767 may be a N, -N, or +N, where N is a number.  If the spec is N, then the number
1768 returned is N.  If it is -N, then the number returned is the profile's current
1769 generation number minus N.  If it is +N, then the number returned is the
1770 profile's current generation number plus N.  Return #f if there is no such
1771 generation."
1772   (let ((number (string->number spec)))
1773     (and number
1774          (case (string-ref spec 0)
1775            ((#\+ #\-)
1776             (relative-generation profile number))
1777            (else (if (memv number (profile-generations profile))
1778                      number
1779                      #f))))))
1780
1781
1782 (define* (relative-generation profile shift #:optional
1783                               (current (generation-number profile)))
1784   "Return PROFILE's generation shifted from the CURRENT generation by SHIFT.
1785 SHIFT is a positive or negative number.
1786 Return #f if there is no such generation."
1787   (let* ((abs-shift (abs shift))
1788          (numbers (profile-generations profile))
1789          (from-current (memq current
1790                              (if (negative? shift)
1791                                  (reverse numbers)
1792                                  numbers))))
1793     (and from-current
1794          (< abs-shift (length from-current))
1795          (list-ref from-current abs-shift))))
1796
1797 (define* (previous-generation-number profile #:optional
1798                                      (number (generation-number profile)))
1799   "Return the number of the generation before generation NUMBER of
1800 PROFILE, or 0 if none exists.  It could be NUMBER - 1, but it's not the
1801 case when generations have been deleted (there are \"holes\")."
1802   (or (relative-generation profile -1 number)
1803       0))
1804
1805 (define (generation-file-name profile generation)
1806   "Return the file name for PROFILE's GENERATION."
1807   (format #f "~a-~a-link" profile generation))
1808
1809 (define (generation-time profile number)
1810   "Return the creation time of a generation in the UTC format."
1811   (make-time time-utc 0
1812              (stat:ctime (stat (generation-file-name profile number)))))
1813
1814 (define (link-to-empty-profile store generation)
1815   "Link GENERATION, a string, to the empty profile.  An error is raised if
1816 that fails."
1817   (let* ((drv  (run-with-store store
1818                  (profile-derivation (manifest '())
1819                                      #:locales? #f)))
1820          (prof (derivation->output-path drv "out")))
1821     (build-derivations store (list drv))
1822     (switch-symlinks generation prof)))
1823
1824 (define (switch-to-generation profile number)
1825   "Atomically switch PROFILE to the generation NUMBER.  Return the number of
1826 the generation that was current before switching."
1827   (let ((current    (generation-number profile))
1828         (generation (generation-file-name profile number)))
1829     (cond ((not (file-exists? profile))
1830            (raise (condition (&profile-not-found-error
1831                               (profile profile)))))
1832           ((not (file-exists? generation))
1833            (raise (condition (&missing-generation-error
1834                               (profile profile)
1835                               (generation number)))))
1836           (else
1837            (switch-symlinks profile (basename generation))
1838            current))))
1839
1840 (define (switch-to-previous-generation profile)
1841   "Atomically switch PROFILE to the previous generation.  Return the former
1842 generation number and the current one."
1843   (let ((previous (previous-generation-number profile)))
1844     (values (switch-to-generation profile previous)
1845             previous)))
1846
1847 (define (roll-back store profile)
1848   "Roll back to the previous generation of PROFILE.  Return the number of the
1849 generation that was current before switching and the new generation number."
1850   (let* ((number              (generation-number profile))
1851          (previous-number     (previous-generation-number profile number))
1852          (previous-generation (generation-file-name profile previous-number)))
1853     (cond ((not (file-exists? profile))           ;invalid profile
1854            (raise (condition (&profile-not-found-error
1855                               (profile profile)))))
1856           ((zero? number)                         ;empty profile
1857            (values number number))
1858           ((or (zero? previous-number)            ;going to emptiness
1859                (not (file-exists? previous-generation)))
1860            (link-to-empty-profile store previous-generation)
1861            (switch-to-previous-generation profile))
1862           (else                                   ;anything else
1863            (switch-to-previous-generation profile)))))
1864
1865 (define (delete-generation store profile number)
1866   "Delete generation with NUMBER from PROFILE.  Return the file name of the
1867 generation that has been deleted, or #f if nothing was done (for instance
1868 because the NUMBER is zero.)"
1869   (define (delete-and-return)
1870     (let ((generation (generation-file-name profile number)))
1871       (delete-file generation)
1872       generation))
1873
1874   (let* ((current-number      (generation-number profile))
1875          (previous-number     (previous-generation-number profile number))
1876          (previous-generation (generation-file-name profile previous-number)))
1877     (cond ((zero? number) #f)                     ;do not delete generation 0
1878           ((and (= number current-number)
1879                 (not (file-exists? previous-generation)))
1880            (link-to-empty-profile store previous-generation)
1881            (switch-to-previous-generation profile)
1882            (delete-and-return))
1883           ((= number current-number)
1884            (roll-back store profile)
1885            (delete-and-return))
1886           (else
1887            (delete-and-return)))))
1888
1889 (define %user-profile-directory
1890   (and=> (getenv "HOME")
1891          (cut string-append <> "/.guix-profile")))
1892
1893 (define %profile-directory
1894   (string-append %state-directory "/profiles/"
1895                  (or (and=> (or (getenv "USER")
1896                                 (getenv "LOGNAME")
1897                                 (false-if-exception
1898                                  (passwd:name (getpwuid (getuid)))))
1899                             (cut string-append "per-user/" <>))
1900                      "default")))
1901
1902 (define %current-profile
1903   ;; Call it `guix-profile', not `profile', to allow Guix profiles to
1904   ;; coexist with Nix profiles.
1905   (string-append %profile-directory "/guix-profile"))
1906
1907 (define (ensure-profile-directory)
1908   "Attempt to create /…/profiles/per-user/$USER if needed.  Nowadays this is
1909 taken care of by the daemon."
1910   (let ((s (stat %profile-directory #f)))
1911     (unless (and s (eq? 'directory (stat:type s)))
1912       (catch 'system-error
1913         (lambda ()
1914           (mkdir-p %profile-directory))
1915         (lambda args
1916           ;; Often, we cannot create %PROFILE-DIRECTORY because its
1917           ;; parent directory is root-owned and we're running
1918           ;; unprivileged.
1919           (raise (condition
1920                   (&message
1921                    (message
1922                     (format #f
1923                             (G_ "while creating directory `~a': ~a")
1924                             %profile-directory
1925                             (strerror (system-error-errno args)))))
1926                   (&fix-hint
1927                    (hint
1928                     (format #f (G_ "Please create the @file{~a} directory, \
1929 with you as the owner.")
1930                             %profile-directory))))))))
1931
1932     ;; Bail out if it's not owned by the user.
1933     (unless (or (not s) (= (stat:uid s) (getuid)))
1934       (raise (condition
1935               (&message
1936                (message
1937                 (format #f (G_ "directory `~a' is not owned by you")
1938                         %profile-directory)))
1939               (&fix-hint
1940                (hint
1941                 (format #f (G_ "Please change the owner of @file{~a} \
1942 to user ~s.")
1943                         %profile-directory (or (getenv "USER")
1944                                                (getenv "LOGNAME")
1945                                                (getuid))))))))))
1946
1947 (define (canonicalize-profile profile)
1948   "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that.
1949 Otherwise return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile'
1950 as if '-p' was omitted."  ; see <http://bugs.gnu.org/17939>
1951   ;; Trim trailing slashes so 'readlink' can do its job.
1952   (let ((profile (string-trim-right profile #\/)))
1953     (catch 'system-error
1954       (lambda ()
1955         (let ((target (readlink profile)))
1956           (if (string=? (dirname target) %profile-directory)
1957               target
1958               profile)))
1959       (const profile))))
1960
1961 (define %known-shorthand-profiles
1962   ;; Known shorthand forms for profiles that the user manipulates.
1963   (list (string-append (config-directory #:ensure? #f) "/current")
1964         %user-profile-directory))
1965
1966 (define (user-friendly-profile profile)
1967   "Return either ~/.guix-profile or ~/.config/guix/current if that's what
1968 PROFILE refers to, directly or indirectly, or PROFILE."
1969   (or (find (lambda (shorthand)
1970               (and shorthand
1971                    (let ((target (false-if-exception
1972                                   (readlink shorthand))))
1973                      (and target (string=? target profile)))))
1974             %known-shorthand-profiles)
1975       profile))
1976
1977 ;;; profiles.scm ends here