guix/scripts/package.scm

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