;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts pull)
- #:use-module (guix ui)
+ #:use-module ((guix ui) #:hide (display-profile-content))
#:use-module (guix colors)
#:use-module (guix utils)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix memoization)
#:use-module (guix monads)
#:use-module (guix channels)
- #:autoload (guix inferior) (open-inferior)
+ #:autoload (guix inferior) (open-inferior
+ inferior-available-packages
+ close-inferior)
#:use-module (guix scripts build)
+ #:use-module (guix scripts describe)
#:autoload (guix build utils) (which)
+ #:use-module ((guix build syscalls)
+ #:select (with-file-lock/no-wait))
#:use-module (guix git)
#:use-module (git)
#:use-module (gnu packages)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 format)
- #:export (display-profile-content
+ #:re-export (display-profile-content
+ channel-commit-hyperlink)
+ #:export (channel-list
guix-pull))
\f
;; Alist of default option values.
`((system . ,(%current-system))
(substitutes? . #t)
- (build-hook? . #t)
+ (offload? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
(graft? . #t)
(debug . 0)
- (verbosity . 1)))
+ (verbosity . 1)
+ (authenticate-channels? . #t)
+ (validate-pull . ,ensure-forward-channel-update)))
(define (show-help)
(display (G_ "Usage: guix pull [OPTION]...
Download and deploy the latest version of Guix.\n"))
- (display (G_ "
- --verbose produce verbose output"))
(display (G_ "
-C, --channels=FILE deploy the channels defined in FILE"))
(display (G_ "
--commit=COMMIT download the specified COMMIT"))
(display (G_ "
--branch=BRANCH download the tip of the specified BRANCH"))
+ (display (G_ "
+ --allow-downgrades allow downgrades to earlier channel revisions"))
+ (display (G_ "
+ --disable-authentication
+ disable channel authentication"))
(display (G_ "
-N, --news display news compared to the previous generation"))
(display (G_ "
(define %options
;; Specifications of the command-line options.
- (cons* (option '("verbose") #f #f
- (lambda (opt name arg result)
- (alist-cons 'verbose? #t result)))
- (option '(#\C "channels") #t #f
+ (cons* (option '(#\C "channels") #t #f
(lambda (opt name arg result)
(alist-cons 'channel-file arg result)))
(option '(#\l "list-generations") #f #t
(option '("branch") #t #f
(lambda (opt name arg result)
(alist-cons 'ref `(branch . ,arg) result)))
+ (option '("allow-downgrades") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'validate-pull warn-about-backward-updates
+ result)))
+ (option '("disable-authentication") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'authenticate-channels? #f result)))
(option '(#\p "profile") #t #f
(lambda (opt name arg result)
(alist-cons 'profile (canonicalize-profile arg)
(alist-delete 'system result eq?))))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
(option '(#\v "verbosity") #t #f
(lambda (opt name arg result)
(let ((level (string->number* arg)))
%standard-build-options))
+(define (warn-about-backward-updates channel start commit relation)
+ "Warn about non-forward updates of CHANNEL from START to COMMIT, without
+aborting."
+ (match relation
+ ((or 'ancestor 'self)
+ #t)
+ ('descendant
+ (warning (G_ "rolling back channel '~a' from ~a to ~a~%")
+ (channel-name channel) start commit))
+ ('unrelated
+ (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
+ (channel-name channel) start commit))))
+
(define* (display-profile-news profile #:key concise?
current-is-newer?)
"Display what's up in PROFILE--new packages, and all that. If
(define title
(channel-news-entry-title entry))
- (format port " ~a~%"
- (highlight
- (string-trim-right
- (texi->plain-text (or (assoc-ref title language)
- (assoc-ref title (%default-message-language))
- ""))))))
+ (let ((title (or (assoc-ref title language)
+ (assoc-ref title (%default-message-language))
+ "")))
+ (format port " ~a~%"
+ (highlight
+ (string-trim-right
+ (catch 'parser-error
+ (lambda ()
+ (texi->plain-text title))
+
+ ;; When Texinfo markup is invalid, display it as-is.
+ (const title)))))))
-(define (display-news-entry entry language port)
- "Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to
-PORT."
+(define (display-news-entry entry channel language port)
+ "Display ENTRY, a <channel-news-entry> from CHANNEL, in LANGUAGE, a language
+code, to PORT."
(define body
(channel-news-entry-body entry))
+ (define commit
+ (channel-news-entry-commit entry))
+
(display-news-entry-title entry language port)
- (format port (G_ " commit ~a~%")
- (channel-news-entry-commit entry))
+ (format port (dim (G_ " commit ~a~%"))
+ (if (supports-hyperlinks?)
+ (channel-commit-hyperlink channel commit)
+ commit))
(newline port)
- (format port " ~a~%"
- (indented-string
- (parameterize ((%text-width (- (%text-width) 4)))
- (string-trim-right
- (texi->plain-text (or (assoc-ref body language)
- (assoc-ref body (%default-message-language))
- ""))))
- 4)))
+ (let ((body (or (assoc-ref body language)
+ (assoc-ref body (%default-message-language))
+ "")))
+ (format port "~a~%"
+ (indented-string
+ (parameterize ((%text-width (- (%text-width) 4)))
+ (string-trim-right
+ (catch 'parser-error
+ (lambda ()
+ (texi->plain-text body))
+ (lambda _
+ ;; When Texinfo markup is invalid, display it as-is.
+ (fill-paragraph body (%text-width))))))
+ 4))))
(define* (display-channel-specific-news new old
#:key (port (current-output-port))
(channel-name channel))
(for-each (if concise?
(cut display-news-entry-title <> language port)
- (cut display-news-entry <> language port))
+ (cut display-news-entry <> channel language port))
entries)
(newline port)
#t))))))
(new
(let ((count (length new)))
(format (current-error-port)
- (N_ " ~*One new channel:~%"
+ (N_ " ~a new channel:~%"
" ~a new channels:~%" count)
count)
(for-each display-channel new))))
(removed
(let ((count (length removed)))
(format (current-error-port)
- (N_ " ~*One channel removed:~%"
+ (N_ " ~a channel removed:~%"
" ~a channels removed:~%" count)
count)
(for-each display-channel removed))))
(display-channel-news profile))
-(define* (build-and-install instances profile
- #:key use-substitutes? verbose? dry-run?)
+(define* (build-and-install instances profile)
"Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is
true, display what would be built without actually building it."
(define update-profile
(mlet %store-monad ((manifest (channel-instances->manifest instances)))
(mbegin %store-monad
(update-profile profile manifest
- #:use-substitutes? use-substitutes?
- #:hooks %channel-profile-hooks
- #:dry-run? dry-run?)
- (munless dry-run?
- (return (newline))
- (return
- (let ((more? (list (display-profile-news profile #:concise? #t)
- (display-channel-news-headlines profile))))
- (when (any ->bool more?)
- (display-hint
- (G_ "Run @command{guix pull --news} to read all the news.")))))
- (if guix-command
- (let ((new (map (cut string-append <> "/bin/guix")
- (list (user-friendly-profile profile)
- profile))))
- ;; Is the 'guix' command previously in $PATH the same as the new
- ;; one? If the answer is "no", then suggest 'hash guix'.
- (unless (member guix-command new)
- (display-hint (format #f (G_ "After setting @code{PATH}, run
+ #:hooks %channel-profile-hooks)
+
+ (return
+ (let ((more? (list (display-profile-news profile #:concise? #t)
+ (display-channel-news-headlines profile))))
+ (newline)
+ (when (any ->bool more?)
+ (display-hint
+ (G_ "Run @command{guix pull --news} to read all the news.")))))
+ (if guix-command
+ (let ((new (map (cut string-append <> "/bin/guix")
+ (list (user-friendly-profile profile)
+ profile))))
+ ;; Is the 'guix' command previously in $PATH the same as the new
+ ;; one? If the answer is "no", then suggest 'hash guix'.
+ (unless (member guix-command new)
+ (display-hint (format #f (G_ "After setting @code{PATH}, run
@command{hash guix} to make sure your shell refers to @file{~a}.")
- (first new))))
- (return #f))
- (return #f))))))
+ (first new))))
+ (return #f))
+ (return #f)))))
(define (honor-lets-encrypt-certificates! store)
"Tell Guile-Git to use the Let's Encrypt certificates."
(unless (honor-system-x509-certificates!)
(honor-lets-encrypt-certificates! store)))
-(define (report-git-error error)
- "Report the given Guile-Git error."
- ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
- ;; errors would be represented by integers.
- (match error
- ((? integer? error) ;old Guile-Git
- (leave (G_ "Git error ~a~%") error))
- ((? git-error? error) ;new Guile-Git
- (leave (G_ "Git error: ~a~%") (git-error-message error)))))
-
-(define-syntax-rule (with-git-error-handling body ...)
- (catch 'git-error
- (lambda ()
- body ...)
- (lambda (key err)
- (report-git-error err))))
-
\f
;;;
;;; Profile.
;; workaround, skip this code when $SUDO_USER is set. See
;; <https://bugs.gnu.org/36785>.
(unless (or (getenv "SUDO_USER")
+ (not (file-exists? %user-profile-directory))
(string=? %profile-directory
(dirname
(canonicalize-profile %user-profile-directory))))
;;; Queries.
;;;
-(define (display-profile-content profile number)
- "Display the packages in PROFILE, generation NUMBER, in a human-readable
-way and displaying details about the channel's source code."
- (display-generation profile number)
- (for-each (lambda (entry)
- (format #t " ~a ~a~%"
- (manifest-entry-name entry)
- (manifest-entry-version entry))
- (match (assq 'source (manifest-entry-properties entry))
- (('source ('repository ('version 0)
- ('url url)
- ('branch branch)
- ('commit commit)
- _ ...))
- (format #t (G_ " repository URL: ~a~%") url)
- (when branch
- (format #t (G_ " branch: ~a~%") branch))
- (format #t (G_ " commit: ~a~%") commit))
- (_ #f)))
-
- ;; Show most recently installed packages last.
- (reverse
- (manifest-entries
- (profile-manifest (if (zero? number)
- profile
- (generation-file-name profile number)))))))
-
-(define (indented-string str indent)
- "Return STR with each newline preceded by IDENT spaces."
- (define indent-string
- (make-list indent #\space))
-
- (list->string
- (string-fold-right (lambda (chr result)
- (if (eqv? chr #\newline)
- (cons chr (append indent-string result))
- (cons chr result)))
- '()
- str)))
-
(define profile-package-alist
(mlambda (profile)
"Return a name/version alist representing the packages in PROFILE."
(define (pretty str column)
(indented-string (fill-paragraph str (- (%text-width) 4)
column)
- 4))
+ 4 #:initial-indent? #f))
(define concise/max-item-count
;; Maximum number of items to display when CONCISE? is true.
(define default-file
(string-append (config-directory) "/channels.scm"))
+ (define global-file
+ (string-append %sysconfdir "/guix/channels.scm"))
+
(define (load-channels file)
(let ((result (load* file (make-user-module '((guix channels))))))
(if (and (list? result) (every channel? result))
(load-channels file))
((file-exists? default-file)
(load-channels default-file))
+ ((file-exists? global-file)
+ (load-channels global-file))
(else
%default-channels)))
channels)))
\f
-(define (guix-pull . args)
+(define-command (guix-pull . args)
+ (synopsis "pull the latest revision of Guix")
+
(with-error-handling
(with-git-error-handling
- (let* ((opts (parse-command-line args %options
- (list %default-options)))
- (channels (channel-list opts))
- (profile (or (assoc-ref opts 'profile) %current-profile)))
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)))
+ (substitutes? (assoc-ref opts 'substitutes?))
+ (dry-run? (assoc-ref opts 'dry-run?))
+ (channels (channel-list opts))
+ (profile (or (assoc-ref opts 'profile) %current-profile))
+ (current-channels (profile-channels profile))
+ (validate-pull (assoc-ref opts 'validate-pull))
+ (authenticate? (assoc-ref opts 'authenticate-channels?)))
(cond ((assoc-ref opts 'query)
(process-query opts profile))
((assoc-ref opts 'generation)
(process-generation-change opts profile))
(else
(with-store store
- (ensure-default-profile)
(with-status-verbosity (assoc-ref opts 'verbosity)
(parameterize ((%current-system (assoc-ref opts 'system))
(%graft? (assoc-ref opts 'graft?)))
- (set-build-options-from-command-line store opts)
- (honor-x509-certificates store)
-
- (let ((instances (latest-channel-instances store channels)))
- (format (current-error-port)
- (N_ "Building from this channel:~%"
- "Building from these channels:~%"
- (length instances)))
- (for-each (lambda (instance)
- (let ((channel
- (channel-instance-channel instance)))
- (format (current-error-port)
- " ~10a~a\t~a~%"
- (channel-name channel)
- (channel-url channel)
- (string-take
- (channel-instance-commit instance)
- 7))))
- instances)
- (parameterize ((%guile-for-build
- (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2)))))
- (run-with-store store
- (build-and-install instances profile
- #:dry-run?
- (assoc-ref opts 'dry-run?)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:verbose?
- (assoc-ref opts 'verbose?))))))))))))))
+ (with-build-handler (build-notifier #:use-substitutes?
+ substitutes?
+ #:verbosity
+ (assoc-ref opts 'verbosity)
+ #:dry-run? dry-run?)
+ (set-build-options-from-command-line store opts)
+ (ensure-default-profile)
+ (honor-x509-certificates store)
+
+ (let ((instances
+ (latest-channel-instances store channels
+ #:current-channels
+ current-channels
+ #:validate-pull
+ validate-pull
+ #:authenticate?
+ authenticate?)))
+ (format (current-error-port)
+ (N_ "Building from this channel:~%"
+ "Building from these channels:~%"
+ (length instances)))
+ (for-each (lambda (instance)
+ (let ((channel
+ (channel-instance-channel instance)))
+ (format (current-error-port)
+ " ~10a~a\t~a~%"
+ (channel-name channel)
+ (channel-url channel)
+ (string-take
+ (channel-instance-commit instance)
+ 7))))
+ instances)
+ (parameterize ((%guile-for-build
+ (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (default-guile)))))
+ (with-profile-lock profile
+ (run-with-store store
+ (build-and-install instances profile)))))))))))))))
;;; pull.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff