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