guix/scripts/pull.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix scripts pull)
  21   #:use-module ((guix ui) #:hide (display-profile-content))
  22   #:use-module (guix colors)
  23   #:use-module (guix utils)
  24   #:use-module ((guix status) #:select (with-status-verbosity))
  25   #:use-module (guix scripts)
  26   #:use-module (guix store)
  27   #:use-module (guix config)
  28   #:use-module (guix packages)
  29   #:use-module (guix derivations)
  30   #:use-module (guix profiles)
  31   #:use-module (guix gexp)
  32   #:use-module (guix grafts)
  33   #:use-module (guix memoization)
  34   #:use-module (guix monads)
  35   #:use-module (guix channels)
  36   #:autoload   (guix inferior) (open-inferior
  37                                 inferior-available-packages
  38                                 close-inferior)
  39   #:use-module (guix scripts build)
  40   #:use-module (guix scripts describe)
  41   #:autoload   (guix build utils) (which)
  42   #:use-module ((guix build syscalls)
  43                 #:select (with-file-lock/no-wait))
  44   #:use-module (guix git)
  45   #:use-module (git)
  46   #:use-module (gnu packages)
  47   #:use-module ((guix scripts package) #:select (build-and-use-profile
  48                                                  delete-matching-generations))
  49   #:use-module ((gnu packages base) #:select (canonical-package))
  50   #:use-module (gnu packages guile)
  51   #:use-module ((gnu packages bootstrap)
  52                 #:select (%bootstrap-guile))
  53   #:use-module ((gnu packages certs) #:select (le-certs))
  54   #:use-module (srfi srfi-1)
  55   #:use-module (srfi srfi-11)
  56   #:use-module (srfi srfi-26)
  57   #:use-module (srfi srfi-34)
  58   #:use-module (srfi srfi-35)
  59   #:use-module (srfi srfi-37)
  60   #:use-module (ice-9 match)
  61   #:use-module (ice-9 vlist)
  62   #:use-module (ice-9 format)
  63   #:re-export (display-profile-content
  64                channel-commit-hyperlink)
  65   #:export (channel-list
  66             with-git-error-handling
  67             guix-pull))
  68
  69 \f
  70 ;;;
  71 ;;; Command-line options.
  72 ;;;
  73
  74 (define %default-options
  75   ;; Alist of default option values.
  76   `((system . ,(%current-system))
  77     (substitutes? . #t)
  78     (offload? . #t)
  79     (print-build-trace? . #t)
  80     (print-extended-build-trace? . #t)
  81     (multiplexed-build-output? . #t)
  82     (graft? . #t)
  83     (debug . 0)
  84     (verbosity . 1)))
  85
  86 (define (show-help)
  87   (display (G_ "Usage: guix pull [OPTION]...
  88 Download and deploy the latest version of Guix.\n"))
  89   (display (G_ "
  90   -C, --channels=FILE    deploy the channels defined in FILE"))
  91   (display (G_ "
  92       --url=URL          download from the Git repository at URL"))
  93   (display (G_ "
  94       --commit=COMMIT    download the specified COMMIT"))
  95   (display (G_ "
  96       --branch=BRANCH    download the tip of the specified BRANCH"))
  97   (display (G_ "
  98   -N, --news             display news compared to the previous generation"))
  99   (display (G_ "
 100   -l, --list-generations[=PATTERN]
 101                          list generations matching PATTERN"))
 102   (display (G_ "
 103       --roll-back        roll back to the previous generation"))
 104   (display (G_ "
 105   -d, --delete-generations[=PATTERN]
 106                          delete generations matching PATTERN"))
 107   (display (G_ "
 108   -S, --switch-generation=PATTERN
 109                          switch to a generation matching PATTERN"))
 110   (display (G_ "
 111   -p, --profile=PROFILE  use PROFILE instead of ~/.config/guix/current"))
 112   (display (G_ "
 113   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 114   (display (G_ "
 115   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
 116   (display (G_ "
 117       --bootstrap        use the bootstrap Guile to build the new Guix"))
 118   (newline)
 119   (show-build-options-help)
 120   (display (G_ "
 121   -h, --help             display this help and exit"))
 122   (display (G_ "
 123   -V, --version          display version information and exit"))
 124   (newline)
 125   (show-bug-report-information))
 126
 127 (define %options
 128   ;; Specifications of the command-line options.
 129   (cons* (option '(#\C "channels") #t #f
 130                  (lambda (opt name arg result)
 131                    (alist-cons 'channel-file arg result)))
 132          (option '(#\l "list-generations") #f #t
 133                  (lambda (opt name arg result)
 134                    (cons `(query list-generations ,arg)
 135                          result)))
 136          (option '("roll-back") #f #f
 137                  (lambda (opt name arg result)
 138                    (cons '(generation roll-back)
 139                          result)))
 140          (option '(#\S "switch-generation") #t #f
 141                  (lambda (opt name arg result)
 142                    (cons `(generation switch ,arg)
 143                          result)))
 144          (option '(#\d "delete-generations") #f #t
 145                  (lambda (opt name arg result)
 146                    (cons `(generation delete ,arg)
 147                          result)))
 148          (option '(#\N "news") #f #f
 149                  (lambda (opt name arg result)
 150                    (cons '(query display-news) result)))
 151          (option '("url") #t #f
 152                  (lambda (opt name arg result)
 153                    (alist-cons 'repository-url arg
 154                                (alist-delete 'repository-url result))))
 155          (option '("commit") #t #f
 156                  (lambda (opt name arg result)
 157                    (alist-cons 'ref `(commit . ,arg) result)))
 158          (option '("branch") #t #f
 159                  (lambda (opt name arg result)
 160                    (alist-cons 'ref `(branch . ,arg) result)))
 161          (option '(#\p "profile") #t #f
 162                  (lambda (opt name arg result)
 163                    (alist-cons 'profile (canonicalize-profile arg)
 164                                result)))
 165          (option '(#\s "system") #t #f
 166                  (lambda (opt name arg result)
 167                    (alist-cons 'system arg
 168                                (alist-delete 'system result eq?))))
 169          (option '(#\n "dry-run") #f #f
 170                  (lambda (opt name arg result)
 171                    (alist-cons 'dry-run? #t result)))
 172          (option '(#\v "verbosity") #t #f
 173                  (lambda (opt name arg result)
 174                    (let ((level (string->number* arg)))
 175                      (alist-cons 'verbosity level
 176                                  (alist-delete 'verbosity result)))))
 177          (option '("bootstrap") #f #f
 178                  (lambda (opt name arg result)
 179                    (alist-cons 'bootstrap? #t result)))
 180
 181          (option '(#\h "help") #f #f
 182                  (lambda args
 183                    (show-help)
 184                    (exit 0)))
 185          (option '(#\V "version") #f #f
 186                  (lambda args
 187                    (show-version-and-exit "guix pull")))
 188
 189          %standard-build-options))
 190
 191 (define* (display-profile-news profile #:key concise?
 192                                current-is-newer?)
 193   "Display what's up in PROFILE--new packages, and all that.  If
 194 CURRENT-IS-NEWER? is true, assume that the current process represents the
 195 newest generation of PROFILE.  Return true when there's more info to display."
 196   (match (memv (generation-number profile)
 197                (reverse (profile-generations profile)))
 198     ((current previous _ ...)
 199      (let ((these (fold-available-packages
 200                    (lambda* (name version result
 201                                   #:key supported? deprecated?
 202                                   #:allow-other-keys)
 203                      (if (and supported? (not deprecated?))
 204                          (alist-cons name version result)
 205                          result))
 206                    '()))
 207            (those (profile-package-alist
 208                    (generation-file-name profile
 209                                          (if current-is-newer?
 210                                              previous
 211                                              current)))))
 212        (let ((old (if current-is-newer? those these))
 213              (new (if current-is-newer? these those)))
 214          (display-new/upgraded-packages old new
 215                                         #:concise? concise?
 216                                         #:heading
 217                                         (G_ "New in this revision:\n")))))
 218     (_ #f)))
 219
 220 (define (display-channel channel)
 221   "Display information about CHANNEL."
 222   (format (current-error-port)
 223           ;; TRANSLATORS: This describes a "channel"; the first placeholder is
 224           ;; the channel name (e.g., "guix") and the second placeholder is its
 225           ;; URL.
 226           (G_ "    ~a at ~a~%")
 227           (channel-name channel)
 228           (channel-url channel)))
 229
 230 (define (channel=? channel1 channel2)
 231   "Return true if CHANNEL1 and CHANNEL2 are the same for all practical
 232 purposes."
 233   ;; Assume that the URL matters less than the name.
 234   (eq? (channel-name channel1) (channel-name channel2)))
 235
 236 (define (display-news-entry-title entry language port)
 237   "Display the title of ENTRY, a news entry, to PORT."
 238   (define title
 239     (channel-news-entry-title entry))
 240
 241   (let ((title (or (assoc-ref title language)
 242                    (assoc-ref title (%default-message-language))
 243                    "")))
 244     (format port "  ~a~%"
 245             (highlight
 246              (string-trim-right
 247               (catch 'parser-error
 248                 (lambda ()
 249                   (texi->plain-text title))
 250
 251                 ;; When Texinfo markup is invalid, display it as-is.
 252                 (const title)))))))
 253
 254 (define (display-news-entry entry channel language port)
 255   "Display ENTRY, a <channel-news-entry> from CHANNEL, in LANGUAGE, a language
 256 code, to PORT."
 257   (define body
 258     (channel-news-entry-body entry))
 259
 260   (define commit
 261     (channel-news-entry-commit entry))
 262
 263   (display-news-entry-title entry language port)
 264   (format port (dim (G_ "    commit ~a~%"))
 265           (if (supports-hyperlinks?)
 266               (channel-commit-hyperlink channel commit)
 267               commit))
 268   (newline port)
 269   (let ((body (or (assoc-ref body language)
 270                   (assoc-ref body (%default-message-language))
 271                   "")))
 272     (format port "~a~%"
 273             (indented-string
 274              (parameterize ((%text-width (- (%text-width) 4)))
 275                (string-trim-right
 276                 (catch 'parser-error
 277                   (lambda ()
 278                     (texi->plain-text body))
 279                   (lambda _
 280                     ;; When Texinfo markup is invalid, display it as-is.
 281                     (fill-paragraph body (%text-width))))))
 282              4))))
 283
 284 (define* (display-channel-specific-news new old
 285                                         #:key (port (current-output-port))
 286                                         concise?)
 287   "Display channel news applicable the commits between OLD and NEW, where OLD
 288 and NEW are <channel> records with a proper 'commit' field.  When CONCISE? is
 289 true, display nothing but the news titles.  Return true if there are more news
 290 to display."
 291   (let ((channel new)
 292         (old     (channel-commit old))
 293         (new     (channel-commit new)))
 294     (when (and old new)
 295       (let ((language (current-message-language)))
 296         (match (channel-news-for-commit channel new old)
 297           (()                                     ;no news is good news
 298            #f)
 299           ((entries ...)
 300            (newline port)
 301            (format port (G_ "News for channel '~a'~%")
 302                    (channel-name channel))
 303            (for-each (if concise?
 304                          (cut display-news-entry-title <> language port)
 305                          (cut display-news-entry <> channel language port))
 306                      entries)
 307            (newline port)
 308            #t))))))
 309
 310 (define* (display-channel-news profile
 311                                #:optional
 312                                (previous
 313                                 (and=> (relative-generation profile -1)
 314                                        (cut generation-file-name profile <>))))
 315   "Display news about the channels of PROFILE compared to PREVIOUS."
 316   (when previous
 317     (let ((old-channels (profile-channels previous))
 318           (new-channels (profile-channels profile)))
 319       (and (pair? old-channels) (pair? new-channels)
 320            (begin
 321              (match (lset-difference channel=? new-channels old-channels)
 322                (()
 323                 #t)
 324                (new
 325                 (let ((count (length new)))
 326                   (format (current-error-port)
 327                           (N_ "  ~a new channel:~%"
 328                               "  ~a new channels:~%" count)
 329                           count)
 330                   (for-each display-channel new))))
 331              (match (lset-difference channel=? old-channels new-channels)
 332                (()
 333                 #t)
 334                (removed
 335                 (let ((count (length removed)))
 336                   (format (current-error-port)
 337                           (N_ "  ~a channel removed:~%"
 338                               "  ~a channels removed:~%" count)
 339                           count)
 340                   (for-each display-channel removed))))
 341
 342              ;; Display channel-specific news for those channels that were
 343              ;; here before and are still around afterwards.
 344              (for-each (match-lambda
 345                          ((new old)
 346                           (display-channel-specific-news new old)))
 347                        (filter-map (lambda (new)
 348                                      (define old
 349                                        (find (cut channel=? new <>)
 350                                              old-channels))
 351
 352                                      (and old (list new old)))
 353                                    new-channels)))))))
 354
 355 (define* (display-channel-news-headlines profile)
 356   "Display the titles of news about the channels of PROFILE compared to its
 357 previous generation.  Return true if there are news to display."
 358   (define previous
 359     (and=> (relative-generation profile -1)
 360            (cut generation-file-name profile <>)))
 361
 362   (when previous
 363     (let ((old-channels (profile-channels previous))
 364           (new-channels (profile-channels profile)))
 365       ;; Find the channels present in both PROFILE and PREVIOUS, and print
 366       ;; their news.
 367       (and (pair? old-channels) (pair? new-channels)
 368            (let ((channels (filter-map (lambda (new)
 369                                          (define old
 370                                            (find (cut channel=? new <>)
 371                                                  old-channels))
 372
 373                                          (and old (list new old)))
 374                                        new-channels)))
 375              (define more?
 376                (map (match-lambda
 377                       ((new old)
 378                        (display-channel-specific-news new old
 379                                                       #:concise? #t)))
 380                     channels))
 381
 382              (any ->bool more?))))))
 383
 384 (define (display-news profile)
 385   ;; Display profile news, with the understanding that this process represents
 386   ;; the newest generation.
 387   (display-profile-news profile
 388                         #:current-is-newer? #t)
 389
 390   (display-channel-news profile))
 391
 392 (define* (build-and-install instances profile)
 393   "Build the tool from SOURCE, and install it in PROFILE.  When DRY-RUN? is
 394 true, display what would be built without actually building it."
 395   (define update-profile
 396     (store-lift build-and-use-profile))
 397
 398   (define guix-command
 399     ;; The 'guix' command before we've built the new profile.
 400     (which "guix"))
 401
 402   (mlet %store-monad ((manifest (channel-instances->manifest instances)))
 403     (mbegin %store-monad
 404       (update-profile profile manifest
 405                       #:hooks %channel-profile-hooks)
 406
 407       (return
 408        (let ((more? (list (display-profile-news profile #:concise? #t)
 409                           (display-channel-news-headlines profile))))
 410          (newline)
 411          (when (any ->bool more?)
 412            (display-hint
 413             (G_ "Run @command{guix pull --news} to read all the news.")))))
 414       (if guix-command
 415           (let ((new (map (cut string-append <> "/bin/guix")
 416                           (list (user-friendly-profile profile)
 417                                 profile))))
 418             ;; Is the 'guix' command previously in $PATH the same as the new
 419             ;; one?  If the answer is "no", then suggest 'hash guix'.
 420             (unless (member guix-command new)
 421               (display-hint (format #f (G_ "After setting @code{PATH}, run
 422 @command{hash guix} to make sure your shell refers to @file{~a}.")
 423                                     (first new))))
 424             (return #f))
 425           (return #f)))))
 426
 427 (define (honor-lets-encrypt-certificates! store)
 428   "Tell Guile-Git to use the Let's Encrypt certificates."
 429   (let* ((drv   (package-derivation store le-certs))
 430          (certs (string-append (derivation->output-path drv)
 431                                "/etc/ssl/certs")))
 432     (build-derivations store (list drv))
 433     (set-tls-certificate-locations! certs)))
 434
 435 (define (honor-x509-certificates store)
 436   "Use the right X.509 certificates for Git checkouts over HTTPS."
 437   (unless (honor-system-x509-certificates!)
 438     (honor-lets-encrypt-certificates! store)))
 439
 440 (define (report-git-error error)
 441   "Report the given Guile-Git error."
 442   ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
 443   ;; errors would be represented by integers.
 444   (match error
 445     ((? integer? error)                           ;old Guile-Git
 446      (leave (G_ "Git error ~a~%") error))
 447     ((? git-error? error)                         ;new Guile-Git
 448      (leave (G_ "Git error: ~a~%") (git-error-message error)))))
 449
 450 (define-syntax-rule (with-git-error-handling body ...)
 451   (catch 'git-error
 452     (lambda ()
 453       body ...)
 454     (lambda (key err)
 455       (report-git-error err))))
 456
 457 \f
 458 ;;;
 459 ;;; Profile.
 460 ;;;
 461
 462 (define %current-profile
 463   ;; The "real" profile under /var/guix.
 464   (string-append %profile-directory "/current-guix"))
 465
 466 (define %user-profile-directory
 467   ;; The user-friendly name of %CURRENT-PROFILE.
 468   (string-append (config-directory #:ensure? #f) "/current"))
 469
 470 (define (migrate-generations profile directory)
 471   "Migrate the generations of PROFILE to DIRECTORY."
 472   (format (current-error-port)
 473           (G_ "Migrating profile generations to '~a'...~%")
 474           %profile-directory)
 475   (let ((current (generation-number profile)))
 476     (for-each (lambda (generation)
 477                 (let ((source (generation-file-name profile generation))
 478                       (target (string-append directory "/current-guix-"
 479                                              (number->string generation)
 480                                              "-link")))
 481                   ;; Note: Don't use 'rename-file' as SOURCE and TARGET might
 482                   ;; live on different file systems.
 483                   (symlink (readlink source) target)
 484                   (delete-file source)))
 485               (profile-generations profile))
 486     (symlink (string-append "current-guix-"
 487                             (number->string current) "-link")
 488              (string-append directory "/current-guix"))))
 489
 490 (define (ensure-default-profile)
 491   (ensure-profile-directory)
 492
 493   ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks.  Move
 494   ;; them to %PROFILE-DIRECTORY.
 495   ;;
 496   ;; XXX: Ubuntu's 'sudo' preserves $HOME by default, and thus the second
 497   ;; condition below is always false when one runs "sudo guix pull".  As a
 498   ;; workaround, skip this code when $SUDO_USER is set.  See
 499   ;; <https://bugs.gnu.org/36785>.
 500   (unless (or (getenv "SUDO_USER")
 501               (string=? %profile-directory
 502                         (dirname
 503                          (canonicalize-profile %user-profile-directory))))
 504     (migrate-generations %user-profile-directory %profile-directory))
 505
 506   ;; Make sure ~/.config/guix/current points to /var/guix/profiles/….
 507   (let ((link %user-profile-directory))
 508     (unless (equal? (false-if-exception (readlink link))
 509                     %current-profile)
 510       (catch 'system-error
 511         (lambda ()
 512           (false-if-exception (delete-file link))
 513           (symlink %current-profile link))
 514         (lambda args
 515           (leave (G_ "while creating symlink '~a': ~a~%")
 516                  link (strerror (system-error-errno args))))))))
 517
 518 \f
 519 ;;;
 520 ;;; Queries.
 521 ;;;
 522
 523 (define profile-package-alist
 524   (mlambda (profile)
 525     "Return a name/version alist representing the packages in PROFILE."
 526     (let* ((inferior (open-inferior profile))
 527            (packages (inferior-available-packages inferior)))
 528       (close-inferior inferior)
 529       packages)))
 530
 531 (define (new/upgraded-packages alist1 alist2)
 532   "Compare ALIST1 and ALIST2, both of which are lists of package name/version
 533 pairs, and return two values: the list of packages new in ALIST2, and the list
 534 of packages upgraded in ALIST2."
 535   (let* ((old      (fold (match-lambda*
 536                            (((name . version) table)
 537                             (match (vhash-assoc name table)
 538                               (#f
 539                                (vhash-cons name version table))
 540                               ((_ . previous-version)
 541                                (if (version>? version previous-version)
 542                                    (vhash-cons name version table)
 543                                    table)))))
 544                          vlist-null
 545                          alist1))
 546          (new      (remove (match-lambda
 547                              ((name . _)
 548                               (vhash-assoc name old)))
 549                            alist2))
 550          (upgraded (filter-map (match-lambda
 551                                  ((name . new-version)
 552                                   (match (vhash-assoc name old)
 553                                     (#f #f)
 554                                     ((_ . old-version)
 555                                      (and (version>? new-version old-version)
 556                                           (string-append name "@"
 557                                                          new-version))))))
 558                                alist2)))
 559     (values new upgraded)))
 560
 561 (define* (ellipsis #:optional (port (current-output-port)))
 562   "Return HORIZONTAL ELLIPSIS three dots if PORT's encoding cannot represent
 563 it."
 564   (match (port-encoding port)
 565     ("UTF-8" "…")
 566     (_       "...")))
 567
 568 (define* (display-new/upgraded-packages alist1 alist2
 569                                         #:key (heading "") concise?)
 570   "Given the two package name/version alists ALIST1 and ALIST2, display the
 571 list of new and upgraded packages going from ALIST1 to ALIST2.  When ALIST1
 572 and ALIST2 differ, display HEADING upfront.  When CONCISE? is true, do not
 573 display long package lists that would fill the user's screen.
 574
 575 Return true when there is more package info to display."
 576   (define (pretty str column)
 577     (indented-string (fill-paragraph str (- (%text-width) 4)
 578                                      column)
 579                      4 #:initial-indent? #f))
 580
 581   (define concise/max-item-count
 582     ;; Maximum number of items to display when CONCISE? is true.
 583     12)
 584
 585   (define list->enumeration
 586     (if concise?
 587         (lambda* (lst #:optional (max concise/max-item-count))
 588           (if (> (length lst) max)
 589               (string-append (string-join (take lst max) ", ")
 590                              ", " (ellipsis))
 591               (string-join lst ", ")))
 592         (cut string-join <> ", ")))
 593
 594   (let-values (((new upgraded) (new/upgraded-packages alist1 alist2)))
 595     (define new-count (length new))
 596     (define upgraded-count (length upgraded))
 597
 598     (unless (and (null? new) (null? upgraded))
 599       (display heading))
 600
 601     (match new-count
 602       (0 #t)
 603       (count
 604        (format #t (N_ "  ~h new package: ~a~%"
 605                       "  ~h new packages: ~a~%" count)
 606                count
 607                (pretty (list->enumeration (sort (map first new) string<?))
 608                        30))))
 609     (match upgraded-count
 610       (0 #t)
 611       (count
 612        (format #t (N_ "  ~h package upgraded: ~a~%"
 613                       "  ~h packages upgraded: ~a~%" count)
 614                count
 615                (pretty (list->enumeration (sort upgraded string<?))
 616                        35))))
 617
 618     (and concise?
 619          (or (> new-count concise/max-item-count)
 620              (> upgraded-count concise/max-item-count)))))
 621
 622 (define (display-profile-content-diff profile gen1 gen2)
 623   "Display the changes in PROFILE GEN2 compared to generation GEN1."
 624   (define (package-alist generation)
 625     (profile-package-alist (generation-file-name profile generation)))
 626
 627   (display-profile-content profile gen2)
 628   (display-new/upgraded-packages (package-alist gen1)
 629                                  (package-alist gen2)))
 630
 631 (define (process-query opts profile)
 632   "Process any query on PROFILE specified by OPTS."
 633   (match (assoc-ref opts 'query)
 634     (('list-generations pattern)
 635      (define (list-generations profile numbers)
 636        (match numbers
 637          ((first rest ...)
 638           (display-profile-content profile first)
 639           (let loop ((numbers numbers))
 640             (match numbers
 641               ((first second rest ...)
 642                (display-profile-content-diff profile
 643                                              first second)
 644                (display-channel-news (generation-file-name profile second)
 645                                      (generation-file-name profile first))
 646                (loop (cons second rest)))
 647               ((_) #t)
 648               (()  #t))))))
 649
 650      (leave-on-EPIPE
 651       (cond ((not (file-exists? profile))         ; XXX: race condition
 652              (raise (condition (&profile-not-found-error
 653                                 (profile profile)))))
 654             ((not pattern)
 655              (list-generations profile (profile-generations profile)))
 656             ((matching-generations pattern profile)
 657              =>
 658              (match-lambda
 659                (()
 660                 (exit 1))
 661                ((numbers ...)
 662                 (list-generations profile numbers)))))))
 663     (('display-news)
 664      (display-news profile))))
 665
 666 (define (process-generation-change opts profile)
 667   "Process a request to change the current generation (roll-back, switch, delete)."
 668   (unless (assoc-ref opts 'dry-run?)
 669     (match (assoc-ref opts 'generation)
 670       (('roll-back)
 671        (with-store store
 672          (roll-back* store profile)))
 673       (('switch pattern)
 674        (let ((number (relative-generation-spec->number profile pattern)))
 675          (if number
 676              (switch-to-generation* profile number)
 677              (leave (G_ "cannot switch to generation '~a'~%") pattern))))
 678       (('delete pattern)
 679        (with-store store
 680          (delete-matching-generations store profile pattern))))))
 681
 682 (define (channel-list opts)
 683   "Return the list of channels to use.  If OPTS specify a channel file,
 684 channels are read from there; otherwise, if ~/.config/guix/channels.scm
 685 exists, read it; otherwise %DEFAULT-CHANNELS is used.  Apply channel
 686 transformations specified in OPTS (resulting from '--url', '--commit', or
 687 '--branch'), if any."
 688   (define file
 689     (assoc-ref opts 'channel-file))
 690
 691   (define default-file
 692     (string-append (config-directory) "/channels.scm"))
 693
 694   (define global-file
 695     (string-append %sysconfdir "/guix/channels.scm"))
 696
 697   (define (load-channels file)
 698     (let ((result (load* file (make-user-module '((guix channels))))))
 699       (if (and (list? result) (every channel? result))
 700           result
 701           (leave (G_ "'~a' did not return a list of channels~%") file))))
 702
 703   (define channels
 704     (cond (file
 705            (load-channels file))
 706           ((file-exists? default-file)
 707            (load-channels default-file))
 708           ((file-exists? global-file)
 709            (load-channels global-file))
 710           (else
 711            %default-channels)))
 712
 713   (define (environment-variable)
 714     (match (getenv "GUIX_PULL_URL")
 715       (#f #f)
 716       (url
 717        (warning (G_ "The 'GUIX_PULL_URL' environment variable is deprecated.
 718 Use '~/.config/guix/channels.scm' instead."))
 719        url)))
 720
 721   (let ((ref (assoc-ref opts 'ref))
 722         (url (or (assoc-ref opts 'repository-url)
 723                  (environment-variable))))
 724     (if (or ref url)
 725         (match (find guix-channel? channels)
 726           ((? channel? guix)
 727            ;; Apply '--url', '--commit', and '--branch' to the 'guix' channel.
 728            (let ((url (or url (channel-url guix))))
 729              (cons (match ref
 730                      (('commit . commit)
 731                       (channel (inherit guix)
 732                                (url url) (commit commit) (branch #f)))
 733                      (('branch . branch)
 734                       (channel (inherit guix)
 735                                (url url) (commit #f) (branch branch)))
 736                      (#f
 737                       (channel (inherit guix) (url url))))
 738                    (remove guix-channel? channels))))
 739           (#f                           ;no 'guix' channel, failure will ensue
 740            channels))
 741         channels)))
 742
 743 \f
 744 (define (guix-pull . args)
 745   (with-error-handling
 746     (with-git-error-handling
 747      (let* ((opts         (parse-command-line args %options
 748                                               (list %default-options)))
 749             (substitutes? (assoc-ref opts 'substitutes?))
 750             (dry-run?     (assoc-ref opts 'dry-run?))
 751             (channels     (channel-list opts))
 752             (profile      (or (assoc-ref opts 'profile) %current-profile)))
 753        (cond ((assoc-ref opts 'query)
 754               (process-query opts profile))
 755              ((assoc-ref opts 'generation)
 756               (process-generation-change opts profile))
 757              (else
 758               (with-store store
 759                 (with-status-verbosity (assoc-ref opts 'verbosity)
 760                   (parameterize ((%current-system (assoc-ref opts 'system))
 761                                  (%graft? (assoc-ref opts 'graft?)))
 762                     (with-build-handler (build-notifier #:use-substitutes?
 763                                                         substitutes?
 764                                                         #:dry-run? dry-run?)
 765                       (set-build-options-from-command-line store opts)
 766                       (ensure-default-profile)
 767                       (honor-x509-certificates store)
 768
 769                       (let ((instances (latest-channel-instances store channels)))
 770                         (format (current-error-port)
 771                                 (N_ "Building from this channel:~%"
 772                                     "Building from these channels:~%"
 773                                     (length instances)))
 774                         (for-each (lambda (instance)
 775                                     (let ((channel
 776                                            (channel-instance-channel instance)))
 777                                       (format (current-error-port)
 778                                               "  ~10a~a\t~a~%"
 779                                               (channel-name channel)
 780                                               (channel-url channel)
 781                                               (string-take
 782                                                (channel-instance-commit instance)
 783                                                7))))
 784                                   instances)
 785                         (parameterize ((%guile-for-build
 786                                         (package-derivation
 787                                          store
 788                                          (if (assoc-ref opts 'bootstrap?)
 789                                              %bootstrap-guile
 790                                              (default-guile)))))
 791                           (with-profile-lock profile
 792                             (run-with-store store
 793                               (build-and-install instances profile)))))))))))))))
 794
 795 ;;; pull.scm ends here