guix/scripts/pull.scm

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