guix/profiles.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 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 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 ;;;
  12 ;;; This file is part of GNU Guix.
  13 ;;;
  14 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  15 ;;; under the terms of the GNU General Public License as published by
  16 ;;; the Free Software Foundation; either version 3 of the License, or (at
  17 ;;; your option) any later version.
  18 ;;;
  19 ;;; GNU Guix is distributed in the hope that it will be useful, but
  20 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;;; GNU General Public License for more details.
  23 ;;;
  24 ;;; You should have received a copy of the GNU General Public License
  25 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 (define-module (guix profiles)
  28   #:use-module ((guix utils) #:hide (package-name->name+version))
  29   #:use-module ((guix build utils)
  30                 #:select (package-name->name+version))
  31   #:use-module (guix records)
  32   #:use-module (guix packages)
  33   #:use-module (guix derivations)
  34   #:use-module (guix search-paths)
  35   #:use-module (guix gexp)
  36   #:use-module (guix monads)
  37   #:use-module (guix store)
  38   #:use-module (guix sets)
  39   #:use-module (ice-9 vlist)
  40   #:use-module (ice-9 match)
  41   #:use-module (ice-9 regex)
  42   #:use-module (ice-9 ftw)
  43   #:use-module (ice-9 format)
  44   #:use-module (srfi srfi-1)
  45   #:use-module (srfi srfi-9)
  46   #:use-module (srfi srfi-11)
  47   #:use-module (srfi srfi-19)
  48   #:use-module (srfi srfi-26)
  49   #:use-module (srfi srfi-34)
  50   #:use-module (srfi srfi-35)
  51   #:export (&profile-error
  52             profile-error?
  53             profile-error-profile
  54             &profile-not-found-error
  55             profile-not-found-error?
  56             &profile-collistion-error
  57             profile-collision-error?
  58             profile-collision-error-entry
  59             profile-collision-error-conflict
  60             &missing-generation-error
  61             missing-generation-error?
  62             missing-generation-error-generation
  63
  64             manifest make-manifest
  65             manifest?
  66             manifest-entries
  67             manifest-transitive-entries
  68
  69             <manifest-entry>              ; FIXME: eventually make it internal
  70             manifest-entry
  71             manifest-entry?
  72             manifest-entry-name
  73             manifest-entry-version
  74             manifest-entry-output
  75             manifest-entry-item
  76             manifest-entry-dependencies
  77             manifest-entry-search-paths
  78             manifest-entry-parent
  79
  80             manifest-pattern
  81             manifest-pattern?
  82             manifest-pattern-name
  83             manifest-pattern-version
  84             manifest-pattern-output
  85
  86             manifest-remove
  87             manifest-add
  88             manifest-lookup
  89             manifest-installed?
  90             manifest-matching-entries
  91
  92             manifest-transaction
  93             manifest-transaction?
  94             manifest-transaction-install
  95             manifest-transaction-remove
  96             manifest-transaction-install-entry
  97             manifest-transaction-remove-pattern
  98             manifest-transaction-null?
  99             manifest-perform-transaction
 100             manifest-transaction-effects
 101
 102             profile-manifest
 103             package->manifest-entry
 104             packages->manifest
 105             ca-certificate-bundle
 106             %default-profile-hooks
 107             profile-derivation
 108
 109             generation-number
 110             generation-numbers
 111             profile-generations
 112             relative-generation-spec->number
 113             relative-generation
 114             previous-generation-number
 115             generation-time
 116             generation-file-name
 117             switch-to-generation
 118             roll-back
 119             delete-generation))
 120
 121 ;;; Commentary:
 122 ;;;
 123 ;;; Tools to create and manipulate profiles---i.e., the representation of a
 124 ;;; set of installed packages.
 125 ;;;
 126 ;;; Code:
 127
 128 \f
 129 ;;;
 130 ;;; Condition types.
 131 ;;;
 132
 133 (define-condition-type &profile-error &error
 134   profile-error?
 135   (profile profile-error-profile))
 136
 137 (define-condition-type &profile-not-found-error &profile-error
 138   profile-not-found-error?)
 139
 140 (define-condition-type &profile-collision-error &error
 141   profile-collision-error?
 142   (entry    profile-collision-error-entry)        ;<manifest-entry>
 143   (conflict profile-collision-error-conflict))    ;<manifest-entry>
 144
 145 (define-condition-type &missing-generation-error &profile-error
 146   missing-generation-error?
 147   (generation missing-generation-error-generation))
 148
 149 \f
 150 ;;;
 151 ;;; Manifests.
 152 ;;;
 153
 154 (define-record-type <manifest>
 155   (manifest entries)
 156   manifest?
 157   (entries manifest-entries))                     ; list of <manifest-entry>
 158
 159 ;; Convenient alias, to avoid name clashes.
 160 (define make-manifest manifest)
 161
 162 (define-record-type* <manifest-entry> manifest-entry
 163   make-manifest-entry
 164   manifest-entry?
 165   (name         manifest-entry-name)              ; string
 166   (version      manifest-entry-version)           ; string
 167   (output       manifest-entry-output             ; string
 168                 (default "out"))
 169   (item         manifest-entry-item)              ; package | store path
 170   (dependencies manifest-entry-dependencies       ; <manifest-entry>*
 171                 (default '()))
 172   (search-paths manifest-entry-search-paths       ; search-path-specification*
 173                 (default '()))
 174   (parent       manifest-entry-parent        ; promise (#f | <manifest-entry>)
 175                 (default (delay #f))))
 176
 177 (define-record-type* <manifest-pattern> manifest-pattern
 178   make-manifest-pattern
 179   manifest-pattern?
 180   (name         manifest-pattern-name)            ; string
 181   (version      manifest-pattern-version          ; string | #f
 182                 (default #f))
 183   (output       manifest-pattern-output           ; string | #f
 184                 (default "out")))
 185
 186 (define (manifest-transitive-entries manifest)
 187   "Return the entries of MANIFEST along with their propagated inputs,
 188 recursively."
 189   (let loop ((entries (manifest-entries manifest))
 190              (result  '())
 191              (visited (set)))                     ;compare with 'equal?'
 192     (match entries
 193       (()
 194        (reverse result))
 195       ((head . tail)
 196        (if (set-contains? visited head)
 197            (loop tail result visited)
 198            (loop (append (manifest-entry-dependencies head)
 199                          tail)
 200                  (cons head result)
 201                  (set-insert head visited)))))))
 202
 203 (define (profile-manifest profile)
 204   "Return the PROFILE's manifest."
 205   (let ((file (string-append profile "/manifest")))
 206     (if (file-exists? file)
 207         (call-with-input-file file read-manifest)
 208         (manifest '()))))
 209
 210 (define (manifest-entry-lookup manifest)
 211   "Return a lookup procedure for the entries of MANIFEST.  The lookup
 212 procedure takes two arguments: the entry name and output."
 213   (define mapping
 214     (let loop ((entries (manifest-entries manifest))
 215                (mapping vlist-null))
 216       (fold (lambda (entry result)
 217               (vhash-cons (cons (manifest-entry-name entry)
 218                                 (manifest-entry-output entry))
 219                           entry
 220                           (loop (manifest-entry-dependencies entry)
 221                                 result)))
 222             mapping
 223             entries)))
 224
 225   (lambda (name output)
 226     (match (vhash-assoc (cons name output) mapping)
 227       ((_ . entry) entry)
 228       (#f          #f))))
 229
 230 (define* (lower-manifest-entry entry system #:key target)
 231   "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store
 232 file name."
 233   (let ((item (manifest-entry-item entry)))
 234     (if (string? item)
 235         (with-monad %store-monad
 236           (return entry))
 237         (mlet %store-monad ((drv (lower-object item system
 238                                                #:target target))
 239                             (output -> (manifest-entry-output entry)))
 240           (return (manifest-entry
 241                     (inherit entry)
 242                     (item (derivation->output-path drv output))))))))
 243
 244 (define* (check-for-collisions manifest system #:key target)
 245   "Check whether the entries of MANIFEST conflict with one another; raise a
 246 '&profile-collision-error' when a conflict is encountered."
 247   (define lookup
 248     (manifest-entry-lookup manifest))
 249
 250   (with-monad %store-monad
 251     (foldm %store-monad
 252            (lambda (entry result)
 253              (match (lookup (manifest-entry-name entry)
 254                             (manifest-entry-output entry))
 255                ((? manifest-entry? second)        ;potential conflict
 256                 (mlet %store-monad ((first (lower-manifest-entry entry system
 257                                                                  #:target
 258                                                                  target))
 259                                     (second (lower-manifest-entry second system
 260                                                                   #:target
 261                                                                   target)))
 262                   (if (string=? (manifest-entry-item first)
 263                                 (manifest-entry-item second))
 264                       (return result)
 265                       (raise (condition
 266                               (&profile-collision-error
 267                                (entry first)
 268                                (conflict second)))))))
 269                (#f                                ;no conflict
 270                 (return result))))
 271            #t
 272            (manifest-transitive-entries manifest))))
 273
 274 (define* (package->manifest-entry package #:optional (output "out")
 275                                   #:key (parent (delay #f)))
 276   "Return a manifest entry for the OUTPUT of package PACKAGE."
 277   ;; For each dependency, keep a promise pointing to its "parent" entry.
 278   (letrec* ((deps  (map (match-lambda
 279                           ((label package)
 280                            (package->manifest-entry package
 281                                                     #:parent (delay entry)))
 282                           ((label package output)
 283                            (package->manifest-entry package output
 284                                                     #:parent (delay entry))))
 285                         (package-propagated-inputs package)))
 286             (entry (manifest-entry
 287                      (name (package-name package))
 288                      (version (package-version package))
 289                      (output output)
 290                      (item package)
 291                      (dependencies (delete-duplicates deps))
 292                      (search-paths
 293                       (package-transitive-native-search-paths package))
 294                      (parent parent))))
 295     entry))
 296
 297 (define (packages->manifest packages)
 298   "Return a list of manifest entries, one for each item listed in PACKAGES.
 299 Elements of PACKAGES can be either package objects or package/string tuples
 300 denoting a specific output of a package."
 301   (manifest
 302    (map (match-lambda
 303          ((package output)
 304           (package->manifest-entry package output))
 305          ((? package? package)
 306           (package->manifest-entry package)))
 307         packages)))
 308
 309 (define (manifest->gexp manifest)
 310   "Return a representation of MANIFEST as a gexp."
 311   (define (entry->gexp entry)
 312     (match entry
 313       (($ <manifest-entry> name version output (? string? path)
 314                            (deps ...) (search-paths ...))
 315        #~(#$name #$version #$output #$path
 316                  (propagated-inputs #$(map entry->gexp deps))
 317                  (search-paths #$(map search-path-specification->sexp
 318                                       search-paths))))
 319       (($ <manifest-entry> name version output (? package? package)
 320                            (deps ...) (search-paths ...))
 321        #~(#$name #$version #$output
 322                  (ungexp package (or output "out"))
 323                  (propagated-inputs #$(map entry->gexp deps))
 324                  (search-paths #$(map search-path-specification->sexp
 325                                       search-paths))))))
 326
 327   (match manifest
 328     (($ <manifest> (entries ...))
 329      #~(manifest (version 3)
 330                  (packages #$(map entry->gexp entries))))))
 331
 332 (define (find-package name version)
 333   "Return a package from the distro matching NAME and possibly VERSION.  This
 334 procedure is here for backward-compatibility and will eventually vanish."
 335   (define find-best-packages-by-name              ;break abstractions
 336     (module-ref (resolve-interface '(gnu packages))
 337                 'find-best-packages-by-name))
 338
 339    ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the
 340    ;; former traverses the module tree only once and then allows for efficient
 341    ;; access via a vhash.
 342    (match (find-best-packages-by-name name version)
 343      ((p _ ...) p)
 344      (_
 345       (match (find-best-packages-by-name name #f)
 346         ((p _ ...) p)
 347         (_ #f)))))
 348
 349 (define (sexp->manifest sexp)
 350   "Parse SEXP as a manifest."
 351   (define (infer-search-paths name version)
 352     ;; Infer the search path specifications for NAME-VERSION by looking up a
 353     ;; same-named package in the distro.  Useful for the old manifest formats
 354     ;; that did not store search path info.
 355     (let ((package (find-package name version)))
 356       (if package
 357           (package-native-search-paths package)
 358           '())))
 359
 360   (define (infer-dependency item parent)
 361     ;; Return a <manifest-entry> for ITEM.
 362     (let-values (((name version)
 363                   (package-name->name+version
 364                    (store-path-package-name item))))
 365       (manifest-entry
 366         (name name)
 367         (version version)
 368         (item item)
 369         (parent parent))))
 370
 371   (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
 372     (match sexp
 373       ((name version output path
 374              ('propagated-inputs deps)
 375              ('search-paths search-paths)
 376              extra-stuff ...)
 377        ;; For each of DEPS, keep a promise pointing to ENTRY.
 378        (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry))
 379                              deps))
 380                  (entry (manifest-entry
 381                           (name name)
 382                           (version version)
 383                           (output output)
 384                           (item path)
 385                           (dependencies deps*)
 386                           (search-paths (map sexp->search-path-specification
 387                                              search-paths))
 388                           (parent parent))))
 389          entry))))
 390
 391   (match sexp
 392     (('manifest ('version 0)
 393                 ('packages ((name version output path) ...)))
 394      (manifest
 395       (map (lambda (name version output path)
 396              (manifest-entry
 397                (name name)
 398                (version version)
 399                (output output)
 400                (item path)
 401                (search-paths (infer-search-paths name version))))
 402            name version output path)))
 403
 404     ;; Version 1 adds a list of propagated inputs to the
 405     ;; name/version/output/path tuples.
 406     (('manifest ('version 1)
 407                 ('packages ((name version output path deps) ...)))
 408      (manifest
 409       (map (lambda (name version output path deps)
 410              ;; Up to Guix 0.7 included, dependencies were listed as ("gmp"
 411              ;; "/gnu/store/...-gmp") for instance.  Discard the 'label' in
 412              ;; such lists.
 413              (let ((deps (match deps
 414                            (((labels directories) ...)
 415                             directories)
 416                            ((directories ...)
 417                             directories))))
 418                (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
 419                                      deps))
 420                          (entry (manifest-entry
 421                                   (name name)
 422                                   (version version)
 423                                   (output output)
 424                                   (item path)
 425                                   (dependencies deps*)
 426                                   (search-paths
 427                                    (infer-search-paths name version)))))
 428                  entry)))
 429            name version output path deps)))
 430
 431     ;; Version 2 adds search paths and is slightly more verbose.
 432     (('manifest ('version 2 minor-version ...)
 433                 ('packages ((name version output path
 434                                   ('propagated-inputs deps)
 435                                   ('search-paths search-paths)
 436                                   extra-stuff ...)
 437                             ...)))
 438      (manifest
 439       (map (lambda (name version output path deps search-paths)
 440              (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
 441                                    deps))
 442                        (entry (manifest-entry
 443                                 (name name)
 444                                 (version version)
 445                                 (output output)
 446                                 (item path)
 447                                 (dependencies deps*)
 448                                 (search-paths
 449                                  (map sexp->search-path-specification
 450                                       search-paths)))))
 451                entry))
 452            name version output path deps search-paths)))
 453
 454     ;; Version 3 represents DEPS as full-blown manifest entries.
 455     (('manifest ('version 3 minor-version ...)
 456                 ('packages (entries ...)))
 457      (manifest (map sexp->manifest-entry entries)))
 458     (_
 459      (raise (condition
 460              (&message (message "unsupported manifest format")))))))
 461
 462 (define (read-manifest port)
 463   "Return the packages listed in MANIFEST."
 464   (sexp->manifest (read port)))
 465
 466 (define (entry-predicate pattern)
 467   "Return a procedure that returns #t when passed a manifest entry that
 468 matches NAME/OUTPUT/VERSION.  OUTPUT and VERSION may be #f, in which case they
 469 are ignored."
 470   (match pattern
 471     (($ <manifest-pattern> name version output)
 472      (match-lambda
 473       (($ <manifest-entry> entry-name entry-version entry-output)
 474        (and (string=? entry-name name)
 475             (or (not entry-output) (not output)
 476                 (string=? entry-output output))
 477             (or (not version)
 478                 (string=? entry-version version))))))))
 479
 480 (define (manifest-remove manifest patterns)
 481   "Remove entries for each of PATTERNS from MANIFEST.  Each item in PATTERNS
 482 must be a manifest-pattern."
 483   (define (remove-entry pattern lst)
 484     (remove (entry-predicate pattern) lst))
 485
 486   (make-manifest (fold remove-entry
 487                        (manifest-entries manifest)
 488                        patterns)))
 489
 490 (define (manifest-add manifest entries)
 491   "Add a list of manifest ENTRIES to MANIFEST and return new manifest.
 492 Remove MANIFEST entries that have the same name and output as ENTRIES."
 493   (define (same-entry? entry name output)
 494     (match entry
 495       (($ <manifest-entry> entry-name _ entry-output _ ...)
 496        (and (equal? name entry-name)
 497             (equal? output entry-output)))))
 498
 499   (make-manifest
 500    (append entries
 501            (fold (lambda (entry result)
 502                    (match entry
 503                      (($ <manifest-entry> name _ out _ ...)
 504                       (filter (negate (cut same-entry? <> name out))
 505                               result))))
 506                  (manifest-entries manifest)
 507                  entries))))
 508
 509 (define (manifest-lookup manifest pattern)
 510   "Return the first item of MANIFEST that matches PATTERN, or #f if there is
 511 no match.."
 512   (find (entry-predicate pattern)
 513         (manifest-entries manifest)))
 514
 515 (define (manifest-installed? manifest pattern)
 516   "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
 517 #f otherwise."
 518   (->bool (manifest-lookup manifest pattern)))
 519
 520 (define (manifest-matching-entries manifest patterns)
 521   "Return all the entries of MANIFEST that match one of the PATTERNS."
 522   (define predicates
 523     (map entry-predicate patterns))
 524
 525   (define (matches? entry)
 526     (any (lambda (pred)
 527            (pred entry))
 528          predicates))
 529
 530   (filter matches? (manifest-entries manifest)))
 531
 532 \f
 533 ;;;
 534 ;;; Manifest transactions.
 535 ;;;
 536
 537 (define-record-type* <manifest-transaction> manifest-transaction
 538   make-manifest-transaction
 539   manifest-transaction?
 540   (install manifest-transaction-install ; list of <manifest-entry>
 541            (default '()))
 542   (remove  manifest-transaction-remove  ; list of <manifest-pattern>
 543            (default '())))
 544
 545 (define (manifest-transaction-install-entry entry transaction)
 546   "Augment TRANSACTION's set of installed packages with ENTRY, a
 547 <manifest-entry>."
 548   (manifest-transaction
 549    (inherit transaction)
 550    (install
 551     (cons entry (manifest-transaction-install transaction)))))
 552
 553 (define (manifest-transaction-remove-pattern pattern transaction)
 554   "Add PATTERN to TRANSACTION's list of packages to remove."
 555   (manifest-transaction
 556    (inherit transaction)
 557    (remove
 558     (cons pattern (manifest-transaction-remove transaction)))))
 559
 560 (define (manifest-transaction-null? transaction)
 561   "Return true if TRANSACTION has no effect---i.e., it neither installs nor
 562 remove software."
 563   (match transaction
 564     (($ <manifest-transaction> () ()) #t)
 565     (($ <manifest-transaction> _ _)   #f)))
 566
 567 (define (manifest-transaction-effects manifest transaction)
 568   "Compute the effect of applying TRANSACTION to MANIFEST.  Return 4 values:
 569 the list of packages that would be removed, installed, upgraded, or downgraded
 570 when applying TRANSACTION to MANIFEST.  Upgrades are represented as pairs
 571 where the head is the entry being upgraded and the tail is the entry that will
 572 replace it."
 573   (define (manifest-entry->pattern entry)
 574     (manifest-pattern
 575       (name   (manifest-entry-name entry))
 576       (output (manifest-entry-output entry))))
 577
 578   (let loop ((input     (manifest-transaction-install transaction))
 579              (install   '())
 580              (upgrade   '())
 581              (downgrade '()))
 582     (match input
 583       (()
 584        (let ((remove (manifest-transaction-remove transaction)))
 585          (values (manifest-matching-entries manifest remove)
 586                  (reverse install) (reverse upgrade) (reverse downgrade))))
 587       ((entry rest ...)
 588        ;; Check whether installing ENTRY corresponds to the installation of a
 589        ;; new package or to an upgrade.
 590
 591        ;; XXX: When the exact same output directory is installed, we're not
 592        ;; really upgrading anything.  Add a check for that case.
 593        (let* ((pattern  (manifest-entry->pattern entry))
 594               (previous (manifest-lookup manifest pattern))
 595               (newer?   (and previous
 596                              (version>=? (manifest-entry-version entry)
 597                                          (manifest-entry-version previous)))))
 598          (loop rest
 599                (if previous install (cons entry install))
 600                (if (and previous newer?)
 601                    (alist-cons previous entry upgrade)
 602                    upgrade)
 603                (if (and previous (not newer?))
 604                    (alist-cons previous entry downgrade)
 605                    downgrade)))))))
 606
 607 (define (manifest-perform-transaction manifest transaction)
 608   "Perform TRANSACTION on MANIFEST and return the new manifest."
 609   (let ((install (manifest-transaction-install transaction))
 610         (remove  (manifest-transaction-remove transaction)))
 611     (manifest-add (manifest-remove manifest remove)
 612                   install)))
 613
 614 \f
 615 ;;;
 616 ;;; Profiles.
 617 ;;;
 618
 619 (define (manifest-inputs manifest)
 620   "Return a list of <gexp-input> objects for MANIFEST."
 621   (define entry->input
 622     (match-lambda
 623       (($ <manifest-entry> name version output thing deps)
 624        ;; THING may be a package or a file name.  In the latter case, assume
 625        ;; it's already valid.
 626        (cons (gexp-input thing output)
 627              (append-map entry->input deps)))))
 628
 629   (append-map entry->input (manifest-entries manifest)))
 630
 631 (define* (manifest-lookup-package manifest name #:optional version)
 632   "Return as a monadic value the first package or store path referenced by
 633 MANIFEST that is named NAME and optionally has the given VERSION prefix, or #f
 634 if not found."
 635   ;; Return as a monadic value the package or store path referenced by the
 636   ;; manifest ENTRY, or #f if not referenced.
 637   (define (entry-lookup-package entry)
 638     (define (find-among-inputs inputs)
 639       (find (lambda (input)
 640               (and (package? input)
 641                    (equal? name (package-name input))
 642                    (if version
 643                        (string-prefix? version (package-version input))
 644                        #t)))
 645             inputs))
 646     (define (find-among-store-items items)
 647       (find (lambda (item)
 648               (let-values (((name* version*)
 649                             (package-name->name+version
 650                              (store-path-package-name item))))
 651                 (and (string=? name name*)
 652                      (if version
 653                          (string-prefix? version version*)
 654                          #t))))
 655             items))
 656
 657     (with-monad %store-monad
 658       (match (manifest-entry-item entry)
 659         ((? package? package)
 660          (match (cons (list (package-name package) package)
 661                       (package-transitive-inputs package))
 662            (((labels inputs . _) ...)
 663             (return (find-among-inputs inputs)))))
 664         ((? string? item)
 665          (mlet %store-monad ((refs (references* item)))
 666            (return (find-among-store-items refs)))))))
 667
 668   (anym %store-monad
 669         entry-lookup-package (manifest-entries manifest)))
 670
 671 (define (info-dir-file manifest)
 672   "Return a derivation that builds the 'dir' file for all the entries of
 673 MANIFEST."
 674   (define texinfo                                 ;lazy reference
 675     (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
 676   (define gzip                                    ;lazy reference
 677     (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
 678
 679   (define build
 680     (with-imported-modules '((guix build utils))
 681       #~(begin
 682           (use-modules (guix build utils)
 683                        (srfi srfi-1) (srfi srfi-26)
 684                        (ice-9 ftw))
 685
 686           (define (info-file? file)
 687             (or (string-suffix? ".info" file)
 688                 (string-suffix? ".info.gz" file)))
 689
 690           (define (info-files top)
 691             (let ((infodir (string-append top "/share/info")))
 692               (map (cut string-append infodir "/" <>)
 693                    (or (scandir infodir info-file?) '()))))
 694
 695           (define (install-info info)
 696             (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
 697             (zero?
 698              (system* (string-append #+texinfo "/bin/install-info") "--silent"
 699                       info (string-append #$output "/share/info/dir"))))
 700
 701           (mkdir-p (string-append #$output "/share/info"))
 702           (exit (every install-info
 703                        (append-map info-files
 704                                    '#$(manifest-inputs manifest)))))))
 705
 706   (gexp->derivation "info-dir" build
 707                     #:local-build? #t
 708                     #:substitutable? #f))
 709
 710 (define (ghc-package-cache-file manifest)
 711   "Return a derivation that builds the GHC 'package.cache' file for all the
 712 entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
 713   (define ghc                                     ;lazy reference
 714     (module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
 715
 716   (define build
 717     (with-imported-modules '((guix build utils))
 718       #~(begin
 719           (use-modules (guix build utils)
 720                        (srfi srfi-1) (srfi srfi-26)
 721                        (ice-9 ftw))
 722
 723           (define ghc-name-version
 724             (let* ((base (basename #+ghc)))
 725               (string-drop base
 726                            (+ 1 (string-index base #\-)))))
 727
 728           (define db-subdir
 729             (string-append "lib/" ghc-name-version "/package.conf.d"))
 730
 731           (define db-dir
 732             (string-append #$output "/" db-subdir))
 733
 734           (define (conf-files top)
 735             (let ((db (string-append top "/" db-subdir)))
 736               (if (file-exists? db)
 737                   (find-files db "\\.conf$")
 738                   '())))
 739
 740           (define (copy-conf-file conf)
 741             (let ((base (basename conf)))
 742               (copy-file conf (string-append db-dir "/" base))))
 743
 744           (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
 745           (for-each copy-conf-file
 746                     (append-map conf-files
 747                                 (delete-duplicates
 748                                  '#$(manifest-inputs manifest))))
 749           (let ((success
 750                  (zero?
 751                   (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
 752                            (string-append "--package-db=" db-dir)))))
 753             (for-each delete-file (find-files db-dir "\\.conf$"))
 754             (exit success)))))
 755
 756   (with-monad %store-monad
 757     ;; Don't depend on GHC when there's nothing to do.
 758     (if (any (cut string-prefix? "ghc" <>)
 759              (map manifest-entry-name (manifest-entries manifest)))
 760         (gexp->derivation "ghc-package-cache" build
 761                           #:local-build? #t
 762                           #:substitutable? #f)
 763         (return #f))))
 764
 765 (define (ca-certificate-bundle manifest)
 766   "Return a derivation that builds a single-file bundle containing the CA
 767 certificates in the /etc/ssl/certs sub-directories of the packages in
 768 MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
 769   ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html>
 770   ;; for a discussion.
 771
 772   (define glibc-utf8-locales                      ;lazy reference
 773     (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
 774
 775   (define build
 776     (with-imported-modules '((guix build utils))
 777       #~(begin
 778           (use-modules (guix build utils)
 779                        (rnrs io ports)
 780                        (srfi srfi-1)
 781                        (srfi srfi-26)
 782                        (ice-9 ftw)
 783                        (ice-9 match))
 784
 785           (define (pem-file? file)
 786             (string-suffix? ".pem" file))
 787
 788           (define (ca-files top)
 789             (let ((cert-dir (string-append top "/etc/ssl/certs")))
 790               (map (cut string-append cert-dir "/" <>)
 791                    (or (scandir cert-dir pem-file?) '()))))
 792
 793           (define (concatenate-files files result)
 794             "Make RESULT the concatenation of all of FILES."
 795             (define (dump file port)
 796               (display (call-with-input-file file get-string-all)
 797                        port)
 798               (newline port))  ;required, see <https://bugs.debian.org/635570>
 799
 800             (call-with-output-file result
 801               (lambda (port)
 802                 (for-each (cut dump <> port) files))))
 803
 804           ;; Some file names in the NSS certificates are UTF-8 encoded so
 805           ;; install a UTF-8 locale.
 806           (setenv "LOCPATH"
 807                   (string-append #+glibc-utf8-locales "/lib/locale/"
 808                                  #+(package-version glibc-utf8-locales)))
 809           (setlocale LC_ALL "en_US.utf8")
 810
 811           (match (append-map ca-files '#$(manifest-inputs manifest))
 812             (()
 813              ;; Since there are no CA files, just create an empty directory.  Do
 814              ;; not create the etc/ssl/certs sub-directory, since that would
 815              ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be
 816              ;; defined.
 817              (mkdir #$output)
 818              #t)
 819             ((ca-files ...)
 820              (let ((result (string-append #$output "/etc/ssl/certs")))
 821                (mkdir-p result)
 822                (concatenate-files ca-files
 823                                   (string-append result
 824                                                  "/ca-certificates.crt"))
 825                #t))))))
 826
 827   (gexp->derivation "ca-certificate-bundle" build
 828                     #:local-build? #t
 829                     #:substitutable? #f))
 830
 831 (define (gtk-icon-themes manifest)
 832   "Return a derivation that unions all icon themes from manifest entries and
 833 creates the GTK+ 'icon-theme.cache' file for each theme."
 834   (define gtk+  ; lazy reference
 835     (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+))
 836
 837   (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+"))
 838                       ;; XXX: Can't use gtk-update-icon-cache corresponding
 839                       ;; to the gtk+ referenced by 'manifest'.  Because
 840                       ;; '%gtk+' can be either a package or store path, and
 841                       ;; there's no way to get the "bin" output for the later.
 842                       (gtk-update-icon-cache
 843                        -> #~(string-append #+gtk+:bin
 844                                            "/bin/gtk-update-icon-cache")))
 845
 846     (define build
 847       (with-imported-modules '((guix build utils)
 848                                (guix build union)
 849                                (guix build profiles)
 850                                (guix search-paths)
 851                                (guix records))
 852         #~(begin
 853             (use-modules (guix build utils)
 854                          (guix build union)
 855                          (guix build profiles)
 856                          (srfi srfi-26)
 857                          (ice-9 ftw))
 858
 859             (let* ((destdir  (string-append #$output "/share/icons"))
 860                    (icondirs (filter file-exists?
 861                                      (map (cut string-append <> "/share/icons")
 862                                           '#$(manifest-inputs manifest)))))
 863
 864               ;; Union all the icons.
 865               (mkdir-p (string-append #$output "/share"))
 866               (union-build destdir icondirs
 867                            #:log-port (%make-void-port "w"))
 868
 869               ;; Update the 'icon-theme.cache' file for each icon theme.
 870               (for-each
 871                (lambda (theme)
 872                  (let ((dir (string-append destdir "/" theme)))
 873                    ;; Occasionally DESTDIR contains plain files, such as
 874                    ;; "abiword_48.png".  Ignore these.
 875                    (when (file-is-directory? dir)
 876                      (ensure-writable-directory dir)
 877                      (system* #+gtk-update-icon-cache "-t" dir "--quiet"))))
 878                (scandir destdir (negate (cut member <> '("." "..")))))))))
 879
 880     ;; Don't run the hook when there's nothing to do.
 881     (if %gtk+
 882         (gexp->derivation "gtk-icon-themes" build
 883                           #:local-build? #t
 884                           #:substitutable? #f)
 885         (return #f))))
 886
 887 (define (gtk-im-modules manifest)
 888   "Return a derivation that builds the cache files for input method modules
 889 for both major versions of GTK+."
 890
 891   (mlet %store-monad ((gtk+   (manifest-lookup-package manifest "gtk+" "3"))
 892                       (gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
 893
 894     (define (build gtk gtk-version query)
 895       (let ((major (string-take gtk-version 1)))
 896         (with-imported-modules '((guix build utils)
 897                                  (guix build union)
 898                                  (guix build profiles)
 899                                  (guix search-paths)
 900                                  (guix records))
 901           #~(begin
 902               (use-modules (guix build utils)
 903                            (guix build union)
 904                            (guix build profiles)
 905                            (ice-9 popen)
 906                            (srfi srfi-1)
 907                            (srfi srfi-26))
 908
 909               (let* ((prefix  (string-append "/lib/gtk-" #$major ".0/"
 910                                              #$gtk-version))
 911                      (destdir (string-append #$output prefix))
 912                      (moddirs (cons (string-append #$gtk prefix "/immodules")
 913                                     (filter file-exists?
 914                                             (map (cut string-append <> prefix "/immodules")
 915                                                  '#$(manifest-inputs manifest)))))
 916                      (modules (append-map (cut find-files <> "\\.so$")
 917                                           moddirs)))
 918
 919                 ;; Generate a new immodules cache file.
 920                 (mkdir-p (string-append #$output prefix))
 921                 (let ((pipe    (apply open-pipe* OPEN_READ #$query modules))
 922                       (outfile (string-append #$output prefix
 923                                               "/immodules-gtk" #$major ".cache")))
 924                   (dynamic-wind
 925                     (const #t)
 926                     (lambda ()
 927                       (call-with-output-file outfile
 928                         (lambda (out)
 929                           (while (not (eof-object? (peek-char pipe)))
 930                             (write-char (read-char pipe) out))))
 931                       #t)
 932                     (lambda ()
 933                       (close-pipe pipe)))))))))
 934
 935     ;; Don't run the hook when there's nothing to do.
 936     (let* ((pkg-gtk+ (module-ref        ; lazy reference
 937                       (resolve-interface '(gnu packages gtk)) 'gtk+))
 938            (gexp #~(begin
 939                      #$(if gtk+
 940                            (build
 941                             gtk+ "3.0.0"
 942                             ;; Use 'gtk-query-immodules-3.0' from the 'bin'
 943                             ;; output of latest gtk+ package.
 944                             #~(string-append
 945                                #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0"))
 946                            #t)
 947                      #$(if gtk+-2
 948                            (build
 949                             gtk+-2 "2.10.0"
 950                             #~(string-append
 951                                #$gtk+-2 "/bin/gtk-query-immodules-2.0"))
 952                            #t))))
 953       (if (or gtk+ gtk+-2)
 954           (gexp->derivation "gtk-im-modules" gexp
 955                             #:local-build? #t
 956                             #:substitutable? #f)
 957           (return #f)))))
 958
 959 (define (xdg-desktop-database manifest)
 960   "Return a derivation that builds the @file{mimeinfo.cache} database from
 961 desktop files.  It's used to query what applications can handle a given
 962 MIME type."
 963   (mlet %store-monad ((desktop-file-utils
 964                        (manifest-lookup-package
 965                         manifest "desktop-file-utils")))
 966     (define build
 967       (with-imported-modules '((guix build utils)
 968                                (guix build union))
 969         #~(begin
 970             (use-modules (srfi srfi-26)
 971                          (guix build utils)
 972                          (guix build union))
 973             (let* ((destdir (string-append #$output "/share/applications"))
 974                    (appdirs (filter file-exists?
 975                                     (map (cut string-append <>
 976                                               "/share/applications")
 977                                          '#$(manifest-inputs manifest))))
 978                    (update-desktop-database (string-append
 979                                              #+desktop-file-utils
 980                                              "/bin/update-desktop-database")))
 981               (mkdir-p (string-append #$output "/share"))
 982               (union-build destdir appdirs
 983                            #:log-port (%make-void-port "w"))
 984               (exit (zero? (system* update-desktop-database destdir)))))))
 985
 986     ;; Don't run the hook when 'desktop-file-utils' is not referenced.
 987     (if desktop-file-utils
 988         (gexp->derivation "xdg-desktop-database" build
 989                           #:local-build? #t
 990                           #:substitutable? #f)
 991         (return #f))))
 992
 993 (define (xdg-mime-database manifest)
 994   "Return a derivation that builds the @file{mime.cache} database from manifest
 995 entries.  It's used to query the MIME type of a given file."
 996   (define shared-mime-info  ; lazy reference
 997     (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
 998
 999   (mlet %store-monad ((glib
1000                        (manifest-lookup-package
1001                         manifest "glib")))
1002     (define build
1003       (with-imported-modules  '((guix build utils)
1004                                 (guix build union))
1005         #~(begin
1006             (use-modules (srfi srfi-26)
1007                          (guix build utils)
1008                          (guix build union))
1009             (let* ((datadir (string-append #$output "/share"))
1010                    (destdir (string-append datadir "/mime"))
1011                    (pkgdirs (filter file-exists?
1012                                     (map (cut string-append <>
1013                                               "/share/mime/packages")
1014                                          (cons #+shared-mime-info
1015                                                '#$(manifest-inputs manifest)))))
1016                    (update-mime-database (string-append
1017                                           #+shared-mime-info
1018                                           "/bin/update-mime-database")))
1019               (mkdir-p destdir)
1020               (union-build (string-append destdir "/packages") pkgdirs
1021                            #:log-port (%make-void-port "w"))
1022               (setenv "XDG_DATA_HOME" datadir)
1023               (exit (zero? (system* update-mime-database destdir)))))))
1024
1025     ;; Don't run the hook when there are no GLib based applications.
1026     (if glib
1027         (gexp->derivation "xdg-mime-database" build
1028                           #:local-build? #t
1029                           #:substitutable? #f)
1030         (return #f))))
1031
1032 ;; Several font packages may install font files into same directory, so
1033 ;; fonts.dir and fonts.scale file should be generated here, instead of in
1034 ;; packages.
1035 (define (fonts-dir-file manifest)
1036   "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
1037 files for the fonts of the @var{manifest} entries."
1038   (define mkfontscale
1039     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
1040
1041   (define mkfontdir
1042     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir))
1043
1044   (define build
1045     #~(begin
1046         (use-modules (srfi srfi-26)
1047                      (guix build utils)
1048                      (guix build union))
1049         (let ((fonts-dirs (filter file-exists?
1050                                   (map (cut string-append <>
1051                                             "/share/fonts")
1052                                        '#$(manifest-inputs manifest)))))
1053           (mkdir #$output)
1054           (if (null? fonts-dirs)
1055               (exit #t)
1056               (let* ((share-dir   (string-append #$output "/share"))
1057                      (fonts-dir   (string-append share-dir "/fonts"))
1058                      (mkfontscale (string-append #+mkfontscale
1059                                                  "/bin/mkfontscale"))
1060                      (mkfontdir   (string-append #+mkfontdir
1061                                                  "/bin/mkfontdir"))
1062                      (empty-file? (lambda (filename)
1063                                     (call-with-ascii-input-file filename
1064                                       (lambda (p)
1065                                         (eqv? #\0 (read-char p))))))
1066                      (fonts-dir-file "fonts.dir")
1067                      (fonts-scale-file "fonts.scale"))
1068                 (mkdir-p share-dir)
1069                 ;; Create all sub-directories, because we may create fonts.dir
1070                 ;; and fonts.scale files in the sub-directories.
1071                 (union-build fonts-dir fonts-dirs
1072                              #:log-port (%make-void-port "w")
1073                              #:create-all-directories? #t)
1074                 (let ((directories (find-files fonts-dir
1075                                                (lambda (file stat)
1076                                                  (eq? 'directory (stat:type stat)))
1077                                                #:directories? #t)))
1078                   (for-each (lambda (dir)
1079                               (with-directory-excursion dir
1080                                 (when (file-exists? fonts-scale-file)
1081                                   (delete-file fonts-scale-file))
1082                                 (when (file-exists? fonts-dir-file)
1083                                   (delete-file fonts-dir-file))
1084                                 (unless (and (zero? (system* mkfontscale))
1085                                              (zero? (system* mkfontdir)))
1086                                   (exit #f))
1087                                 (when (empty-file? fonts-scale-file)
1088                                   (delete-file fonts-scale-file))
1089                                 (when (empty-file? fonts-dir-file)
1090                                   (delete-file fonts-dir-file))))
1091                             directories)))))))
1092
1093   (gexp->derivation "fonts-dir" build
1094                     #:modules '((guix build utils)
1095                                 (guix build union)
1096                                 (srfi srfi-26))
1097                     #:local-build? #t
1098                     #:substitutable? #f))
1099
1100 (define (manual-database manifest)
1101   "Return a derivation that builds the manual page database (\"mandb\") for
1102 the entries in MANIFEST."
1103   (define man-db                                  ;lazy reference
1104     (module-ref (resolve-interface '(gnu packages man)) 'man-db))
1105
1106   (define build
1107     #~(begin
1108         (use-modules (guix build utils)
1109                      (srfi srfi-1)
1110                      (srfi srfi-19)
1111                      (srfi srfi-26))
1112
1113         (define entries
1114           (filter-map (lambda (directory)
1115                         (let ((man (string-append directory "/share/man")))
1116                           (and (directory-exists? man)
1117                                man)))
1118                       '#$(manifest-inputs manifest)))
1119
1120         (define manpages-collection-dir
1121           (string-append (getenv "PWD") "/manpages-collection"))
1122
1123         (define man-directory
1124           (string-append #$output "/share/man"))
1125
1126         (define (get-manpage-tail-path manpage-path)
1127           (let ((index (string-contains manpage-path "/share/man/")))
1128             (unless index
1129               (error "Manual path doesn't contain \"/share/man/\":"
1130                      manpage-path))
1131             (string-drop manpage-path (+ index (string-length "/share/man/")))))
1132
1133         (define (populate-manpages-collection-dir entries)
1134           (let ((manpages (append-map (cut find-files <> #:stat stat) entries)))
1135             (for-each (lambda (manpage)
1136                         (let* ((dest-file (string-append
1137                                            manpages-collection-dir "/"
1138                                            (get-manpage-tail-path manpage))))
1139                           (mkdir-p (dirname dest-file))
1140                           (catch 'system-error
1141                             (lambda ()
1142                               (symlink manpage dest-file))
1143                             (lambda args
1144                               ;; Different packages may contain the same
1145                               ;; manpage.  Simply ignore the symlink error.
1146                               #t))))
1147                       manpages)))
1148
1149         (mkdir-p manpages-collection-dir)
1150         (populate-manpages-collection-dir entries)
1151
1152         ;; Create a mandb config file which contains a custom made
1153         ;; manpath. The associated catpath is the location where the database
1154         ;; gets generated.
1155         (copy-file #+(file-append man-db "/etc/man_db.conf")
1156                    "man_db.conf")
1157         (substitute* "man_db.conf"
1158           (("MANDB_MAP  /usr/man                /var/cache/man/fsstnd")
1159            (string-append "MANDB_MAP " manpages-collection-dir " "
1160                           man-directory)))
1161
1162         (mkdir-p man-directory)
1163         (setenv "MANPATH" (string-join entries ":"))
1164
1165         (format #t "Creating manual page database for ~a packages... "
1166                 (length entries))
1167         (force-output)
1168         (let* ((start-time (current-time))
1169                (exit-status (system* #+(file-append man-db "/bin/mandb")
1170                                     "--quiet" "--create"
1171                                     "-C" "man_db.conf"))
1172                (duration (time-difference (current-time) start-time)))
1173           (format #t "done in ~,3f s~%"
1174                   (+ (time-second duration)
1175                      (* (time-nanosecond duration) (expt 10 -9))))
1176           (force-output)
1177           (zero? exit-status))))
1178
1179   (gexp->derivation "manual-database" build
1180                     #:modules '((guix build utils)
1181                                 (srfi srfi-19)
1182                                 (srfi srfi-26))
1183                     #:local-build? #t))
1184
1185 (define %default-profile-hooks
1186   ;; This is the list of derivation-returning procedures that are called by
1187   ;; default when making a non-empty profile.
1188   (list info-dir-file
1189         manual-database
1190         fonts-dir-file
1191         ghc-package-cache-file
1192         ca-certificate-bundle
1193         gtk-icon-themes
1194         gtk-im-modules
1195         xdg-desktop-database
1196         xdg-mime-database))
1197
1198 (define* (profile-derivation manifest
1199                              #:key
1200                              (hooks %default-profile-hooks)
1201                              (locales? #t)
1202                              (allow-collisions? #f)
1203                              system target)
1204   "Return a derivation that builds a profile (aka. 'user environment') with
1205 the given MANIFEST.  The profile includes additional derivations returned by
1206 the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
1207 Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if
1208 entries in MANIFEST collide (for instance if there are two same-name packages
1209 with a different version number.)
1210
1211 When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
1212 a dependency on the 'glibc-utf8-locales' package.
1213
1214 When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
1215 are cross-built for TARGET."
1216   (mlet* %store-monad ((system (if system
1217                                    (return system)
1218                                    (current-system)))
1219                        (ok?    (if allow-collisions?
1220                                    (return #t)
1221                                    (check-for-collisions manifest system
1222                                                          #:target target)))
1223                        (extras (if (null? (manifest-entries manifest))
1224                                    (return '())
1225                                    (sequence %store-monad
1226                                              (map (lambda (hook)
1227                                                     (hook manifest))
1228                                                   hooks)))))
1229     (define inputs
1230       (append (filter-map (lambda (drv)
1231                             (and (derivation? drv)
1232                                  (gexp-input drv)))
1233                           extras)
1234               (manifest-inputs manifest)))
1235
1236     (define glibc-utf8-locales                    ;lazy reference
1237       (module-ref (resolve-interface '(gnu packages base))
1238                   'glibc-utf8-locales))
1239
1240     (define set-utf8-locale
1241       ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so
1242       ;; install a UTF-8 locale.
1243       #~(begin
1244           (setenv "LOCPATH"
1245                   #$(file-append glibc-utf8-locales "/lib/locale/"
1246                                  (package-version glibc-utf8-locales)))
1247           (setlocale LC_ALL "en_US.utf8")))
1248
1249     (define builder
1250       (with-imported-modules '((guix build profiles)
1251                                (guix build union)
1252                                (guix build utils)
1253                                (guix search-paths)
1254                                (guix records))
1255         #~(begin
1256             (use-modules (guix build profiles)
1257                          (guix search-paths)
1258                          (srfi srfi-1))
1259
1260             (setvbuf (current-output-port) _IOLBF)
1261             (setvbuf (current-error-port) _IOLBF)
1262
1263             #+(if locales? set-utf8-locale #t)
1264
1265             (define search-paths
1266               ;; Search paths of MANIFEST's packages, converted back to their
1267               ;; record form.
1268               (map sexp->search-path-specification
1269                    (delete-duplicates
1270                     '#$(map search-path-specification->sexp
1271                             (append-map manifest-entry-search-paths
1272                                         (manifest-entries manifest))))))
1273
1274             (build-profile #$output '#$inputs
1275                            #:manifest '#$(manifest->gexp manifest)
1276                            #:search-paths search-paths))))
1277
1278     (gexp->derivation "profile" builder
1279                       #:system system
1280                       #:target target
1281
1282                       ;; Not worth offloading.
1283                       #:local-build? #t
1284
1285                       ;; Disable substitution because it would trigger a
1286                       ;; connection to the substitute server, which is likely
1287                       ;; to have no substitute to offer.
1288                       #:substitutable? #f)))
1289
1290 (define (profile-regexp profile)
1291   "Return a regular expression that matches PROFILE's name and number."
1292   (make-regexp (string-append "^" (regexp-quote (basename profile))
1293                               "-([0-9]+)")))
1294
1295 (define (generation-number profile)
1296   "Return PROFILE's number or 0.  An absolute file name must be used."
1297   (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
1298                                               (basename (readlink profile))))
1299              (compose string->number (cut match:substring <> 1)))
1300       0))
1301
1302 (define (generation-numbers profile)
1303   "Return the sorted list of generation numbers of PROFILE, or '(0) if no
1304 former profiles were found."
1305   (define* (scandir name #:optional (select? (const #t))
1306                     (entry<? (@ (ice-9 i18n) string-locale<?)))
1307     ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
1308     (define (enter? dir stat result)
1309       (and stat (string=? dir name)))
1310
1311     (define (visit basename result)
1312       (if (select? basename)
1313           (cons basename result)
1314           result))
1315
1316     (define (leaf name stat result)
1317       (and result
1318            (visit (basename name) result)))
1319
1320     (define (down name stat result)
1321       (visit "." '()))
1322
1323     (define (up name stat result)
1324       (visit ".." result))
1325
1326     (define (skip name stat result)
1327       ;; All the sub-directories are skipped.
1328       (visit (basename name) result))
1329
1330     (define (error name* stat errno result)
1331       (if (string=? name name*)             ; top-level NAME is unreadable
1332           result
1333           (visit (basename name*) result)))
1334
1335     (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
1336            (lambda (files)
1337              (sort files entry<?))))
1338
1339   (match (scandir (dirname profile)
1340                   (cute regexp-exec (profile-regexp profile) <>))
1341     (#f                                         ; no profile directory
1342      '(0))
1343     (()                                         ; no profiles
1344      '(0))
1345     ((profiles ...)                             ; former profiles around
1346      (sort (map (compose string->number
1347                          (cut match:substring <> 1)
1348                          (cute regexp-exec (profile-regexp profile) <>))
1349                 profiles)
1350            <))))
1351
1352 (define (profile-generations profile)
1353   "Return a list of PROFILE's generations."
1354   (let ((generations (generation-numbers profile)))
1355     (if (equal? generations '(0))
1356         '()
1357         generations)))
1358
1359 (define (relative-generation-spec->number profile spec)
1360   "Return PROFILE's generation specified by SPEC, which is a string.  The SPEC
1361 may be a N, -N, or +N, where N is a number.  If the spec is N, then the number
1362 returned is N.  If it is -N, then the number returned is the profile's current
1363 generation number minus N.  If it is +N, then the number returned is the
1364 profile's current generation number plus N.  Return #f if there is no such
1365 generation."
1366   (let ((number (string->number spec)))
1367     (and number
1368          (case (string-ref spec 0)
1369            ((#\+ #\-)
1370             (relative-generation profile number))
1371            (else (if (memv number (profile-generations profile))
1372                      number
1373                      #f))))))
1374
1375
1376 (define* (relative-generation profile shift #:optional
1377                               (current (generation-number profile)))
1378   "Return PROFILE's generation shifted from the CURRENT generation by SHIFT.
1379 SHIFT is a positive or negative number.
1380 Return #f if there is no such generation."
1381   (let* ((abs-shift (abs shift))
1382          (numbers (profile-generations profile))
1383          (from-current (memq current
1384                              (if (negative? shift)
1385                                  (reverse numbers)
1386                                  numbers))))
1387     (and from-current
1388          (< abs-shift (length from-current))
1389          (list-ref from-current abs-shift))))
1390
1391 (define* (previous-generation-number profile #:optional
1392                                      (number (generation-number profile)))
1393   "Return the number of the generation before generation NUMBER of
1394 PROFILE, or 0 if none exists.  It could be NUMBER - 1, but it's not the
1395 case when generations have been deleted (there are \"holes\")."
1396   (or (relative-generation profile -1 number)
1397       0))
1398
1399 (define (generation-file-name profile generation)
1400   "Return the file name for PROFILE's GENERATION."
1401   (format #f "~a-~a-link" profile generation))
1402
1403 (define (generation-time profile number)
1404   "Return the creation time of a generation in the UTC format."
1405   (make-time time-utc 0
1406              (stat:ctime (stat (generation-file-name profile number)))))
1407
1408 (define (link-to-empty-profile store generation)
1409   "Link GENERATION, a string, to the empty profile.  An error is raised if
1410 that fails."
1411   (let* ((drv  (run-with-store store
1412                  (profile-derivation (manifest '())
1413                                      #:locales? #f)))
1414          (prof (derivation->output-path drv "out")))
1415     (build-derivations store (list drv))
1416     (switch-symlinks generation prof)))
1417
1418 (define (switch-to-generation profile number)
1419   "Atomically switch PROFILE to the generation NUMBER.  Return the number of
1420 the generation that was current before switching."
1421   (let ((current    (generation-number profile))
1422         (generation (generation-file-name profile number)))
1423     (cond ((not (file-exists? profile))
1424            (raise (condition (&profile-not-found-error
1425                               (profile profile)))))
1426           ((not (file-exists? generation))
1427            (raise (condition (&missing-generation-error
1428                               (profile profile)
1429                               (generation number)))))
1430           (else
1431            (switch-symlinks profile generation)
1432            current))))
1433
1434 (define (switch-to-previous-generation profile)
1435   "Atomically switch PROFILE to the previous generation.  Return the former
1436 generation number and the current one."
1437   (let ((previous (previous-generation-number profile)))
1438     (values (switch-to-generation profile previous)
1439             previous)))
1440
1441 (define (roll-back store profile)
1442   "Roll back to the previous generation of PROFILE.  Return the number of the
1443 generation that was current before switching and the new generation number."
1444   (let* ((number              (generation-number profile))
1445          (previous-number     (previous-generation-number profile number))
1446          (previous-generation (generation-file-name profile previous-number)))
1447     (cond ((not (file-exists? profile))           ;invalid profile
1448            (raise (condition (&profile-not-found-error
1449                               (profile profile)))))
1450           ((zero? number)                         ;empty profile
1451            (values number number))
1452           ((or (zero? previous-number)            ;going to emptiness
1453                (not (file-exists? previous-generation)))
1454            (link-to-empty-profile store previous-generation)
1455            (switch-to-previous-generation profile))
1456           (else                                   ;anything else
1457            (switch-to-previous-generation profile)))))
1458
1459 (define (delete-generation store profile number)
1460   "Delete generation with NUMBER from PROFILE.  Return the file name of the
1461 generation that has been deleted, or #f if nothing was done (for instance
1462 because the NUMBER is zero.)"
1463   (define (delete-and-return)
1464     (let ((generation (generation-file-name profile number)))
1465       (delete-file generation)
1466       generation))
1467
1468   (let* ((current-number      (generation-number profile))
1469          (previous-number     (previous-generation-number profile number))
1470          (previous-generation (generation-file-name profile previous-number)))
1471     (cond ((zero? number) #f)                     ;do not delete generation 0
1472           ((and (= number current-number)
1473                 (not (file-exists? previous-generation)))
1474            (link-to-empty-profile store previous-generation)
1475            (switch-to-previous-generation profile)
1476            (delete-and-return))
1477           ((= number current-number)
1478            (roll-back store profile)
1479            (delete-and-return))
1480           (else
1481            (delete-and-return)))))
1482
1483 ;;; profiles.scm ends here