guix/scripts/pull.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2017, 2018 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 scripts)
  24   #:use-module (guix store)
  25   #:use-module (guix config)
  26   #:use-module (guix packages)
  27   #:use-module (guix derivations)
  28   #:use-module (guix profiles)
  29   #:use-module (guix gexp)
  30   #:use-module (guix grafts)
  31   #:use-module (guix memoization)
  32   #:use-module (guix monads)
  33   #:use-module (guix channels)
  34   #:autoload   (guix inferior) (open-inferior)
  35   #:use-module (guix scripts build)
  36   #:use-module (guix git)
  37   #:use-module (git)
  38   #:use-module (gnu packages)
  39   #:use-module ((guix scripts package) #:select (build-and-use-profile))
  40   #:use-module (gnu packages base)
  41   #:use-module (gnu packages guile)
  42   #:use-module ((gnu packages bootstrap)
  43                 #:select (%bootstrap-guile))
  44   #:use-module ((gnu packages certs) #:select (le-certs))
  45   #:use-module (srfi srfi-1)
  46   #:use-module (srfi srfi-26)
  47   #:use-module (srfi srfi-35)
  48   #:use-module (srfi srfi-37)
  49   #:use-module (ice-9 match)
  50   #:use-module (ice-9 vlist)
  51   #:export (display-profile-content
  52             guix-pull))
  53
  54 \f
  55 ;;;
  56 ;;; Command-line options.
  57 ;;;
  58
  59 (define %default-options
  60   ;; Alist of default option values.
  61   `((system . ,(%current-system))
  62     (substitutes? . #t)
  63     (build-hook? . #t)
  64     (graft? . #t)
  65     (verbosity . 0)))
  66
  67 (define (show-help)
  68   (display (G_ "Usage: guix pull [OPTION]...
  69 Download and deploy the latest version of Guix.\n"))
  70   (display (G_ "
  71       --verbose          produce verbose output"))
  72   (display (G_ "
  73   -C, --channels=FILE    deploy the channels defined in FILE"))
  74   (display (G_ "
  75       --url=URL          download from the Git repository at URL"))
  76   (display (G_ "
  77       --commit=COMMIT    download the specified COMMIT"))
  78   (display (G_ "
  79       --branch=BRANCH    download the tip of the specified BRANCH"))
  80   (display (G_ "
  81   -l, --list-generations[=PATTERN]
  82                          list generations matching PATTERN"))
  83   (display (G_ "
  84   -p, --profile=PROFILE  use PROFILE instead of ~/.config/guix/current"))
  85   (display (G_ "
  86       --bootstrap        use the bootstrap Guile to build the new Guix"))
  87   (newline)
  88   (show-build-options-help)
  89   (display (G_ "
  90   -h, --help             display this help and exit"))
  91   (display (G_ "
  92   -V, --version          display version information and exit"))
  93   (newline)
  94   (show-bug-report-information))
  95
  96 (define %options
  97   ;; Specifications of the command-line options.
  98   (cons* (option '("verbose") #f #f
  99                  (lambda (opt name arg result)
 100                    (alist-cons 'verbose? #t result)))
 101          (option '(#\C "channels") #t #f
 102                  (lambda (opt name arg result)
 103                    (alist-cons 'channel-file arg result)))
 104          (option '(#\l "list-generations") #f #t
 105                  (lambda (opt name arg result)
 106                    (cons `(query list-generations ,(or arg ""))
 107                          result)))
 108          (option '("url") #t #f
 109                  (lambda (opt name arg result)
 110                    (alist-cons 'repository-url arg
 111                                (alist-delete 'repository-url result))))
 112          (option '("commit") #t #f
 113                  (lambda (opt name arg result)
 114                    (alist-cons 'ref `(commit . ,arg) result)))
 115          (option '("branch") #t #f
 116                  (lambda (opt name arg result)
 117                    (alist-cons 'ref `(branch . ,(string-append "origin/" arg))
 118                                result)))
 119          (option '(#\p "profile") #t #f
 120                  (lambda (opt name arg result)
 121                    (alist-cons 'profile (canonicalize-profile arg)
 122                                result)))
 123          (option '(#\n "dry-run") #f #f
 124                  (lambda (opt name arg result)
 125                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
 126          (option '("bootstrap") #f #f
 127                  (lambda (opt name arg result)
 128                    (alist-cons 'bootstrap? #t result)))
 129
 130          (option '(#\h "help") #f #f
 131                  (lambda args
 132                    (show-help)
 133                    (exit 0)))
 134          (option '(#\V "version") #f #f
 135                  (lambda args
 136                    (show-version-and-exit "guix pull")))
 137
 138          %standard-build-options))
 139
 140 (define what-to-build
 141   (store-lift show-what-to-build))
 142 (define indirect-root-added
 143   (store-lift add-indirect-root))
 144
 145 (define (display-profile-news profile)
 146   "Display what's up in PROFILE--new packages, and all that."
 147   (match (memv (generation-number profile)
 148                (reverse (profile-generations profile)))
 149     ((current previous _ ...)
 150      (newline)
 151      (let ((old (fold-packages (lambda (package result)
 152                                  (alist-cons (package-name package)
 153                                              (package-version package)
 154                                              result))
 155                                '()))
 156            (new (profile-package-alist
 157                  (generation-file-name profile current))))
 158        (display-new/upgraded-packages old new
 159                                       #:heading (G_ "New in this revision:\n"))))
 160     (_ #t)))
 161
 162 (define* (build-and-install instances profile
 163                             #:key verbose?)
 164   "Build the tool from SOURCE, and install it in PROFILE."
 165   (define update-profile
 166     (store-lift build-and-use-profile))
 167
 168   (mlet %store-monad ((manifest (channel-instances->manifest instances)))
 169     (mbegin %store-monad
 170       (update-profile profile manifest)
 171       (return (display-profile-news profile)))))
 172
 173 (define (honor-lets-encrypt-certificates! store)
 174   "Tell Guile-Git to use the Let's Encrypt certificates."
 175   (let* ((drv   (package-derivation store le-certs))
 176          (certs (string-append (derivation->output-path drv)
 177                                "/etc/ssl/certs")))
 178     (build-derivations store (list drv))
 179
 180     ;; In the past Guile-Git would not provide this procedure.
 181     (if (module-defined? (resolve-interface '(git))
 182                          'set-tls-certificate-locations!)
 183         (set-tls-certificate-locations! certs)
 184         (begin
 185           ;; In this case we end up using whichever certificates OpenSSL
 186           ;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs.
 187           (warning (G_ "cannot enforce use of the Let's Encrypt \
 188 certificates~%"))
 189           (warning (G_ "please upgrade Guile-Git~%"))))))
 190
 191 (define (report-git-error error)
 192   "Report the given Guile-Git error."
 193   ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
 194   ;; errors would be represented by integers.
 195   (match error
 196     ((? integer? error)                           ;old Guile-Git
 197      (leave (G_ "Git error ~a~%") error))
 198     ((? git-error? error)                         ;new Guile-Git
 199      (leave (G_ "Git error: ~a~%") (git-error-message error)))))
 200
 201 (define-syntax-rule (with-git-error-handling body ...)
 202   (catch 'git-error
 203     (lambda ()
 204       body ...)
 205     (lambda (key err)
 206       (report-git-error err))))
 207
 208 \f
 209 ;;;
 210 ;;; Queries.
 211 ;;;
 212
 213 (define (display-profile-content profile number)
 214   "Display the packages in PROFILE, generation NUMBER, in a human-readable
 215 way and displaying details about the channel's source code."
 216   (display-generation profile number)
 217   (for-each (lambda (entry)
 218               (format #t "  ~a ~a~%"
 219                       (manifest-entry-name entry)
 220                       (manifest-entry-version entry))
 221               (match (assq 'source (manifest-entry-properties entry))
 222                 (('source ('repository ('version 0)
 223                                        ('url url)
 224                                        ('branch branch)
 225                                        ('commit commit)
 226                                        _ ...))
 227                  (format #t (G_ "    repository URL: ~a~%") url)
 228                  (when branch
 229                    (format #t (G_ "    branch: ~a~%") branch))
 230                  (format #t (G_ "    commit: ~a~%") commit))
 231                 (_ #f)))
 232
 233             ;; Show most recently installed packages last.
 234             (reverse
 235              (manifest-entries
 236               (profile-manifest (generation-file-name profile number))))))
 237
 238 (define (indented-string str indent)
 239   "Return STR with each newline preceded by IDENT spaces."
 240   (define indent-string
 241     (make-list indent #\space))
 242
 243   (list->string
 244    (string-fold-right (lambda (chr result)
 245                         (if (eqv? chr #\newline)
 246                             (cons chr (append indent-string result))
 247                             (cons chr result)))
 248                       '()
 249                       str)))
 250
 251 (define profile-package-alist
 252   (mlambda (profile)
 253     "Return a name/version alist representing the packages in PROFILE."
 254     (fold (lambda (package lst)
 255             (alist-cons (inferior-package-name package)
 256                         (inferior-package-version package)
 257                         lst))
 258           '()
 259           (let* ((inferior (open-inferior profile))
 260                  (packages (inferior-packages inferior)))
 261             (close-inferior inferior)
 262             packages))))
 263
 264 (define* (display-new/upgraded-packages alist1 alist2
 265                                         #:key (heading ""))
 266   "Given the two package name/version alists ALIST1 and ALIST2, display the
 267 list of new and upgraded packages going from ALIST1 to ALIST2.  When ALIST1
 268 and ALIST2 differ, display HEADING upfront."
 269   (let* ((old      (fold (match-lambda*
 270                            (((name . version) table)
 271                             (vhash-cons name version table)))
 272                          vlist-null
 273                          alist1))
 274          (new      (remove (match-lambda
 275                              ((name . _)
 276                               (vhash-assoc name old)))
 277                            alist2))
 278          (upgraded (filter-map (match-lambda
 279                                  ((name . new-version)
 280                                   (match (vhash-fold* cons '() name old)
 281                                     (() #f)
 282                                     ((= (cut sort <> version>?) old-versions)
 283                                      (and (version>? new-version
 284                                                      (first old-versions))
 285                                           (string-append name "@"
 286                                                          new-version))))))
 287                                alist2)))
 288     (unless (and (null? new) (null? upgraded))
 289       (display heading))
 290
 291     (match (length new)
 292       (0 #t)
 293       (count
 294        (format #t (N_ "  ~h new package: ~a~%"
 295                       "  ~h new packages: ~a~%" count)
 296                count
 297                (indented-string
 298                 (fill-paragraph (string-join (sort (map first new) string<?)
 299                                              ", ")
 300                                 (- (%text-width) 4) 30)
 301                 4))))
 302     (match (length upgraded)
 303       (0 #t)
 304       (count
 305        (format #t (N_ "  ~h package upgraded: ~a~%"
 306                       "  ~h packages upgraded: ~a~%" count)
 307                count
 308                (indented-string
 309                 (fill-paragraph (string-join (sort upgraded string<?) ", ")
 310                                 (- (%text-width) 4) 35)
 311                 4))))))
 312
 313 (define (display-profile-content-diff profile gen1 gen2)
 314   "Display the changes in PROFILE GEN2 compared to generation GEN1."
 315   (define (package-alist generation)
 316     (profile-package-alist (generation-file-name profile generation)))
 317
 318   (display-profile-content profile gen2)
 319   (display-new/upgraded-packages (package-alist gen1)
 320                                  (package-alist gen2)))
 321
 322 (define (process-query opts)
 323   "Process any query specified by OPTS."
 324   (define profile
 325     (string-append (config-directory) "/current"))
 326
 327   (match (assoc-ref opts 'query)
 328     (('list-generations pattern)
 329      (define (list-generations profile numbers)
 330        (match numbers
 331          ((first rest ...)
 332           (display-profile-content profile first)
 333           (let loop ((numbers numbers))
 334             (match numbers
 335               ((first second rest ...)
 336                (display-profile-content-diff profile
 337                                              first second)
 338                (loop (cons second rest)))
 339               ((_) #t)
 340               (()  #t))))))
 341
 342      (leave-on-EPIPE
 343       (cond ((not (file-exists? profile))         ; XXX: race condition
 344              (raise (condition (&profile-not-found-error
 345                                 (profile profile)))))
 346             ((string-null? pattern)
 347              (list-generations profile (profile-generations profile)))
 348             ((matching-generations pattern profile)
 349              =>
 350              (match-lambda
 351                (()
 352                 (exit 1))
 353                ((numbers ...)
 354                 (list-generations profile numbers)))))))))
 355
 356 (define (channel-list opts)
 357   "Return the list of channels to use.  If OPTS specify a channel file,
 358 channels are read from there; otherwise, if ~/.config/guix/channels.scm
 359 exists, read it; otherwise %DEFAULT-CHANNELS is used.  Apply channel
 360 transformations specified in OPTS (resulting from '--url', '--commit', or
 361 '--branch'), if any."
 362   (define file
 363     (assoc-ref opts 'channel-file))
 364
 365   (define default-file
 366     (string-append (config-directory) "/channels.scm"))
 367
 368   (define (load-channels file)
 369     (let ((result (load* file (make-user-module '((guix channels))))))
 370       (if (and (list? result) (every channel? result))
 371           result
 372           (leave (G_ "'~a' did not return a list of channels~%") file))))
 373
 374   (define channels
 375     (cond (file
 376            (load-channels file))
 377           ((file-exists? default-file)
 378            (load-channels default-file))
 379           (else
 380            %default-channels)))
 381
 382   (define (environment-variable)
 383     (match (getenv "GUIX_PULL_URL")
 384       (#f #f)
 385       (url
 386        (warning (G_ "The 'GUIX_PULL_URL' environment variable is deprecated.
 387 Use '~/.config/guix/channels.scm' instead."))
 388        url)))
 389
 390   (let ((ref (assoc-ref opts 'ref))
 391         (url (or (assoc-ref opts 'repository-url)
 392                  (environment-variable))))
 393     (if (or ref url)
 394         (match channels
 395           ((one)
 396            ;; When there's only one channel, apply '--url', '--commit', and
 397            ;; '--branch' to this specific channel.
 398            (let ((url (or url (channel-url one))))
 399              (list (match ref
 400                      (('commit . commit)
 401                       (channel (inherit one)
 402                                (url url) (commit commit) (branch #f)))
 403                      (('branch . branch)
 404                       (channel (inherit one)
 405                                (url url) (commit #f) (branch branch)))
 406                      (#f
 407                       (channel (inherit one) (url url)))))))
 408           (_
 409            ;; Otherwise bail out.
 410            (leave
 411             (G_ "'--url', '--commit', and '--branch' are not applicable~%"))))
 412         channels)))
 413
 414 \f
 415 (define (guix-pull . args)
 416   (with-error-handling
 417     (with-git-error-handling
 418      (let* ((opts     (parse-command-line args %options
 419                                           (list %default-options)))
 420             (cache    (string-append (cache-directory) "/pull"))
 421             (channels (channel-list opts))
 422             (profile  (or (assoc-ref opts 'profile)
 423                           (string-append (config-directory) "/current"))))
 424
 425        (cond ((assoc-ref opts 'query)
 426               (process-query opts))
 427              ((assoc-ref opts 'dry-run?)
 428               #t)                                 ;XXX: not very useful
 429              (else
 430               (with-store store
 431                 (parameterize ((%graft? (assoc-ref opts 'graft?))
 432                                (%repository-cache-directory cache))
 433                   (set-build-options-from-command-line store opts)
 434
 435                   ;; When certificates are already installed, use them.
 436                   ;; Otherwise, use the Let's Encrypt certificates, which we
 437                   ;; know Savannah uses.
 438                   (let ((certs (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
 439                     (unless (file-exists? certs)
 440                       (honor-lets-encrypt-certificates! store)))
 441
 442                   (let ((instances (latest-channel-instances store channels)))
 443                     (format (current-error-port)
 444                             (N_ "Building from this channel:~%"
 445                                 "Building from these channels:~%"
 446                                 (length instances)))
 447                     (for-each (lambda (instance)
 448                                 (let ((channel
 449                                        (channel-instance-channel instance)))
 450                                   (format (current-error-port)
 451                                           "  ~10a~a\t~a~%"
 452                                           (channel-name channel)
 453                                           (channel-url channel)
 454                                           (string-take
 455                                            (channel-instance-commit instance)
 456                                            7))))
 457                               instances)
 458                     (parameterize ((%guile-for-build
 459                                     (package-derivation
 460                                      store
 461                                      (if (assoc-ref opts 'bootstrap?)
 462                                          %bootstrap-guile
 463                                          (canonical-package guile-2.2)))))
 464                       (run-with-store store
 465                         (build-and-install instances profile
 466                                            #:verbose?
 467                                            (assoc-ref opts 'verbose?)))))))))))))
 468
 469 ;;; pull.scm ends here