guix/scripts/package.scm

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