guix/scripts/package.scm

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