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