guix/scripts/package.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
   5 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
   6 ;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
   7 ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
   8 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
   9 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
  10 ;;;
  11 ;;; This file is part of GNU Guix.
  12 ;;;
  13 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  14 ;;; under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 3 of the License, or (at
  16 ;;; your option) any later version.
  17 ;;;
  18 ;;; GNU Guix is distributed in the hope that it will be useful, but
  19 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 (define-module (guix scripts package)
  27   #:use-module (guix ui)
  28   #:use-module ((guix status) #:select (with-status-verbosity))
  29   #:use-module ((guix build syscalls) #:select (terminal-rows))
  30   #:use-module (guix store)
  31   #:use-module (guix grafts)
  32   #:use-module (guix derivations)
  33   #:use-module (guix packages)
  34   #:use-module (guix profiles)
  35   #:use-module (guix search-paths)
  36   #:use-module (guix monads)
  37   #:use-module (guix utils)
  38   #:use-module (guix config)
  39   #:use-module (guix scripts)
  40   #:use-module (guix scripts build)
  41   #:autoload   (guix describe) (package-provenance)
  42   #:use-module ((guix build utils)
  43                 #:select (directory-exists? mkdir-p))
  44   #:use-module (ice-9 format)
  45   #:use-module (ice-9 match)
  46   #:use-module (ice-9 regex)
  47   #:use-module (ice-9 vlist)
  48   #:use-module (srfi srfi-1)
  49   #:use-module (srfi srfi-11)
  50   #:use-module (srfi srfi-26)
  51   #:use-module (srfi srfi-34)
  52   #:use-module (srfi srfi-35)
  53   #:use-module (srfi srfi-37)
  54   #:use-module (gnu packages)
  55   #:autoload   (gnu packages base) (canonical-package)
  56   #:autoload   (gnu packages guile) (guile-2.2)
  57   #:autoload   (gnu packages bootstrap) (%bootstrap-guile)
  58   #:export (build-and-use-profile
  59             delete-generations
  60             delete-matching-generations
  61             guix-package
  62
  63             (%options . %package-options)
  64             (%default-options . %package-default-options)
  65             guix-package*))
  66
  67 (define %store
  68   (make-parameter #f))
  69
  70 \f
  71 ;;;
  72 ;;; Profiles.
  73 ;;;
  74
  75 (define (ensure-default-profile)
  76   "Ensure the default profile symlink and directory exist and are writable."
  77   (ensure-profile-directory)
  78
  79   ;; Create ~/.guix-profile if it doesn't exist yet.
  80   (when (and %user-profile-directory
  81              %current-profile
  82              (not (false-if-exception
  83                    (lstat %user-profile-directory))))
  84     (symlink %current-profile %user-profile-directory)))
  85
  86 (define (delete-generations store profile generations)
  87   "Delete GENERATIONS from PROFILE.
  88 GENERATIONS is a list of generation numbers."
  89   (for-each (cut delete-generation* store profile <>)
  90             generations))
  91
  92 (define (delete-matching-generations store profile pattern)
  93   "Delete from PROFILE all the generations matching PATTERN.  PATTERN must be
  94 a string denoting a set of generations: the empty list means \"all generations
  95 but the current one\", a number designates a generation, and other patterns
  96 denote ranges as interpreted by 'matching-generations'."
  97   (let ((current (generation-number profile)))
  98     (cond ((not (file-exists? profile))            ; XXX: race condition
  99            (raise (condition (&profile-not-found-error
 100                               (profile profile)))))
 101           ((not pattern)
 102            (delete-generations store profile
 103                                (delv current (profile-generations profile))))
 104           ;; Do not delete the zeroth generation.
 105           ((equal? 0 (string->number pattern))
 106            #t)
 107
 108           ;; If PATTERN is a duration, match generations that are
 109           ;; older than the specified duration.
 110           ((matching-generations pattern profile
 111                                  #:duration-relation >)
 112            =>
 113            (lambda (numbers)
 114              (when (memv current numbers)
 115                (warning (G_ "not removing generation ~a, which is current~%")
 116                         current))
 117
 118              ;; Make sure we don't inadvertently remove the current
 119              ;; generation.
 120              (let ((numbers (delv current numbers)))
 121                (when (null-list? numbers)
 122                  (leave (G_ "no matching generation~%")))
 123                (delete-generations store profile numbers)))))))
 124
 125 (define* (build-and-use-profile store profile manifest
 126                                 #:key
 127                                 (hooks %default-profile-hooks)
 128                                 allow-collisions?
 129                                 bootstrap? use-substitutes?
 130                                 dry-run?)
 131   "Build a new generation of PROFILE, a file name, using the packages
 132 specified in MANIFEST, a manifest object.  When ALLOW-COLLISIONS? is true,
 133 do not treat collisions in MANIFEST as an error.  HOOKS is a list of \"profile
 134 hooks\" run when building the profile."
 135   (when (equal? profile %current-profile)
 136     (ensure-default-profile))
 137
 138   (let* ((prof-drv (run-with-store store
 139                      (profile-derivation manifest
 140                                          #:allow-collisions? allow-collisions?
 141                                          #:hooks (if bootstrap? '() hooks)
 142                                          #:locales? (not bootstrap?))))
 143          (prof     (derivation->output-path prof-drv)))
 144     (show-what-to-build store (list prof-drv)
 145                         #:use-substitutes? use-substitutes?
 146                         #:dry-run? dry-run?)
 147
 148     (cond
 149      (dry-run? #t)
 150      ((and (file-exists? profile)
 151            (and=> (readlink* profile) (cut string=? prof <>)))
 152       (format (current-error-port) (G_ "nothing to be done~%")))
 153      (else
 154       (let* ((number (generation-number profile))
 155
 156              ;; Always use NUMBER + 1 for the new profile, possibly
 157              ;; overwriting a "previous future generation".
 158              (name   (generation-file-name profile (+ 1 number))))
 159         (and (build-derivations store (list prof-drv))
 160              (let* ((entries (manifest-entries manifest))
 161                     (count   (length entries)))
 162                (switch-symlinks name prof)
 163                (switch-symlinks profile (basename name))
 164                (unless (string=? profile %current-profile)
 165                  (register-gc-root store name))
 166                (format #t (N_ "~a package in profile~%"
 167                               "~a packages in profile~%"
 168                               count)
 169                        count)
 170                (display-search-path-hint entries profile)))
 171
 172         (warn-about-disk-space profile))))))
 173
 174 \f
 175 ;;;
 176 ;;; Package specifications.
 177 ;;;
 178
 179 (define (find-packages-by-description regexps)
 180   "Return a list of pairs: packages whose name, synopsis, description,
 181 or output matches at least one of REGEXPS sorted by relevance, and its
 182 non-zero relevance score."
 183   (let ((matches (fold-packages (lambda (package result)
 184                                   (if (package-superseded package)
 185                                       result
 186                                       (match (package-relevance package
 187                                                                 regexps)
 188                                         ((? zero?)
 189                                          result)
 190                                         (score
 191                                          (cons (cons package score)
 192                                                result)))))
 193                                 '())))
 194     (sort matches
 195           (lambda (m1 m2)
 196             (match m1
 197               ((package1 . score1)
 198                (match m2
 199                  ((package2 . score2)
 200                   (if (= score1 score2)
 201                       (string>? (package-full-name package1)
 202                                 (package-full-name package2))
 203                       (> score1 score2))))))))))
 204
 205 (define (transaction-upgrade-entry entry transaction)
 206   "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
 207 <manifest-entry>."
 208   (define (supersede old new)
 209     (info (G_ "package '~a' has been superseded by '~a'~%")
 210           (manifest-entry-name old) (package-name new))
 211     (manifest-transaction-install-entry
 212      (package->manifest-entry* new (manifest-entry-output old))
 213      (manifest-transaction-remove-pattern
 214       (manifest-pattern
 215         (name (manifest-entry-name old))
 216         (version (manifest-entry-version old))
 217         (output (manifest-entry-output old)))
 218       transaction)))
 219
 220   (match (if (manifest-transaction-removal-candidate? entry transaction)
 221              'dismiss
 222              entry)
 223     ('dismiss
 224      transaction)
 225     (($ <manifest-entry> name version output (? string? path))
 226      (match (find-best-packages-by-name name #f)
 227        ((pkg . rest)
 228         (let ((candidate-version (package-version pkg)))
 229           (match (package-superseded pkg)
 230             ((? package? new)
 231              (supersede entry new))
 232             (#f
 233              (case (version-compare candidate-version version)
 234                ((>)
 235                 (manifest-transaction-install-entry
 236                  (package->manifest-entry* pkg output)
 237                  transaction))
 238                ((<)
 239                 transaction)
 240                ((=)
 241                 (let ((candidate-path (derivation->output-path
 242                                        (package-derivation (%store) pkg))))
 243                   ;; XXX: When there are propagated inputs, assume we need to
 244                   ;; upgrade the whole entry.
 245                   (if (and (string=? path candidate-path)
 246                            (null? (package-propagated-inputs pkg)))
 247                       transaction
 248                       (manifest-transaction-install-entry
 249                        (package->manifest-entry* pkg output)
 250                        transaction)))))))))
 251        (()
 252         (warning (G_ "package '~a' no longer exists~%") name)
 253         transaction)))))
 254
 255 \f
 256 ;;;
 257 ;;; Search paths.
 258 ;;;
 259
 260 (define* (search-path-environment-variables entries profiles
 261                                             #:optional (getenv getenv)
 262                                             #:key (kind 'exact))
 263   "Return environment variable definitions that may be needed for the use of
 264 ENTRIES, a list of manifest entries, in PROFILES.  Use GETENV to determine the
 265 current settings and report only settings not already effective.  KIND
 266 must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search
 267 path definition to be returned."
 268   (let ((search-paths (delete-duplicates
 269                        (cons $PATH
 270                              (append-map manifest-entry-search-paths
 271                                          entries)))))
 272     (filter-map (match-lambda
 273                   ((spec . value)
 274                    (let ((variable (search-path-specification-variable spec))
 275                          (sep      (search-path-specification-separator spec)))
 276                      (environment-variable-definition variable value
 277                                                       #:separator sep
 278                                                       #:kind kind))))
 279                 (evaluate-search-paths search-paths profiles
 280                                        getenv))))
 281
 282 (define (absolutize file)
 283   "Return an absolute file name equivalent to FILE, but without resolving
 284 symlinks like 'canonicalize-path' would do."
 285   (if (string-prefix? "/" file)
 286       file
 287       (string-append (getcwd) "/" file)))
 288
 289 (define (display-search-path-hint entries profile)
 290   "Display a hint on how to set environment variables to use ENTRIES, a list
 291 of manifest entries, in the context of PROFILE."
 292   (let* ((profile  (user-friendly-profile (absolutize profile)))
 293          (settings (search-path-environment-variables entries (list profile)
 294                                                       #:kind 'prefix)))
 295     (unless (null? settings)
 296       (display-hint (format #f (G_ "Consider setting the necessary environment
 297 variables by running:
 298
 299 @example
 300 GUIX_PROFILE=\"~a\"
 301 . \"$GUIX_PROFILE/etc/profile\"
 302 @end example
 303
 304 Alternately, see @command{guix package --search-paths -p ~s}.")
 305                             profile profile)))))
 306
 307 \f
 308 ;;;
 309 ;;; Command-line options.
 310 ;;;
 311
 312 (define %default-options
 313   ;; Alist of default option values.
 314   `((verbosity . 1)
 315     (debug . 0)
 316     (graft? . #t)
 317     (substitutes? . #t)
 318     (build-hook? . #t)
 319     (print-build-trace? . #t)
 320     (print-extended-build-trace? . #t)
 321     (multiplexed-build-output? . #t)))
 322
 323 (define (show-help)
 324   (display (G_ "Usage: guix package [OPTION]...
 325 Install, remove, or upgrade packages in a single transaction.\n"))
 326   (display (G_ "
 327   -i, --install PACKAGE ...
 328                          install PACKAGEs"))
 329   (display (G_ "
 330   -e, --install-from-expression=EXP
 331                          install the package EXP evaluates to"))
 332   (display (G_ "
 333   -f, --install-from-file=FILE
 334                          install the package that the code within FILE
 335                          evaluates to"))
 336   (display (G_ "
 337   -r, --remove PACKAGE ...
 338                          remove PACKAGEs"))
 339   (display (G_ "
 340   -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
 341   (display (G_ "
 342   -m, --manifest=FILE    create a new profile generation with the manifest
 343                          from FILE"))
 344   (display (G_ "
 345       --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
 346   (display (G_ "
 347       --roll-back        roll back to the previous generation"))
 348   (display (G_ "
 349       --search-paths[=KIND]
 350                          display needed environment variable definitions"))
 351   (display (G_ "
 352   -l, --list-generations[=PATTERN]
 353                          list generations matching PATTERN"))
 354   (display (G_ "
 355   -d, --delete-generations[=PATTERN]
 356                          delete generations matching PATTERN"))
 357   (display (G_ "
 358   -S, --switch-generation=PATTERN
 359                          switch to a generation matching PATTERN"))
 360   (display (G_ "
 361   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
 362   (newline)
 363   (display (G_ "
 364       --allow-collisions do not treat collisions in the profile as an error"))
 365   (display (G_ "
 366       --bootstrap        use the bootstrap Guile to build the profile"))
 367   (display (G_ "
 368   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 369   (newline)
 370   (display (G_ "
 371   -s, --search=REGEXP    search in synopsis and description using REGEXP"))
 372   (display (G_ "
 373   -I, --list-installed[=REGEXP]
 374                          list installed packages matching REGEXP"))
 375   (display (G_ "
 376   -A, --list-available[=REGEXP]
 377                          list available packages matching REGEXP"))
 378   (display (G_ "
 379       --show=PACKAGE     show details about PACKAGE"))
 380   (newline)
 381   (show-build-options-help)
 382   (newline)
 383   (show-transformation-options-help)
 384   (newline)
 385   (display (G_ "
 386   -h, --help             display this help and exit"))
 387   (display (G_ "
 388   -V, --version          display version information and exit"))
 389   (newline)
 390   (show-bug-report-information))
 391
 392 (define %options
 393   ;; Specification of the command-line options.
 394   (cons* (option '(#\h "help") #f #f
 395                  (lambda args
 396                    (show-help)
 397                    (exit 0)))
 398          (option '(#\V "version") #f #f
 399                  (lambda args
 400                    (show-version-and-exit "guix package")))
 401
 402          (option '(#\i "install") #f #t
 403                  (lambda (opt name arg result arg-handler)
 404                    (let arg-handler ((arg arg) (result result))
 405                      (values (if arg
 406                                  (alist-cons 'install arg result)
 407                                  result)
 408                              arg-handler))))
 409          (option '(#\e "install-from-expression") #t #f
 410                  (lambda (opt name arg result arg-handler)
 411                    (values (alist-cons 'install (read/eval-package-expression arg)
 412                                        result)
 413                            #f)))
 414          (option '(#\f "install-from-file") #t #f
 415                  (lambda (opt name arg result arg-handler)
 416                    (values (alist-cons 'install
 417                                        (load* arg (make-user-module '()))
 418                                        result)
 419                            #f)))
 420          (option '(#\r "remove") #f #t
 421                  (lambda (opt name arg result arg-handler)
 422                    (let arg-handler ((arg arg) (result result))
 423                      (values (if arg
 424                                  (alist-cons 'remove arg result)
 425                                  result)
 426                              arg-handler))))
 427          (option '(#\u "upgrade") #f #t
 428                  (lambda (opt name arg result arg-handler)
 429                    (when (and arg (string-prefix? "-" arg))
 430                      (warning (G_ "upgrade regexp '~a' looks like a \
 431 command-line option~%")
 432                               arg)
 433                      (warning (G_ "is this intended?~%")))
 434                    (let arg-handler ((arg arg) (result result))
 435                      (values (alist-cons 'upgrade arg
 436                                          ;; Delete any prior "upgrade all"
 437                                          ;; command, or else "--upgrade gcc"
 438                                          ;; would upgrade everything.
 439                                          (delete '(upgrade . #f) result))
 440                              arg-handler))))
 441          (option '("do-not-upgrade") #f #t
 442                  (lambda (opt name arg result arg-handler)
 443                    (let arg-handler ((arg arg) (result result))
 444                      (values (if arg
 445                                  (alist-cons 'do-not-upgrade arg result)
 446                                  result)
 447                              arg-handler))))
 448          (option '("roll-back" "rollback") #f #f
 449                  (lambda (opt name arg result arg-handler)
 450                    (values (alist-cons 'roll-back? #t result)
 451                            #f)))
 452          (option '(#\m "manifest") #t #f
 453                  (lambda (opt name arg result arg-handler)
 454                    (values (alist-cons 'manifest arg result)
 455                            arg-handler)))
 456          (option '(#\l "list-generations") #f #t
 457                  (lambda (opt name arg result arg-handler)
 458                    (values (cons `(query list-generations ,arg)
 459                                  result)
 460                            #f)))
 461          (option '(#\d "delete-generations") #f #t
 462                  (lambda (opt name arg result arg-handler)
 463                    (values (alist-cons 'delete-generations arg
 464                                        result)
 465                            #f)))
 466          (option '(#\S "switch-generation") #t #f
 467                  (lambda (opt name arg result arg-handler)
 468                    (values (alist-cons 'switch-generation arg result)
 469                            #f)))
 470          (option '("search-paths") #f #t
 471                  (lambda (opt name arg result arg-handler)
 472                    (let ((kind (match arg
 473                                  ((or "exact" "prefix" "suffix")
 474                                   (string->symbol arg))
 475                                  (#f
 476                                   'exact)
 477                                  (x
 478                                   (leave (G_ "~a: unsupported \
 479 kind of search path~%")
 480                                          x)))))
 481                      (values (cons `(query search-paths ,kind)
 482                                    result)
 483                              #f))))
 484          (option '(#\p "profile") #t #f
 485                  (lambda (opt name arg result arg-handler)
 486                    (values (alist-cons 'profile (canonicalize-profile arg)
 487                                        result)
 488                            #f)))
 489          (option '(#\n "dry-run") #f #f
 490                  (lambda (opt name arg result arg-handler)
 491                    (values (alist-cons 'dry-run? #t
 492                                        (alist-cons 'graft? #f result))
 493                            #f)))
 494          (option '(#\v "verbosity") #t #f
 495                  (lambda (opt name arg result arg-handler)
 496                    (let ((level (string->number* arg)))
 497                      (values (alist-cons 'verbosity level
 498                                          (alist-delete 'verbosity result))
 499                              #f))))
 500          (option '("bootstrap") #f #f
 501                  (lambda (opt name arg result arg-handler)
 502                    (values (alist-cons 'bootstrap? #t result)
 503                            #f)))
 504          (option '("verbose") #f #f               ;deprecated
 505                  (lambda (opt name arg result arg-handler)
 506                    (values (alist-cons 'verbosity 2
 507                                        (alist-delete 'verbosity
 508                                                      result))
 509                            #f)))
 510          (option '("allow-collisions") #f #f
 511                  (lambda (opt name arg result arg-handler)
 512                    (values (alist-cons 'allow-collisions? #t result)
 513                            #f)))
 514          (option '(#\s "search") #t #f
 515                  (lambda (opt name arg result arg-handler)
 516                    (values (cons `(query search ,(or arg ""))
 517                                  result)
 518                            #f)))
 519          (option '(#\I "list-installed") #f #t
 520                  (lambda (opt name arg result arg-handler)
 521                    (values (cons `(query list-installed ,(or arg ""))
 522                                  result)
 523                            #f)))
 524          (option '(#\A "list-available") #f #t
 525                  (lambda (opt name arg result arg-handler)
 526                    (values (cons `(query list-available ,(or arg ""))
 527                                  result)
 528                            #f)))
 529          (option '("show") #t #t
 530                  (lambda (opt name arg result arg-handler)
 531                    (values (cons `(query show ,arg)
 532                                  result)
 533                            #f)))
 534
 535          (append %transformation-options
 536                  %standard-build-options)))
 537
 538 (define (options->upgrade-predicate opts)
 539   "Return a predicate based on the upgrade/do-not-upgrade regexps in OPTS
 540 that, given a package name, returns true if the package is a candidate for
 541 upgrading, #f otherwise."
 542   (define upgrade-regexps
 543     (filter-map (match-lambda
 544                   (('upgrade . regexp)
 545                    (make-regexp* (or regexp "") regexp/icase))
 546                   (_ #f))
 547                 opts))
 548
 549   (define do-not-upgrade-regexps
 550     (filter-map (match-lambda
 551                   (('do-not-upgrade . regexp)
 552                    (make-regexp* regexp regexp/icase))
 553                   (_ #f))
 554                 opts))
 555
 556   (lambda (name)
 557     (and (any (cut regexp-exec <> name) upgrade-regexps)
 558          (not (any (cut regexp-exec <> name) do-not-upgrade-regexps)))))
 559
 560 (define (store-item->manifest-entry item)
 561   "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name."
 562   (let-values (((name version)
 563                 (package-name->name+version (store-path-package-name item)
 564                                             #\-)))
 565     (manifest-entry
 566       (name name)
 567       (version version)
 568       (output "out")                              ;XXX: wild guess
 569       (item item))))
 570
 571 (define (package->manifest-entry* package output)
 572   "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to
 573 the resulting manifest entry."
 574   (define (provenance-properties package)
 575     (match (package-provenance package)
 576       (#f   '())
 577       (sexp `((provenance ,@sexp)))))
 578
 579   (package->manifest-entry package output
 580                            #:properties (provenance-properties package)))
 581
 582
 583 (define (options->installable opts manifest transaction)
 584   "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
 585 return an variant of TRANSACTION that accounts for the specified installations
 586 and upgrades."
 587   (define upgrade?
 588     (options->upgrade-predicate opts))
 589
 590   (define upgraded
 591     (fold (lambda (entry transaction)
 592             (if (upgrade? (manifest-entry-name entry))
 593                 (transaction-upgrade-entry entry transaction)
 594                 transaction))
 595           transaction
 596           (manifest-entries manifest)))
 597
 598   (define to-install
 599     (filter-map (match-lambda
 600                   (('install . (? package? p))
 601                    ;; When given a package via `-e', install the first of its
 602                    ;; outputs (XXX).
 603                    (package->manifest-entry* p "out"))
 604                   (('install . (? string? spec))
 605                    (if (store-path? spec)
 606                        (store-item->manifest-entry spec)
 607                        (let-values (((package output)
 608                                      (specification->package+output spec)))
 609                          (package->manifest-entry* package output))))
 610                   (('install . obj)
 611                    (leave (G_ "cannot install non-package object: ~s~%")
 612                           obj))
 613                   (_
 614                    #f))
 615                 opts))
 616
 617   (fold manifest-transaction-install-entry
 618         upgraded
 619         to-install))
 620
 621 (define (options->removable options manifest transaction)
 622   "Given options, return a variant of TRANSACTION augmented with the list of
 623 patterns of packages to remove."
 624   (fold (lambda (opt transaction)
 625           (match opt
 626             (('remove . spec)
 627              (call-with-values
 628                  (lambda ()
 629                    (package-specification->name+version+output spec))
 630                (lambda (name version output)
 631                  (manifest-transaction-remove-pattern
 632                   (manifest-pattern
 633                     (name name)
 634                     (version version)
 635                     (output output))
 636                   transaction))))
 637             (_ transaction)))
 638         transaction
 639         options))
 640
 641 (define (register-gc-root store profile)
 642   "Register PROFILE, a profile generation symlink, as a GC root, unless it
 643 doesn't need it."
 644   (define absolute
 645     ;; We must pass the daemon an absolute file name for PROFILE.  However, we
 646     ;; cannot use (canonicalize-path profile) because that would return us the
 647     ;; target of PROFILE in the store; using a store item as an indirect root
 648     ;; would mean that said store item will always remain live, which is not
 649     ;; what we want here.
 650     (if (string-prefix? "/" profile)
 651         profile
 652         (string-append (getcwd) "/" profile)))
 653
 654   (add-indirect-root store absolute))
 655
 656 \f
 657 ;;;
 658 ;;; Queries and actions.
 659 ;;;
 660
 661 (define (process-query opts)
 662   "Process any query specified by OPTS.  Return #t when a query was actually
 663 processed, #f otherwise."
 664   (let* ((profiles (match (filter-map (match-lambda
 665                                         (('profile . p) p)
 666                                         (_              #f))
 667                                       opts)
 668                      (() (list %current-profile))
 669                      (lst (reverse lst))))
 670          (profile  (match profiles
 671                      ((head tail ...) head))))
 672     (match (assoc-ref opts 'query)
 673       (('list-generations pattern)
 674        (define (list-generation display-function number)
 675          (unless (zero? number)
 676            (display-generation profile number)
 677            (display-function profile number)
 678            (newline)))
 679        (define (diff-profiles profile numbers)
 680          (unless (null-list? (cdr numbers))
 681            (display-profile-content-diff profile (car numbers) (cadr numbers))
 682            (diff-profiles profile (cdr numbers))))
 683
 684        (leave-on-EPIPE
 685         (cond ((not (file-exists? profile))       ; XXX: race condition
 686                (raise (condition (&profile-not-found-error
 687                                   (profile profile)))))
 688               ((not pattern)
 689                (match (profile-generations profile)
 690                  (()
 691                   #t)
 692                  ((first rest ...)
 693                   (list-generation display-profile-content first)
 694                   (diff-profiles profile (cons first rest)))))
 695               ((matching-generations pattern profile)
 696                =>
 697                (lambda (numbers)
 698                  (if (null-list? numbers)
 699                      (exit 1)
 700                      (begin
 701                        (list-generation display-profile-content (car numbers))
 702                        (diff-profiles profile numbers)))))))
 703        #t)
 704
 705       (('list-installed regexp)
 706        (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
 707               (manifest  (profile-manifest profile))
 708               (installed (manifest-entries manifest)))
 709          (leave-on-EPIPE
 710           (for-each (match-lambda
 711                       (($ <manifest-entry> name version output path _)
 712                        (when (or (not regexp)
 713                                  (regexp-exec regexp name))
 714                          (format #t "~a\t~a\t~a\t~a~%"
 715                                  name (or version "?") output path))))
 716
 717                     ;; Show most recently installed packages last.
 718                     (reverse installed)))
 719          #t))
 720
 721       (('list-available regexp)
 722        (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
 723               (available (fold-available-packages
 724                           (lambda* (name version result
 725                                          #:key outputs location
 726                                          supported? deprecated?
 727                                          #:allow-other-keys)
 728                             (if (and supported? (not deprecated?))
 729                                 (if regexp
 730                                     (if (regexp-exec regexp name)
 731                                         (cons `(,name ,version
 732                                                       ,outputs ,location)
 733                                               result)
 734                                         result)
 735                                     (cons `(,name ,version
 736                                                   ,outputs ,location)
 737                                           result))
 738                                 result))
 739                           '())))
 740          (leave-on-EPIPE
 741           (for-each (match-lambda
 742                       ((name version outputs location)
 743                        (format #t "~a\t~a\t~a\t~a~%"
 744                                name version
 745                                (string-join outputs ",")
 746                                (location->string location))))
 747                     (sort available
 748                           (match-lambda*
 749                             (((name1 . _) (name2 . _))
 750                              (string<? name1 name2))))))
 751          #t))
 752
 753       (('search _)
 754        (let* ((patterns (filter-map (match-lambda
 755                                       (('query 'search rx) rx)
 756                                       (_                   #f))
 757                                     opts))
 758               (regexps  (map (cut make-regexp* <> regexp/icase) patterns))
 759               (matches  (find-packages-by-description regexps)))
 760          (leave-on-EPIPE
 761           (display-search-results matches (current-output-port)))
 762          #t))
 763
 764       (('show requested-name)
 765        (let-values (((name version)
 766                      (package-name->name+version requested-name)))
 767          (match (find-packages-by-name name version)
 768            (()
 769             (leave (G_ "~a~@[@~a~]: package not found~%") name version))
 770            (packages
 771             (leave-on-EPIPE
 772              (for-each (cute package->recutils <> (current-output-port))
 773                        packages))))
 774          #t))
 775
 776       (('search-paths kind)
 777        (let* ((manifests (map profile-manifest profiles))
 778               (entries   (append-map manifest-transitive-entries
 779                                      manifests))
 780               (profiles  (map user-friendly-profile profiles))
 781               (settings  (search-path-environment-variables entries profiles
 782                                                             (const #f)
 783                                                             #:kind kind)))
 784          (format #t "~{~a~%~}" settings)
 785          #t))
 786
 787       (_ #f))))
 788
 789
 790 (define* (roll-back-action store profile arg opts
 791                            #:key dry-run?)
 792   "Roll back PROFILE to its previous generation."
 793   (unless dry-run?
 794     (roll-back* store profile)))
 795
 796 (define* (switch-generation-action store profile spec opts
 797                                    #:key dry-run?)
 798   "Switch PROFILE to the generation specified by SPEC."
 799   (unless dry-run?
 800     (let ((number (relative-generation-spec->number profile spec)))
 801       (if number
 802           (switch-to-generation* profile number)
 803           (leave (G_ "cannot switch to generation '~a'~%") spec)))))
 804
 805 (define* (delete-generations-action store profile pattern opts
 806                                     #:key dry-run?)
 807   "Delete PROFILE's generations that match PATTERN."
 808   (unless dry-run?
 809     (delete-matching-generations store profile pattern)))
 810
 811 (define* (manifest-action store profile file opts
 812                           #:key dry-run?)
 813   "Change PROFILE to contain the packages specified in FILE."
 814   (let* ((user-module  (make-user-module '((guix profiles) (gnu))))
 815          (manifest     (load* file user-module))
 816          (bootstrap?   (assoc-ref opts 'bootstrap?))
 817          (substitutes? (assoc-ref opts 'substitutes?))
 818          (allow-collisions? (assoc-ref opts 'allow-collisions?)))
 819     (if dry-run?
 820         (format #t (G_ "would install new manifest from '~a' with ~d entries~%")
 821                 file (length (manifest-entries manifest)))
 822         (format #t (G_ "installing new manifest from '~a' with ~d entries~%")
 823                 file (length (manifest-entries manifest))))
 824     (build-and-use-profile store profile manifest
 825                            #:allow-collisions? allow-collisions?
 826                            #:bootstrap? bootstrap?
 827                            #:use-substitutes? substitutes?
 828                            #:dry-run? dry-run?)))
 829
 830 (define %actions
 831   ;; List of actions that may be processed.  The car of each pair is the
 832   ;; action's symbol in the option list; the cdr is the action's procedure.
 833   `((roll-back? . ,roll-back-action)
 834     (switch-generation . ,switch-generation-action)
 835     (delete-generations . ,delete-generations-action)
 836     (manifest . ,manifest-action)))
 837
 838 (define (process-actions store opts)
 839   "Process any install/remove/upgrade action from OPTS."
 840
 841   (define dry-run? (assoc-ref opts 'dry-run?))
 842   (define bootstrap? (assoc-ref opts 'bootstrap?))
 843   (define substitutes? (assoc-ref opts 'substitutes?))
 844   (define allow-collisions? (assoc-ref opts 'allow-collisions?))
 845   (define profile  (or (assoc-ref opts 'profile) %current-profile))
 846   (define transform (options->transformation opts))
 847
 848   (define (transform-entry entry)
 849     (let ((item (transform store (manifest-entry-item entry))))
 850       (manifest-entry
 851         (inherit entry)
 852         (item item)
 853         (version (if (package? item)
 854                      (package-version item)
 855                      (manifest-entry-version entry))))))
 856
 857   ;; First, process roll-backs, generation removals, etc.
 858   (for-each (match-lambda
 859               ((key . arg)
 860                (and=> (assoc-ref %actions key)
 861                       (lambda (proc)
 862                         (proc store profile arg opts
 863                               #:dry-run? dry-run?)))))
 864             opts)
 865
 866   ;; Then, process normal package removal/installation/upgrade.
 867   (let* ((manifest (profile-manifest profile))
 868          (step1    (options->removable opts manifest
 869                                        (manifest-transaction)))
 870          (step2    (options->installable opts manifest step1))
 871          (step3    (manifest-transaction
 872                     (inherit step2)
 873                     (install (map transform-entry
 874                                   (manifest-transaction-install step2)))))
 875          (new      (manifest-perform-transaction manifest step3)))
 876
 877     (warn-about-old-distro)
 878
 879     (unless (manifest-transaction-null? step3)
 880       (show-manifest-transaction store manifest step3
 881                                  #:dry-run? dry-run?)
 882       (build-and-use-profile store profile new
 883                              #:allow-collisions? allow-collisions?
 884                              #:bootstrap? bootstrap?
 885                              #:use-substitutes? substitutes?
 886                              #:dry-run? dry-run?))))
 887
 888 \f
 889 ;;;
 890 ;;; Entry point.
 891 ;;;
 892
 893 (define (guix-package . args)
 894   (define (handle-argument arg result arg-handler)
 895     ;; Process non-option argument ARG by calling back ARG-HANDLER.
 896     (if arg-handler
 897         (arg-handler arg result)
 898         (leave (G_ "~A: extraneous argument~%") arg)))
 899
 900   (define opts
 901     (parse-command-line args %options (list %default-options #f)
 902                         #:argument-handler handle-argument))
 903
 904   (guix-package* opts))
 905
 906 (define (guix-package* opts)
 907   "Run the 'guix package' command on OPTS, an alist resulting for command-line
 908 option processing with 'parse-command-line'."
 909   (with-error-handling
 910     (or (process-query opts)
 911         (parameterize ((%store  (open-connection))
 912                        (%graft? (assoc-ref opts 'graft?)))
 913           (with-status-verbosity (assoc-ref opts 'verbosity)
 914             (set-build-options-from-command-line (%store) opts)
 915             (parameterize ((%guile-for-build
 916                             (package-derivation
 917                              (%store)
 918                              (if (assoc-ref opts 'bootstrap?)
 919                                  %bootstrap-guile
 920                                  (canonical-package guile-2.2)))))
 921               (process-actions (%store) opts)))))))