diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/container/exec.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/deploy.scm | 47 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 242 | ||||
| -rw-r--r-- | guix/scripts/search.scm | 11 | ||||
| -rw-r--r-- | guix/scripts/show.scm | 76 |
6 files changed, 346 insertions, 41 deletions
diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index d598f5cac4..51b616b384 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -38,7 +38,7 @@ (define (show-help) (display (G_ "Usage: guix container exec PID COMMAND [ARGS...] -Execute COMMMAND within the container process PID.\n")) +Execute COMMAND within the container process PID.\n")) (newline) (display (G_ " -h, --help display this help and exit")) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index cf571756fd..f311587ec3 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -26,6 +26,7 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix grafts) + #:use-module (guix status) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) @@ -52,6 +53,8 @@ Perform the deployment specified by FILE.\n")) (display (G_ " -V, --version display version information and exit")) (newline) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (show-bug-report-information)) (define %options @@ -63,6 +66,12 @@ Perform the deployment specified by FILE.\n")) (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) + %standard-build-options)) (define %default-options @@ -87,25 +96,27 @@ Perform the deployment specified by FILE.\n")) (define (guix-deploy . args) (define (handle-argument arg result) (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) (file (assq-ref opts 'file)) (machines (or (and file (load-source-file file)) '()))) - (with-store store - (set-build-options-from-command-line store opts) - (for-each (lambda (machine) - (info (G_ "deploying to ~a...~%") - (machine-display-name machine)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (guard (c ((message-condition? c) - (report-error (G_ "failed to deploy ~a: ~a~%") - (machine-display-name machine) - (condition-message c))) - ((deploy-error? c) - (when (deploy-error-should-roll-back c) - (info (G_ "rolling back ~a...~%") - (machine-display-name machine)) - (run-with-store store (roll-back-machine machine))) - (apply throw (deploy-error-captured-args c)))) - (run-with-store store (deploy-machine machine))))) - machines)))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (for-each (lambda (machine) + (info (G_ "deploying to ~a...~%") + (machine-display-name machine)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (guard (c ((message-condition? c) + (report-error (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (condition-message c))) + ((deploy-error? c) + (when (deploy-error-should-roll-back c) + (info (G_ "rolling back ~a...~%") + (machine-display-name machine)) + (run-with-store store (roll-back-machine machine))) + (apply throw (deploy-error-captured-args c)))) + (run-with-store store (deploy-machine machine))))) + machines))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a43c96516f..f03741aa9e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -607,7 +607,11 @@ and upgrades." (let-values (((package output) (specification->package+output spec))) (package->manifest-entry* package output)))) - (_ #f)) + (('install . obj) + (leave (G_ "cannot install non-package object: ~s~%") + obj)) + (_ + #f)) opts)) (fold manifest-transaction-install-entry @@ -760,7 +764,8 @@ processed, #f otherwise." (('show requested-name) (let-values (((name version) (package-name->name+version requested-name))) - (match (find-packages-by-name name version) + (match (remove package-superseded + (find-packages-by-name name version)) (() (leave (G_ "~a~@[@~a~]: package not found~%") name version)) (packages diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 54bbaddf30..2b7b991b50 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -19,6 +19,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) + #:use-module (guix colors) #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix scripts) @@ -38,7 +39,8 @@ #:use-module (guix git) #:use-module (git) #:use-module (gnu packages) - #:use-module ((guix scripts package) #:select (build-and-use-profile)) + #:use-module ((guix scripts package) #:select (build-and-use-profile + delete-matching-generations)) #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) @@ -92,6 +94,14 @@ Download and deploy the latest version of Guix.\n")) -l, --list-generations[=PATTERN] list generations matching PATTERN")) (display (G_ " + --roll-back roll back to the previous generation")) + (display (G_ " + -d, --delete-generations[=PATTERN] + delete generations matching PATTERN")) + (display (G_ " + -S, --switch-generation=PATTERN + switch to a generation matching PATTERN")) + (display (G_ " -p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current")) (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) @@ -120,6 +130,18 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (cons `(query list-generations ,arg) result))) + (option '("roll-back") #f #f + (lambda (opt name arg result) + (cons '(generation roll-back) + result))) + (option '(#\S "switch-generation") #t #f + (lambda (opt name arg result) + (cons `(generation switch ,arg) + result))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result) + (cons `(generation delete ,arg) + result))) (option '(#\N "news") #f #f (lambda (opt name arg result) (cons '(query display-news) result))) @@ -167,7 +189,7 @@ Download and deploy the latest version of Guix.\n")) current-is-newer?) "Display what's up in PROFILE--new packages, and all that. If CURRENT-IS-NEWER? is true, assume that the current process represents the -newest generation of PROFILE." +newest generation of PROFILE. Return true when there's more info to display." (match (memv (generation-number profile) (reverse (profile-generations profile))) ((current previous _ ...) @@ -190,7 +212,162 @@ newest generation of PROFILE." #:concise? concise? #:heading (G_ "New in this revision:\n"))))) - (_ #t))) + (_ #f))) + +(define (display-channel channel) + "Display information about CHANNEL." + (format (current-error-port) + ;; TRANSLATORS: This describes a "channel"; the first placeholder is + ;; the channel name (e.g., "guix") and the second placeholder is its + ;; URL. + (G_ " ~a at ~a~%") + (channel-name channel) + (channel-url channel))) + +(define (channel=? channel1 channel2) + "Return true if CHANNEL1 and CHANNEL2 are the same for all practical +purposes." + ;; Assume that the URL matters less than the name. + (eq? (channel-name channel1) (channel-name channel2))) + +(define (display-news-entry-title entry language port) + "Display the title of ENTRY, a news entry, to PORT." + (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)) + "")))))) + +(define (display-news-entry entry language port) + "Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to +PORT." + (define body + (channel-news-entry-body entry)) + + (display-news-entry-title entry language port) + (format port (G_ " commit ~a~%") + (channel-news-entry-commit entry)) + (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))) + +(define* (display-channel-specific-news new old + #:key (port (current-output-port)) + concise?) + "Display channel news applicable the commits between OLD and NEW, where OLD +and NEW are <channel> records with a proper 'commit' field. When CONCISE? is +true, display nothing but the news titles. Return true if there are more news +to display." + (let ((channel new) + (old (channel-commit old)) + (new (channel-commit new))) + (when (and old new) + (let ((language (current-message-language))) + (match (channel-news-for-commit channel new old) + (() ;no news is good news + #f) + ((entries ...) + (newline port) + (format port (G_ "News for channel '~a'~%") + (channel-name channel)) + (for-each (if concise? + (cut display-news-entry-title <> language port) + (cut display-news-entry <> language port)) + entries) + (newline port) + #t)))))) + +(define* (display-channel-news profile + #:optional + (previous + (and=> (relative-generation profile -1) + (cut generation-file-name profile <>)))) + "Display news about the channels of PROFILE compared to PREVIOUS." + (when previous + (let ((old-channels (profile-channels previous)) + (new-channels (profile-channels profile))) + (and (pair? old-channels) (pair? new-channels) + (begin + (match (lset-difference channel=? new-channels old-channels) + (() + #t) + (new + (let ((count (length new))) + (format (current-error-port) + (N_ " ~*One new channel:~%" + " ~a new channels:~%" count) + count) + (for-each display-channel new)))) + (match (lset-difference channel=? old-channels new-channels) + (() + #t) + (removed + (let ((count (length removed))) + (format (current-error-port) + (N_ " ~*One channel removed:~%" + " ~a channels removed:~%" count) + count) + (for-each display-channel removed)))) + + ;; Display channel-specific news for those channels that were + ;; here before and are still around afterwards. + (for-each (match-lambda + ((new old) + (display-channel-specific-news new old))) + (filter-map (lambda (new) + (define old + (find (cut channel=? new <>) + old-channels)) + + (and old (list new old))) + new-channels))))))) + +(define* (display-channel-news-headlines profile) + "Display the titles of news about the channels of PROFILE compared to its +previous generation. Return true if there are news to display." + (define previous + (and=> (relative-generation profile -1) + (cut generation-file-name profile <>))) + + (when previous + (let ((old-channels (profile-channels previous)) + (new-channels (profile-channels profile))) + ;; Find the channels present in both PROFILE and PREVIOUS, and print + ;; their news. + (and (pair? old-channels) (pair? new-channels) + (let ((channels (filter-map (lambda (new) + (define old + (find (cut channel=? new <>) + old-channels)) + + (and old (list new old))) + new-channels))) + (define more? + (map (match-lambda + ((new old) + (display-channel-specific-news new old + #:concise? #t))) + channels)) + + (any ->bool more?)))))) + +(define (display-news profile) + ;; Display profile news, with the understanding that this process represents + ;; the newest generation. + (display-profile-news profile + #:current-is-newer? #t) + + (display-channel-news profile)) (define* (build-and-install instances profile #:key use-substitutes? verbose? dry-run?) @@ -211,7 +388,12 @@ true, display what would be built without actually building it." #:dry-run? dry-run?) (munless dry-run? (return (newline)) - (return (display-profile-news profile #:concise? #t)) + (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) @@ -293,8 +475,15 @@ true, display what would be built without actually building it." ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move ;; them to %PROFILE-DIRECTORY. - (unless (string=? %profile-directory - (dirname (canonicalize-profile %user-profile-directory))) + ;; + ;; XXX: Ubuntu's 'sudo' preserves $HOME by default, and thus the second + ;; condition below is always false when one runs "sudo guix pull". As a + ;; workaround, skip this code when $SUDO_USER is set. See + ;; <https://bugs.gnu.org/36785>. + (unless (or (getenv "SUDO_USER") + (string=? %profile-directory + (dirname + (canonicalize-profile %user-profile-directory)))) (migrate-generations %user-profile-directory %profile-directory)) ;; Make sure ~/.config/guix/current points to /var/guix/profiles/…. @@ -404,7 +593,9 @@ it." "Given the two package name/version alists ALIST1 and ALIST2, display the list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1 and ALIST2 differ, display HEADING upfront. When CONCISE? is true, do not -display long package lists that would fill the user's screen." +display long package lists that would fill the user's screen. + +Return true when there is more package info to display." (define (pretty str column) (indented-string (fill-paragraph str (- (%text-width) 4) column) @@ -447,11 +638,9 @@ display long package lists that would fill the user's screen." (pretty (list->enumeration (sort upgraded string<?)) 35)))) - (when (and concise? - (or (> new-count concise/max-item-count) - (> upgraded-count concise/max-item-count))) - (display-hint (G_ "Run @command{guix pull --news} to view the complete -list of package changes."))))) + (and concise? + (or (> new-count concise/max-item-count) + (> upgraded-count concise/max-item-count))))) (define (display-profile-content-diff profile gen1 gen2) "Display the changes in PROFILE GEN2 compared to generation GEN1." @@ -475,6 +664,8 @@ list of package changes."))))) ((first second rest ...) (display-profile-content-diff profile first second) + (display-channel-news (generation-file-name profile second) + (generation-file-name profile first)) (loop (cons second rest))) ((_) #t) (() #t)))))) @@ -493,10 +684,23 @@ list of package changes."))))) ((numbers ...) (list-generations profile numbers))))))) (('display-news) - ;; Display profile news, with the understanding that this process - ;; represents the newest generation. - (display-profile-news profile - #:current-is-newer? #t)))) + (display-news profile)))) + +(define (process-generation-change opts profile) + "Process a request to change the current generation (roll-back, switch, delete)." + (unless (assoc-ref opts 'dry-run?) + (match (assoc-ref opts 'generation) + (('roll-back) + (with-store store + (roll-back* store profile))) + (('switch pattern) + (let ((number (relative-generation-spec->number profile pattern))) + (if number + (switch-to-generation* profile number) + (leave (G_ "cannot switch to generation '~a'~%") pattern)))) + (('delete pattern) + (with-store store + (delete-matching-generations store profile pattern)))))) (define (channel-list opts) "Return the list of channels to use. If OPTS specify a channel file, @@ -560,18 +764,18 @@ Use '~/.config/guix/channels.scm' instead.")) (with-git-error-handling (let* ((opts (parse-command-line args %options (list %default-options))) - (cache (string-append (cache-directory) "/pull")) (channels (channel-list opts)) (profile (or (assoc-ref opts 'profile) %current-profile))) (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?)) - (%repository-cache-directory cache)) + (%graft? (assoc-ref opts 'graft?))) (set-build-options-from-command-line store opts) (honor-x509-certificates store) diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm index 8fceb83668..827b2eb7a9 100644 --- a/guix/scripts/search.scm +++ b/guix/scripts/search.scm @@ -19,6 +19,8 @@ (define-module (guix scripts search) #:use-module (guix ui) #:use-module (guix scripts package) + #:use-module ((guix scripts build) + #:select (%standard-build-options)) #:use-module (guix scripts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -36,6 +38,9 @@ This is an alias for 'guix package -s'.\n")) (display (G_ " -V, --version display version information and exit")) (newline) + (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (newline) (show-bug-report-information)) (define %options @@ -46,7 +51,11 @@ This is an alias for 'guix package -s'.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix search"))))) + (show-version-and-exit "guix search"))) + + (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options))) (define (guix-search . args) (define (handle-argument arg result) diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm new file mode 100644 index 0000000000..ef64b5755b --- /dev/null +++ b/guix/scripts/show.scm @@ -0,0 +1,76 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts show) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module ((guix scripts build) + #:select (%standard-build-options)) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-show)) + +(define (show-help) + (display (G_ "Usage: guix show [OPTION] PACKAGE... +Show details about PACKAGE.")) + (display (G_" +This is an alias for 'guix package --show='.\n")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix show"))) + + (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options))) + +(define (guix-show . args) + (define (handle-argument arg result) + ;; Treat all non-option arguments as regexps. + (cons `(query show ,arg) + result)) + + (define opts + (args-fold* args %options + (lambda (opt name arg . rest) + (leave (G_ "~A: unrecognized option~%") name)) + handle-argument + '())) + + (unless (assoc-ref opts 'query) + (leave (G_ "missing arguments: no package to show~%"))) + + (guix-package* opts)) |