guix/scripts/package.scm

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