diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/ruby-build-system.scm | 2 | ||||
| -rw-r--r-- | guix/channels.scm | 145 | ||||
| -rw-r--r-- | guix/gexp.scm | 26 | ||||
| -rw-r--r-- | guix/git.scm | 58 | ||||
| -rw-r--r-- | guix/import/github.scm | 6 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 3 | ||||
| -rw-r--r-- | guix/import/stackage.scm | 2 | ||||
| -rw-r--r-- | guix/inferior.scm | 33 | ||||
| -rw-r--r-- | guix/lint.scm | 2 | ||||
| -rw-r--r-- | guix/repl.scm | 6 | ||||
| -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 | ||||
| -rw-r--r-- | guix/tests/git.scm | 105 | ||||
| -rw-r--r-- | guix/ui.scm | 66 |
18 files changed, 740 insertions, 101 deletions
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 63c94765f7..c957a61115 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -128,7 +128,7 @@ is #f." (define* (install #:key inputs outputs (gem-flags '()) #:allow-other-keys) "Install the gem archive SOURCE to the output store item. Additional -GEM-FLAGS are passed to the 'gem' invokation, if present." +GEM-FLAGS are passed to the 'gem' invocation, if present." (let* ((ruby-version (match:substring (string-match "ruby-(.*)\\.[0-9]$" (assoc-ref inputs "ruby")) diff --git a/guix/channels.scm b/guix/channels.scm index ebb2cacbc7..4e6e7090ac 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -19,6 +19,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix channels) + #:use-module (git) #:use-module (guix git) #:use-module (guix records) #:use-module (guix gexp) @@ -29,6 +30,7 @@ #:use-module (guix derivations) #:use-module (guix combinators) #:use-module (guix diagnostics) + #:use-module (guix sets) #:use-module (guix store) #:use-module (guix i18n) #:use-module ((guix utils) @@ -38,6 +40,7 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:autoload (guix self) (whole-package make-config.scm) @@ -67,7 +70,15 @@ %channel-profile-hooks channel-instances->derivation - profile-channels)) + profile-channels + + channel-news-entry? + channel-news-entry-commit + channel-news-entry-tag + channel-news-entry-title + channel-news-entry-body + + channel-news-for-commit)) ;;; Commentary: ;;; @@ -110,10 +121,11 @@ (checkout channel-instance-checkout)) (define-record-type <channel-metadata> - (channel-metadata directory dependencies) + (channel-metadata directory dependencies news-file) channel-metadata? (directory channel-metadata-directory) ;string with leading slash - (dependencies channel-metadata-dependencies)) ;list of <channel> + (dependencies channel-metadata-dependencies) ;list of <channel> + (news-file channel-metadata-news-file)) ;string | #f (define (channel-reference channel) "Return the \"reference\" for CHANNEL, an sexp suitable for @@ -129,12 +141,13 @@ if valid metadata could not be read from PORT." (match (read port) (('channel ('version 0) properties ...) (let ((directory (and=> (assoc-ref properties 'directory) first)) - (dependencies (or (assoc-ref properties 'dependencies) '()))) + (dependencies (or (assoc-ref properties 'dependencies) '())) + (news-file (and=> (assoc-ref properties 'news-file) first))) (channel-metadata - (cond ((not directory) "/") + (cond ((not directory) "/") ;directory ((string-prefix? "/" directory) directory) (else (string-append "/" directory))) - (map (lambda (item) + (map (lambda (item) ;dependencies (let ((get (lambda* (key #:optional default) (or (and=> (assoc-ref item key) first) default)))) (and-let* ((name (get 'name)) @@ -145,7 +158,8 @@ if valid metadata could not be read from PORT." (branch branch) (url url) (commit (get 'commit)))))) - dependencies)))) + dependencies) + news-file))) ;news-file ((and ('channel ('version version) _ ...) sexp) (raise (condition (&message (message "unsupported '.guix-channel' version")) @@ -169,7 +183,7 @@ doesn't exist." read-channel-metadata)) (lambda args (if (= ENOENT (system-error-errno args)) - (channel-metadata "/" '()) + (channel-metadata "/" '() #f) (apply throw args))))) (define (channel-instance-metadata instance) @@ -560,3 +574,118 @@ PROFILE is not a profile created by 'guix pull', return the empty list." ;; Show most recently installed packages last. (reverse (manifest-entries (profile-manifest profile))))) + + +;;; +;;; News. +;;; + +;; Channel news. +(define-record-type <channel-news> + (channel-news entries) + channel-news? + (entries channel-news-entries)) ;list of <channel-news-entry> + +;; News entry, associated with a specific commit of the channel. +(define-record-type <channel-news-entry> + (channel-news-entry commit tag title body) + channel-news-entry? + (commit channel-news-entry-commit) ;hex string | #f + (tag channel-news-entry-tag) ;#f | string + (title channel-news-entry-title) ;list of language tag/string pairs + (body channel-news-entry-body)) ;list of language tag/string pairs + +(define (sexp->channel-news-entry entry) + "Return the <channel-news-entry> record corresponding to ENTRY, an sexp." + (define (pair language message) + (cons (symbol->string language) message)) + + (match entry + (('entry ((and (or 'commit 'tag) type) commit-or-tag) + ('title ((? symbol? title-tags) (? string? titles)) ...) + ('body ((? symbol? body-tags) (? string? bodies)) ...) + _ ...) + (channel-news-entry (and (eq? type 'commit) commit-or-tag) + (and (eq? type 'tag) commit-or-tag) + (map pair title-tags titles) + (map pair body-tags bodies))) + (_ + (raise (condition + (&message (message "invalid channel news entry")) + (&error-location + (location (source-properties->location + (source-properties entry))))))))) + +(define (read-channel-news port) + "Read a channel news feed from PORT and return it as a <channel-news> +record." + (match (false-if-exception (read port)) + (('channel-news ('version 0) entries ...) + (channel-news (map sexp->channel-news-entry entries))) + (('channel-news ('version version) _ ...) + ;; This is an unsupported version from the future. There's nothing wrong + ;; with that (the user may simply need to upgrade the 'guix' channel to + ;; be able to read it), so silently ignore it. + (channel-news '())) + (#f + (raise (condition + (&message (message "syntactically invalid channel news file"))))) + (sexp + (raise (condition + (&message (message "invalid channel news file")) + (&error-location + (location (source-properties->location + (source-properties sexp))))))))) + +(define (resolve-channel-news-entry-tag repository entry) + "If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup +ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to +the field its 'tag' refers to. A 'git-error' exception is raised if the tag +cannot be found." + (if (channel-news-entry-commit entry) + entry + (let* ((tag (channel-news-entry-tag entry)) + (reference (string-append "refs/tags/" tag)) + (oid (reference-name->oid repository reference))) + (channel-news-entry (oid->string oid) tag + (channel-news-entry-title entry) + (channel-news-entry-body entry))))) + +(define* (channel-news-for-commit channel new #:optional old) + "Return a list of <channel-news-entry> for CHANNEL between commits OLD and +NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." + (catch 'git-error + (lambda () + (let* ((checkout (update-cached-checkout (channel-url channel) + #:ref `(commit . ,new))) + (metadata (read-channel-metadata-from-source checkout)) + (news-file (channel-metadata-news-file metadata)) + (news-file (and news-file + (string-append checkout "/" news-file)))) + (if (and news-file (file-exists? news-file)) + (with-repository checkout repository + (let* ((news (call-with-input-file news-file + read-channel-news)) + (entries (map (lambda (entry) + (resolve-channel-news-entry-tag repository + entry)) + (channel-news-entries news)))) + (if old + (let* ((new (commit-lookup repository (string->oid new))) + (old (commit-lookup repository (string->oid old))) + (commits (list->set + (map (compose oid->string commit-id) + (commit-difference new old))))) + (filter (lambda (entry) + (set-contains? commits + (channel-news-entry-commit entry))) + entries)) + entries))) + '()))) + (lambda (key error . rest) + ;; If commit NEW or commit OLD cannot be found, then something must be + ;; wrong (for example, the history of CHANNEL was rewritten and these + ;; commits no longer exist upstream), so quietly return the empty list. + (if (= GIT_ENOTFOUND (git-error-code error)) + '() + (apply throw key error rest))))) diff --git a/guix/gexp.scm b/guix/gexp.scm index d9bdde2e42..44db75b7c2 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -994,6 +994,15 @@ references; otherwise, return only non-native references." (target (%current-target-system))) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" + (define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? keyword? pair? null? array? + number? boolean?))) + (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref @@ -1023,8 +1032,10 @@ and in the current monad setting (system type, etc.)" #:target target))) ;; OBJ must be either a derivation or a store file name. (return (expand thing obj output))))) - (($ <gexp-input> x) + (($ <gexp-input> (? self-quoting? x)) (return x)) + (($ <gexp-input> x) + (raise (condition (&gexp-input-error (input x))))) (x (return x))))) @@ -1033,19 +1044,6 @@ and in the current monad setting (system type, etc.)" reference->sexp (gexp-references exp)))) (return (apply (gexp-proc exp) args)))) -(define (syntax-location-string s) - "Return a string representing the source code location of S." - (let ((props (syntax-source s))) - (if props - (let ((file (assoc-ref props 'filename)) - (line (and=> (assoc-ref props 'line) 1+)) - (column (assoc-ref props 'column))) - (if file - (simple-format #f "~a:~a:~a" - file line column) - (simple-format #f "~a:~a" line column))) - "<unknown location>"))) - (define-syntax-rule (define-syntax-parameter-once name proc) ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME ;; does not get redefined. This works around a race condition in a diff --git a/guix/git.scm b/guix/git.scm index de98fed40c..d7dddde3a7 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -28,6 +28,7 @@ #:use-module (guix utils) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix sets) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -37,8 +38,10 @@ #:export (%repository-cache-directory honor-system-x509-certificates! + with-repository update-cached-checkout latest-repository-commit + commit-difference git-checkout git-checkout? @@ -220,6 +223,21 @@ dynamic extent of EXP." (G_ "Support for submodules is missing; \ please upgrade Guile-Git.~%")))) +(define (reference-available? repository ref) + "Return true if REF, a reference such as '(commit . \"cabba9e\"), is +definitely available in REPOSITORY, false otherwise." + (match ref + (('commit . commit) + (catch 'git-error + (lambda () + (->bool (commit-lookup repository (string->oid commit)))) + (lambda (key error . rest) + (if (= GIT_ENOTFOUND (git-error-code error)) + #f + (apply throw key error rest))))) + (_ + #f))) + (define* (update-cached-checkout url #:key (ref '(branch . "master")) @@ -254,7 +272,8 @@ When RECURSIVE? is true, check out submodules as well, if any." (repository-open cache-directory) (clone* url cache-directory)))) ;; Only fetch remote if it has not been cloned just before. - (when cache-exists? + (when (and cache-exists? + (not (reference-available? repository ref))) (remote-fetch (remote-lookup repository "origin"))) (when recursive? (update-submodules repository #:log-port log-port)) @@ -325,6 +344,43 @@ Log progress and checkout info to LOG-PORT." ;;; +;;; Commit difference. +;;; + +(define (commit-closure commit) + "Return the closure of COMMIT as a set." + (let loop ((commits (list commit)) + (visited (setq))) + (match commits + (() + visited) + ((head . tail) + (if (set-contains? visited head) + (loop tail visited) + (loop (append (commit-parents head) tail) + (set-insert head visited))))))) + +(define (commit-difference new old) + "Return the list of commits between NEW and OLD, where OLD is assumed to be +an ancestor of NEW. + +Essentially, this computes the set difference between the closure of NEW and +that of OLD." + (let loop ((commits (list new)) + (result '()) + (visited (commit-closure old))) + (match commits + (() + (reverse result)) + ((head . tail) + (if (set-contains? visited head) + (loop tail result visited) + (loop (append (commit-parents head) tail) + (cons head result) + (set-insert head visited))))))) + + +;;; ;;; Checkouts. ;;; diff --git a/guix/import/github.scm b/guix/import/github.scm index 55ea00a111..df5f6ff32f 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -186,7 +187,12 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" (substring tag 0 (+ name-length 1)))) (substring tag (+ name-length 1))) ;; some tags start with a "v" e.g. "v0.25.0" + ;; or with the word "version" e.g. "version.2.1" ;; where some are just the version number + ((string-prefix? "version" tag) + (if (char-set-contains? char-set:digit (string-ref tag 7)) + (substring tag 7) + (substring tag 8))) ((string-prefix? "v" tag) (substring tag 1)) ;; Finally, reject tags that don't start with a digit: diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 9b3d80a02e..354cae9c4c 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -437,7 +437,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define (pypi-url? url) (or (string-prefix? "https://pypi.org/" url) (string-prefix? "https://pypi.python.org/" url) - (string-prefix? "https://pypi.org/packages" url))) + (string-prefix? "https://pypi.org/packages" url) + (string-prefix? "https://files.pythonhosted.org/packages" url))) (let ((source-url (and=> (package-source package) origin-uri)) (fetch-method (and=> (package-source package) origin-method))) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 194bea633e..14150201b5 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -95,7 +95,7 @@ (lts-info-packages (stackage-lts-info-fetch lts-version)))) "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved -vesion corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION +version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to that package, or #f on failure. PACKAGES-INFO is the alist with the packages included in the Stackage LTS release." diff --git a/guix/inferior.scm b/guix/inferior.scm index fee97750b6..dcbc954432 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -19,6 +19,8 @@ (define-module (guix inferior) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module ((guix utils) #:select (%current-system source-properties->location @@ -29,7 +31,8 @@ #:select (store-connection-socket store-connection-major-version store-connection-minor-version - store-lift)) + store-lift + &store-protocol-error)) #:use-module ((guix derivations) #:select (read-derivation-from-file)) #:use-module (guix gexp) @@ -151,6 +154,7 @@ inferior." (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) (inferior-eval '(use-modules (ice-9 match)) result) + (inferior-eval '(use-modules (srfi srfi-34)) result) (inferior-eval '(define %package-table (make-hash-table)) result) result)) @@ -386,7 +390,7 @@ inferior package." (cut inferior-package-input-field <> 'package-transitive-propagated-inputs)) (define (%inferior-package-search-paths package field) - "Return the list of search path specificiations of PACKAGE, an inferior + "Return the list of search path specifications of PACKAGE, an inferior package." (define paths (inferior-package-field package @@ -462,7 +466,13 @@ thus be the code of a one-argument procedure that accepts a store." (listen socket 1024) (send-inferior-request `(let ((proc ,code) - (socket (socket AF_UNIX SOCK_STREAM 0))) + (socket (socket AF_UNIX SOCK_STREAM 0)) + (error? (if (defined? 'store-protocol-error?) + store-protocol-error? + nix-protocol-error?)) + (error-message (if (defined? 'store-protocol-error-message) + store-protocol-error-message + nix-protocol-error-message))) (connect socket AF_UNIX ,name) ;; 'port->connection' appeared in June 2018 and we can hardly @@ -475,7 +485,13 @@ thus be the code of a one-argument procedure that accepts a store." (dynamic-wind (const #t) (lambda () - (proc store)) + ;; Serialize '&store-protocol-error' conditions. The + ;; exception serialization mechanism that + ;; 'read-repl-response' expects is unsuitable for SRFI-35 + ;; error conditions, hence this special case. + (guard (c ((error? c) + `(store-protocol-error ,(error-message c)))) + `(result ,(proc store)))) (lambda () (close-connection store) (close-port socket))))) @@ -484,7 +500,14 @@ thus be the code of a one-argument procedure that accepts a store." ((client . address) (proxy client (store-connection-socket store)))) (close-port socket) - (read-inferior-response inferior))))) + + (match (read-inferior-response inferior) + (('store-protocol-error message) + (raise (condition + (&store-protocol-error (message message) + (status 1))))) + (('result result) + result)))))) (define* (inferior-package-derivation store package #:optional diff --git a/guix/lint.scm b/guix/lint.scm index ba38bef806..03a8e88225 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -525,7 +525,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (define (validate-uri uri package field) "Return #t if the given URI can be reached, otherwise return a warning for -PACKAGE mentionning the FIELD." +PACKAGE mentioning the FIELD." (let-values (((status argument) (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status diff --git a/guix/repl.scm b/guix/repl.scm index 5cff5c71e9..1ead18c53b 100644 --- a/guix/repl.scm +++ b/guix/repl.scm @@ -17,7 +17,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix repl) - #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (send-repl-response machine-repl)) @@ -37,9 +36,8 @@ ((_ pred rest ...) (or (pred x) (one-of rest ...)))))) - (one-of symbol? string? pair? null? vector? - bytevector? number? boolean?))) - + (one-of symbol? string? keyword? pair? null? array? + number? boolean?))) (define (send-repl-response exp output) "Write the response corresponding to the evaluation of EXP to PORT, an 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)) diff --git a/guix/tests/git.scm b/guix/tests/git.scm new file mode 100644 index 0000000000..21573ac14e --- /dev/null +++ b/guix/tests/git.scm @@ -0,0 +1,105 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 tests git) + #:use-module (git) + #:use-module ((guix git) #:select (with-repository)) + #:use-module (guix utils) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 control) + #:export (git-command + with-temporary-git-repository + find-commit)) + +(define git-command + (make-parameter "git")) + +(define (populate-git-repository directory directives) + "Initialize a new Git checkout and repository in DIRECTORY and apply +DIRECTIVES. Each element of DIRECTIVES is an sexp like: + + (add \"foo.txt\" \"hi!\") + +Return DIRECTORY on success." + + ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do + ;; all this, so resort to the "git" command. + (define (git command . args) + (apply invoke (git-command) "-C" directory + command args)) + + (mkdir-p directory) + (git "init") + + (let loop ((directives directives)) + (match directives + (() + directory) + ((('add file contents) rest ...) + (let ((file (string-append directory "/" file))) + (mkdir-p (dirname file)) + (call-with-output-file file + (lambda (port) + (display (if (string? contents) + contents + (with-repository directory repository + (contents repository))) + port))) + (git "add" file) + (loop rest))) + ((('commit text) rest ...) + (git "commit" "-m" text) + (loop rest)) + ((('tag name) rest ...) + (git "tag" name) + (loop rest)) + ((('branch name) rest ...) + (git "branch" name) + (loop rest)) + ((('checkout branch) rest ...) + (git "checkout" branch) + (loop rest)) + ((('merge branch message) rest ...) + (git "merge" branch "-m" message) + (loop rest))))) + +(define (call-with-temporary-git-repository directives proc) + (call-with-temporary-directory + (lambda (directory) + (populate-git-repository directory directives) + (proc directory)))) + +(define-syntax-rule (with-temporary-git-repository directory + directives exp ...) + "Evaluate EXP in a context where DIRECTORY contains a checkout populated as +per DIRECTIVES." + (call-with-temporary-git-repository directives + (lambda (directory) + exp ...))) + +(define (find-commit repository message) + "Return the commit in REPOSITORY whose message includes MESSAGE, a string." + (let/ec return + (fold-commits (lambda (commit _) + (and (string-contains (commit-message commit) + message) + (return commit))) + #f + repository) + (error "commit not found" message))) diff --git a/guix/ui.scm b/guix/ui.scm index 7920335928..069d542131 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -120,6 +121,10 @@ roll-back* switch-to-generation* delete-generation* + + %default-message-language + current-message-language + run-guix-command run-guix guix-main)) @@ -427,6 +432,20 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." report them in a user-friendly way." (call-with-unbound-variable-handling (lambda () exp ...))) +(define %default-message-language + ;; Default language to use for messages. + (make-parameter "en")) + +(define (current-message-language) + "Return the language used for messages according to the current locale. +Return %DEFAULT-MESSAGE-LANGUAGE if that information could not be obtained. The +result is an ISO-639-2 language code such as \"ar\", without the territory +part." + (let ((locale (setlocale LC_MESSAGES))) + (match (string-index locale #\_) + (#f locale) + (index (string-take locale index))))) + (define (install-locale) "Install the current locale settings." (catch 'system-error @@ -1281,33 +1300,32 @@ weight of this field in the final score. A score of zero means that OBJ does not match any of REGEXPS. The higher the score, the more relevant OBJ is to REGEXPS." - (define (score str) - (define scores - (map (lambda (regexp) - (fold-matches regexp str 0 - (lambda (m score) - (+ score - (if (string=? (match:substring m) str) - 5 ;exact match - 1))))) - regexps)) - + (define (score regexp str) + (fold-matches regexp str 0 + (lambda (m score) + (+ score + (if (string=? (match:substring m) str) + 5 ;exact match + 1))))) + + (define (regexp->score regexp) + (let ((score-regexp (lambda (str) (score regexp str)))) + (fold (lambda (metric relevance) + (match metric + ((field . weight) + (match (field obj) + (#f relevance) + ((? string? str) + (+ relevance (* (score-regexp str) weight))) + ((lst ...) + (+ relevance (* weight (apply + (map score-regexp lst))))))))) + 0 metrics))) + + (let ((scores (map regexp->score regexps))) ;; Return zero if one of REGEXPS doesn't match. (if (any zero? scores) 0 - (reduce + 0 scores))) - - (fold (lambda (metric relevance) - (match metric - ((field . weight) - (match (field obj) - (#f relevance) - ((? string? str) - (+ relevance (* (score str) weight))) - ((lst ...) - (+ relevance (* weight (apply + (map score lst))))))))) - 0 - metrics)) + (reduce + 0 scores)))) (define %package-metrics ;; Metrics used to compute the "relevance score" of a package against a set |