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 utils)
  23   #:use-module ((guix status) #:select (with-status-verbosity))
  24   #:use-module (guix scripts)
  25   #:use-module (guix store)
  26   #:use-module (guix config)
  27   #:use-module (guix packages)
  28   #:use-module (guix derivations)
  29   #:use-module (guix profiles)
  30   #:use-module (guix gexp)
  31   #:use-module (guix grafts)
  32   #:use-module (guix memoization)
  33   #:use-module (guix monads)
  34   #:use-module (guix channels)
  35   #:autoload   (guix inferior) (open-inferior)
  36   #:use-module (guix scripts build)
  37   #:autoload   (guix build utils) (which)
  38   #:use-module (guix git)
  39   #:use-module (git)
  40   #:use-module (gnu packages)
  41   #:use-module ((guix scripts package) #:select (build-and-use-profile))
  42   #:use-module ((gnu packages base) #:select (canonical-package))
  43   #:use-module (gnu packages guile)
  44   #:use-module ((gnu packages bootstrap)
  45                 #:select (%bootstrap-guile))
  46   #:use-module ((gnu packages certs) #:select (le-certs))
  47   #:use-module (srfi srfi-1)
  48   #:use-module (srfi srfi-11)
  49   #:use-module (srfi srfi-26)
  50   #:use-module (srfi srfi-34)
  51   #:use-module (srfi srfi-35)
  52   #:use-module (srfi srfi-37)
  53   #:use-module (ice-9 match)
  54   #:use-module (ice-9 vlist)
  55   #:export (display-profile-content
  56             guix-pull))
  57
  58 \f
  59 ;;;
  60 ;;; Command-line options.
  61 ;;;
  62
  63 (define %default-options
  64   ;; Alist of default option values.
  65   `((system . ,(%current-system))
  66     (substitutes? . #t)
  67     (build-hook? . #t)
  68     (print-build-trace? . #t)
  69     (print-extended-build-trace? . #t)
  70     (multiplexed-build-output? . #t)
  71     (graft? . #t)
  72     (debug . 0)
  73     (verbosity . 1)))
  74
  75 (define (show-help)
  76   (display (G_ "Usage: guix pull [OPTION]...
  77 Download and deploy the latest version of Guix.\n"))
  78   (display (G_ "
  79       --verbose          produce verbose output"))
  80   (display (G_ "
  81   -C, --channels=FILE    deploy the channels defined in FILE"))
  82   (display (G_ "
  83       --url=URL          download from the Git repository at URL"))
  84   (display (G_ "
  85       --commit=COMMIT    download the specified COMMIT"))
  86   (display (G_ "
  87       --branch=BRANCH    download the tip of the specified BRANCH"))
  88   (display (G_ "
  89   -N, --news             display news compared to the previous generation"))
  90   (display (G_ "
  91   -l, --list-generations[=PATTERN]
  92                          list generations matching PATTERN"))
  93   (display (G_ "
  94   -p, --profile=PROFILE  use PROFILE instead of ~/.config/guix/current"))
  95   (display (G_ "
  96   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  97   (display (G_ "
  98   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
  99   (display (G_ "
 100       --bootstrap        use the bootstrap Guile to build the new Guix"))
 101   (newline)
 102   (show-build-options-help)
 103   (display (G_ "
 104   -h, --help             display this help and exit"))
 105   (display (G_ "
 106   -V, --version          display version information and exit"))
 107   (newline)
 108   (show-bug-report-information))
 109
 110 (define %options
 111   ;; Specifications of the command-line options.
 112   (cons* (option '("verbose") #f #f
 113                  (lambda (opt name arg result)
 114                    (alist-cons 'verbose? #t result)))
 115          (option '(#\C "channels") #t #f
 116                  (lambda (opt name arg result)
 117                    (alist-cons 'channel-file arg result)))
 118          (option '(#\l "list-generations") #f #t
 119                  (lambda (opt name arg result)
 120                    (cons `(query list-generations ,arg)
 121                          result)))
 122          (option '(#\N "news") #f #f
 123                  (lambda (opt name arg result)
 124                    (cons '(query display-news) result)))
 125          (option '("url") #t #f
 126                  (lambda (opt name arg result)
 127                    (alist-cons 'repository-url arg
 128                                (alist-delete 'repository-url result))))
 129          (option '("commit") #t #f
 130                  (lambda (opt name arg result)
 131                    (alist-cons 'ref `(commit . ,arg) result)))
 132          (option '("branch") #t #f
 133                  (lambda (opt name arg result)
 134                    (alist-cons 'ref `(branch . ,arg) result)))
 135          (option '(#\p "profile") #t #f
 136                  (lambda (opt name arg result)
 137                    (alist-cons 'profile (canonicalize-profile arg)
 138                                result)))
 139          (option '(#\s "system") #t #f
 140                  (lambda (opt name arg result)
 141                    (alist-cons 'system arg
 142                                (alist-delete 'system result eq?))))
 143          (option '(#\n "dry-run") #f #f
 144                  (lambda (opt name arg result)
 145                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
 146          (option '(#\v "verbosity") #t #f
 147                  (lambda (opt name arg result)
 148                    (let ((level (string->number* arg)))
 149                      (alist-cons 'verbosity level
 150                                  (alist-delete 'verbosity result)))))
 151          (option '("bootstrap") #f #f
 152                  (lambda (opt name arg result)
 153                    (alist-cons 'bootstrap? #t result)))
 154
 155          (option '(#\h "help") #f #f
 156                  (lambda args
 157                    (show-help)
 158                    (exit 0)))
 159          (option '(#\V "version") #f #f
 160                  (lambda args
 161                    (show-version-and-exit "guix pull")))
 162
 163          %standard-build-options))
 164
 165 (define what-to-build
 166   (store-lift show-what-to-build))
 167 (define indirect-root-added
 168   (store-lift add-indirect-root))
 169
 170 (define* (display-profile-news profile #:key concise?
 171                                current-is-newer?)
 172   "Display what's up in PROFILE--new packages, and all that.  If
 173 CURRENT-IS-NEWER? is true, assume that the current process represents the
 174 newest generation of PROFILE.x"
 175   (match (memv (generation-number profile)
 176                (reverse (profile-generations profile)))
 177     ((current previous _ ...)
 178      (let ((these (fold-available-packages
 179                    (lambda* (name version result
 180                                   #:key supported? deprecated?
 181                                   #:allow-other-keys)
 182                      (if (and supported? (not deprecated?))
 183                          (alist-cons name version result)
 184                          result))
 185                    '()))
 186            (those (profile-package-alist
 187                    (generation-file-name profile
 188                                          (if current-is-newer?
 189                                              previous
 190                                              current)))))
 191        (let ((old (if current-is-newer? those these))
 192              (new (if current-is-newer? these those)))
 193          (display-new/upgraded-packages old new
 194                                         #:concise? concise?
 195                                         #:heading
 196                                         (G_ "New in this revision:\n")))))
 197     (_ #t)))
 198
 199 (define* (build-and-install instances profile
 200                             #:key verbose? dry-run?)
 201   "Build the tool from SOURCE, and install it in PROFILE.  When DRY-RUN? is
 202 true, display what would be built without actually building it."
 203   (define update-profile
 204     (store-lift build-and-use-profile))
 205
 206   (define guix-command
 207     ;; The 'guix' command before we've built the new profile.
 208     (which "guix"))
 209
 210   (mlet %store-monad ((manifest (channel-instances->manifest instances)))
 211     (mbegin %store-monad
 212       (update-profile profile manifest
 213                       #:hooks %channel-profile-hooks
 214                       #:dry-run? dry-run?)
 215       (munless dry-run?
 216         (return (newline))
 217         (return (display-profile-news profile #:concise? #t))
 218         (if guix-command
 219             (let ((new (map (cut string-append <> "/bin/guix")
 220                             (list (user-friendly-profile profile)
 221                                   profile))))
 222               ;; Is the 'guix' command previously in $PATH the same as the new
 223               ;; one?  If the answer is "no", then suggest 'hash guix'.
 224               (unless (member guix-command new)
 225                 (display-hint (format #f (G_ "After setting @code{PATH}, run
 226 @command{hash guix} to make sure your shell refers to @file{~a}.")
 227                                       (first new))))
 228               (return #f))
 229             (return #f))))))
 230
 231 (define (honor-lets-encrypt-certificates! store)
 232   "Tell Guile-Git to use the Let's Encrypt certificates."
 233   (let* ((drv   (package-derivation store le-certs))
 234          (certs (string-append (derivation->output-path drv)
 235                                "/etc/ssl/certs")))
 236     (build-derivations store (list drv))
 237     (set-tls-certificate-locations! certs)))
 238
 239 (define (honor-x509-certificates store)
 240   "Use the right X.509 certificates for Git checkouts over HTTPS."
 241   (unless (honor-system-x509-certificates!)
 242     (honor-lets-encrypt-certificates! store)))
 243
 244 (define (report-git-error error)
 245   "Report the given Guile-Git error."
 246   ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
 247   ;; errors would be represented by integers.
 248   (match error
 249     ((? integer? error)                           ;old Guile-Git
 250      (leave (G_ "Git error ~a~%") error))
 251     ((? git-error? error)                         ;new Guile-Git
 252      (leave (G_ "Git error: ~a~%") (git-error-message error)))))
 253
 254 (define-syntax-rule (with-git-error-handling body ...)
 255   (catch 'git-error
 256     (lambda ()
 257       body ...)
 258     (lambda (key err)
 259       (report-git-error err))))
 260
 261 \f
 262 ;;;
 263 ;;; Profile.
 264 ;;;
 265
 266 (define %current-profile
 267   ;; The "real" profile under /var/guix.
 268   (string-append %profile-directory "/current-guix"))
 269
 270 (define %user-profile-directory
 271   ;; The user-friendly name of %CURRENT-PROFILE.
 272   (string-append (config-directory #:ensure? #f) "/current"))
 273
 274 (define (migrate-generations profile directory)
 275   "Migrate the generations of PROFILE to DIRECTORY."
 276   (format (current-error-port)
 277           (G_ "Migrating profile generations to '~a'...~%")
 278           %profile-directory)
 279   (let ((current (generation-number profile)))
 280     (for-each (lambda (generation)
 281                 (let ((source (generation-file-name profile generation))
 282                       (target (string-append directory "/current-guix-"
 283                                              (number->string generation)
 284                                              "-link")))
 285                   ;; Note: Don't use 'rename-file' as SOURCE and TARGET might
 286                   ;; live on different file systems.
 287                   (symlink (readlink source) target)
 288                   (delete-file source)))
 289               (profile-generations profile))
 290     (symlink (string-append "current-guix-"
 291                             (number->string current) "-link")
 292              (string-append directory "/current-guix"))))
 293
 294 (define (ensure-default-profile)
 295   (ensure-profile-directory)
 296
 297   ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks.  Move
 298   ;; them to %PROFILE-DIRECTORY.
 299   (unless (string=? %profile-directory
 300                     (dirname (canonicalize-profile %user-profile-directory)))
 301     (migrate-generations %user-profile-directory %profile-directory))
 302
 303   ;; Make sure ~/.config/guix/current points to /var/guix/profiles/….
 304   (let ((link %user-profile-directory))
 305     (unless (equal? (false-if-exception (readlink link))
 306                     %current-profile)
 307       (catch 'system-error
 308         (lambda ()
 309           (false-if-exception (delete-file link))
 310           (symlink %current-profile link))
 311         (lambda args
 312           (leave (G_ "while creating symlink '~a': ~a~%")
 313                  link (strerror (system-error-errno args))))))))
 314
 315 \f
 316 ;;;
 317 ;;; Queries.
 318 ;;;
 319
 320 (define (display-profile-content profile number)
 321   "Display the packages in PROFILE, generation NUMBER, in a human-readable
 322 way and displaying details about the channel's source code."
 323   (display-generation profile number)
 324   (for-each (lambda (entry)
 325               (format #t "  ~a ~a~%"
 326                       (manifest-entry-name entry)
 327                       (manifest-entry-version entry))
 328               (match (assq 'source (manifest-entry-properties entry))
 329                 (('source ('repository ('version 0)
 330                                        ('url url)
 331                                        ('branch branch)
 332                                        ('commit commit)
 333                                        _ ...))
 334                  (format #t (G_ "    repository URL: ~a~%") url)
 335                  (when branch
 336                    (format #t (G_ "    branch: ~a~%") branch))
 337                  (format #t (G_ "    commit: ~a~%") commit))
 338                 (_ #f)))
 339
 340             ;; Show most recently installed packages last.
 341             (reverse
 342              (manifest-entries
 343               (profile-manifest (if (zero? number)
 344                                     profile
 345                                     (generation-file-name profile number)))))))
 346
 347 (define (indented-string str indent)
 348   "Return STR with each newline preceded by IDENT spaces."
 349   (define indent-string
 350     (make-list indent #\space))
 351
 352   (list->string
 353    (string-fold-right (lambda (chr result)
 354                         (if (eqv? chr #\newline)
 355                             (cons chr (append indent-string result))
 356                             (cons chr result)))
 357                       '()
 358                       str)))
 359
 360 (define profile-package-alist
 361   (mlambda (profile)
 362     "Return a name/version alist representing the packages in PROFILE."
 363     (let* ((inferior (open-inferior profile))
 364            (packages (inferior-available-packages inferior)))
 365       (close-inferior inferior)
 366       packages)))
 367
 368 (define (new/upgraded-packages alist1 alist2)
 369   "Compare ALIST1 and ALIST2, both of which are lists of package name/version
 370 pairs, and return two values: the list of packages new in ALIST2, and the list
 371 of packages upgraded in ALIST2."
 372   (let* ((old      (fold (match-lambda*
 373                            (((name . version) table)
 374                             (match (vhash-assoc name table)
 375                               (#f
 376                                (vhash-cons name version table))
 377                               ((_ . previous-version)
 378                                (if (version>? version previous-version)
 379                                    (vhash-cons name version table)
 380                                    table)))))
 381                          vlist-null
 382                          alist1))
 383          (new      (remove (match-lambda
 384                              ((name . _)
 385                               (vhash-assoc name old)))
 386                            alist2))
 387          (upgraded (filter-map (match-lambda
 388                                  ((name . new-version)
 389                                   (match (vhash-assoc name old)
 390                                     (#f #f)
 391                                     ((_ . old-version)
 392                                      (and (version>? new-version old-version)
 393                                           (string-append name "@"
 394                                                          new-version))))))
 395                                alist2)))
 396     (values new upgraded)))
 397
 398 (define* (ellipsis #:optional (port (current-output-port)))
 399   "Return HORIZONTAL ELLIPSIS three dots if PORT's encoding cannot represent
 400 it."
 401   (match (port-encoding port)
 402     ("UTF-8" "…")
 403     (_       "...")))
 404
 405 (define* (display-new/upgraded-packages alist1 alist2
 406                                         #:key (heading "") concise?)
 407   "Given the two package name/version alists ALIST1 and ALIST2, display the
 408 list of new and upgraded packages going from ALIST1 to ALIST2.  When ALIST1
 409 and ALIST2 differ, display HEADING upfront.  When CONCISE? is true, do not
 410 display long package lists that would fill the user's screen."
 411   (define (pretty str column)
 412     (indented-string (fill-paragraph str (- (%text-width) 4)
 413                                      column)
 414                      4))
 415
 416   (define concise/max-item-count
 417     ;; Maximum number of items to display when CONCISE? is true.
 418     12)
 419
 420   (define list->enumeration
 421     (if concise?
 422         (lambda* (lst #:optional (max concise/max-item-count))
 423           (if (> (length lst) max)
 424               (string-append (string-join (take lst max) ", ")
 425                              ", " (ellipsis))
 426               (string-join lst ", ")))
 427         (cut string-join <> ", ")))
 428
 429   (let-values (((new upgraded) (new/upgraded-packages alist1 alist2)))
 430     (define new-count (length new))
 431     (define upgraded-count (length upgraded))
 432
 433     (unless (and (null? new) (null? upgraded))
 434       (display heading))
 435
 436     (match new-count
 437       (0 #t)
 438       (count
 439        (format #t (N_ "  ~h new package: ~a~%"
 440                       "  ~h new packages: ~a~%" count)
 441                count
 442                (pretty (list->enumeration (sort (map first new) string<?))
 443                        30))))
 444     (match upgraded-count
 445       (0 #t)
 446       (count
 447        (format #t (N_ "  ~h package upgraded: ~a~%"
 448                       "  ~h packages upgraded: ~a~%" count)
 449                count
 450                (pretty (list->enumeration (sort upgraded string<?))
 451                        35))))
 452
 453     (when (and concise?
 454                (or (> new-count concise/max-item-count)
 455                    (> upgraded-count concise/max-item-count)))
 456       (display-hint (G_ "Run @command{guix pull --news} to view the complete
 457 list of package changes.")))))
 458
 459 (define (display-profile-content-diff profile gen1 gen2)
 460   "Display the changes in PROFILE GEN2 compared to generation GEN1."
 461   (define (package-alist generation)
 462     (profile-package-alist (generation-file-name profile generation)))
 463
 464   (display-profile-content profile gen2)
 465   (display-new/upgraded-packages (package-alist gen1)
 466                                  (package-alist gen2)))
 467
 468 (define (process-query opts profile)
 469   "Process any query on PROFILE specified by OPTS."
 470   (match (assoc-ref opts 'query)
 471     (('list-generations pattern)
 472      (define (list-generations profile numbers)
 473        (match numbers
 474          ((first rest ...)
 475           (display-profile-content profile first)
 476           (let loop ((numbers numbers))
 477             (match numbers
 478               ((first second rest ...)
 479                (display-profile-content-diff profile
 480                                              first second)
 481                (loop (cons second rest)))
 482               ((_) #t)
 483               (()  #t))))))
 484
 485      (leave-on-EPIPE
 486       (cond ((not (file-exists? profile))         ; XXX: race condition
 487              (raise (condition (&profile-not-found-error
 488                                 (profile profile)))))
 489             ((not pattern)
 490              (list-generations profile (profile-generations profile)))
 491             ((matching-generations pattern profile)
 492              =>
 493              (match-lambda
 494                (()
 495                 (exit 1))
 496                ((numbers ...)
 497                 (list-generations profile numbers)))))))
 498     (('display-news)
 499      ;; Display profile news, with the understanding that this process
 500      ;; represents the newest generation.
 501      (display-profile-news profile
 502                            #:current-is-newer? #t))))
 503
 504 (define (channel-list opts)
 505   "Return the list of channels to use.  If OPTS specify a channel file,
 506 channels are read from there; otherwise, if ~/.config/guix/channels.scm
 507 exists, read it; otherwise %DEFAULT-CHANNELS is used.  Apply channel
 508 transformations specified in OPTS (resulting from '--url', '--commit', or
 509 '--branch'), if any."
 510   (define file
 511     (assoc-ref opts 'channel-file))
 512
 513   (define default-file
 514     (string-append (config-directory) "/channels.scm"))
 515
 516   (define (load-channels file)
 517     (let ((result (load* file (make-user-module '((guix channels))))))
 518       (if (and (list? result) (every channel? result))
 519           result
 520           (leave (G_ "'~a' did not return a list of channels~%") file))))
 521
 522   (define channels
 523     (cond (file
 524            (load-channels file))
 525           ((file-exists? default-file)
 526            (load-channels default-file))
 527           (else
 528            %default-channels)))
 529
 530   (define (environment-variable)
 531     (match (getenv "GUIX_PULL_URL")
 532       (#f #f)
 533       (url
 534        (warning (G_ "The 'GUIX_PULL_URL' environment variable is deprecated.
 535 Use '~/.config/guix/channels.scm' instead."))
 536        url)))
 537
 538   (let ((ref (assoc-ref opts 'ref))
 539         (url (or (assoc-ref opts 'repository-url)
 540                  (environment-variable))))
 541     (if (or ref url)
 542         (match (find guix-channel? channels)
 543           ((? channel? guix)
 544            ;; Apply '--url', '--commit', and '--branch' to the 'guix' channel.
 545            (let ((url (or url (channel-url guix))))
 546              (cons (match ref
 547                      (('commit . commit)
 548                       (channel (inherit guix)
 549                                (url url) (commit commit) (branch #f)))
 550                      (('branch . branch)
 551                       (channel (inherit guix)
 552                                (url url) (commit #f) (branch branch)))
 553                      (#f
 554                       (channel (inherit guix) (url url))))
 555                    (remove guix-channel? channels))))
 556           (#f                           ;no 'guix' channel, failure will ensue
 557            channels))
 558         channels)))
 559
 560 \f
 561 (define (guix-pull . args)
 562   (with-error-handling
 563     (with-git-error-handling
 564      (let* ((opts     (parse-command-line args %options
 565                                           (list %default-options)))
 566             (cache    (string-append (cache-directory) "/pull"))
 567             (channels (channel-list opts))
 568             (profile  (or (assoc-ref opts 'profile) %current-profile)))
 569        (cond ((assoc-ref opts 'query)
 570               (process-query opts profile))
 571              (else
 572               (with-store store
 573                 (ensure-default-profile)
 574                 (with-status-verbosity (assoc-ref opts 'verbosity)
 575                   (parameterize ((%current-system (assoc-ref opts 'system))
 576                                  (%graft? (assoc-ref opts 'graft?))
 577                                  (%repository-cache-directory cache))
 578                     (set-build-options-from-command-line store opts)
 579                     (honor-x509-certificates store)
 580
 581                     (let ((instances (latest-channel-instances store channels)))
 582                       (format (current-error-port)
 583                               (N_ "Building from this channel:~%"
 584                                   "Building from these channels:~%"
 585                                   (length instances)))
 586                       (for-each (lambda (instance)
 587                                   (let ((channel
 588                                          (channel-instance-channel instance)))
 589                                     (format (current-error-port)
 590                                             "  ~10a~a\t~a~%"
 591                                             (channel-name channel)
 592                                             (channel-url channel)
 593                                             (string-take
 594                                              (channel-instance-commit instance)
 595                                              7))))
 596                                 instances)
 597                       (parameterize ((%guile-for-build
 598                                       (package-derivation
 599                                        store
 600                                        (if (assoc-ref opts 'bootstrap?)
 601                                            %bootstrap-guile
 602                                            (canonical-package guile-2.2)))))
 603                         (run-with-store store
 604                           (build-and-install instances profile
 605                                              #:dry-run?
 606                                              (assoc-ref opts 'dry-run?)
 607                                              #:verbose?
 608                                              (assoc-ref opts 'verbose?))))))))))))))
 609
 610 ;;; pull.scm ends here