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