guix/profiles.scm

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