guix/scripts/package.scm

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