diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/compile.scm | 9 | ||||
| -rw-r--r-- | guix/build/ruby-build-system.scm | 2 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 28 | ||||
| -rw-r--r-- | guix/channels.scm | 197 | ||||
| -rw-r--r-- | guix/colors.scm | 18 | ||||
| -rw-r--r-- | guix/gexp.scm | 75 | ||||
| -rw-r--r-- | guix/git.scm | 58 | ||||
| -rw-r--r-- | guix/import/crate.scm | 29 | ||||
| -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 | 37 | ||||
| -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/download.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/import/crate.scm | 36 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 30 | ||||
| -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/self.scm | 6 | ||||
| -rw-r--r-- | guix/tests/git.scm | 105 | ||||
| -rw-r--r-- | guix/ui.scm | 106 |
27 files changed, 1000 insertions, 170 deletions
diff --git a/guix/build/compile.scm b/guix/build/compile.scm index c127456fd0..06ed57c9d7 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -169,11 +169,12 @@ BUILD-DIRECTORY, using up to WORKERS parallel workers. The resulting object files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." (define progress-lock (make-mutex)) (define total (length files)) - (define completed 0) + (define progress 0) (define (build file) (with-mutex progress-lock - (report-compilation file total completed)) + (report-compilation file total progress) + (set! progress (+ 1 progress))) ;; Exit as soon as something goes wrong. (exit-on-exception @@ -185,9 +186,7 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." #:output-file (string-append build-directory "/" (scm->go relative)) #:opts (append warning-options - (optimization-options relative))))))) - (with-mutex progress-lock - (set! completed (+ 1 completed)))) + (optimization-options relative)))))))) (with-augmented-search-path %load-path source-directory (with-augmented-search-path %load-compiled-path build-directory 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/build/syscalls.scm b/guix/build/syscalls.scm index f2fdb4d9d1..bbf2531c79 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -68,6 +68,7 @@ statfs free-disk-space device-in-use? + add-to-entropy-count processes mkdtemp! @@ -708,6 +709,33 @@ backend device." ;;; +;;; Random. +;;; + +;; From <uapi/linux/random.h>. +(define RNDADDTOENTCNT #x40045201) + +(define (add-to-entropy-count port-or-fd n) + "Add N to the kernel's entropy count (the value that can be read from +/proc/sys/kernel/random/entropy_avail). PORT-OR-FD must correspond to +/dev/urandom or /dev/random. Raise to 'system-error with EPERM when the +caller lacks root privileges." + (let ((fd (if (port? port-or-fd) + (fileno port-or-fd) + port-or-fd)) + (box (make-bytevector (sizeof int)))) + (bytevector-sint-set! box 0 n (native-endianness) + (sizeof int)) + (let-values (((ret err) + (%ioctl fd RNDADDTOENTCNT + (bytevector->pointer box)))) + (unless (zero? err) + (throw 'system-error "add-to-entropy-count" "~A" + (list (strerror err)) + (list err)))))) + + +;;; ;;; Containers. ;;; diff --git a/guix/channels.scm b/guix/channels.scm index ebb2cacbc7..2c28dccbcb 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) @@ -26,9 +27,11 @@ #:use-module (guix discovery) #:use-module (guix monads) #:use-module (guix profiles) + #:use-module (guix packages) #: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,12 +41,14 @@ #: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) #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module ((ice-9 rdelim) #:select (read-string)) #:export (channel channel? channel-name @@ -67,7 +72,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 +123,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 +143,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 +160,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 +185,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) @@ -292,6 +308,46 @@ to '%package-module-path'." (gexp->derivation-in-inferior name build core))) +(define (syscalls-reexports-local-variables? source) + "Return true if (guix build syscalls) contains the bug described at +<https://bugs.gnu.org/36723>." + (catch 'system-error + (lambda () + (define content + (call-with-input-file (string-append source + "/guix/build/syscalls.scm") + read-string)) + + ;; The faulty code would use the 're-export' macro, causing the + ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using + ;; Guile > 2.2.4. + (string-contains content "(re-export variable)")) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (guile-2.2.4) + (module-ref (resolve-interface '(gnu packages guile)) + 'guile-2.2.4)) + +(define %quirks + ;; List of predicate/package pairs. This allows us provide information + ;; about specific Guile versions that old Guix revisions might need to use + ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See + ;; <https://bugs.gnu.org/37506> + `((,syscalls-reexports-local-variables? . ,guile-2.2.4))) + +(define* (guile-for-source source #:optional (quirks %quirks)) + "Return the Guile package to use when building SOURCE or #f if the default +'%guile-for-build' should be good enough." + (let loop ((quirks quirks)) + (match quirks + (() + #f) + (((predicate . guile) rest ...) + (if (predicate source) (guile) (loop rest)))))) + (define* (build-from-source name source #:key core verbose? commit (dependencies '())) @@ -313,15 +369,19 @@ package modules under SOURCE using CORE, an instance of Guix." ;; about it. (parameterize ((guix-warning-port (%make-void-port "w"))) - (primitive-load script)))))) + (primitive-load script))))) + (guile (guile-for-source source))) ;; BUILD must be a monadic procedure of at least one argument: the ;; source tree. ;; ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In ;; the future we'll fall back to a previous version of the protocol ;; when that happens. - (build source #:verbose? verbose? #:version commit - #:pull-version %pull-version)) + (mbegin %store-monad + (mwhen guile + (set-guile-for-build guile)) + (build source #:verbose? verbose? #:version commit + #:pull-version %pull-version))) ;; Build a set of modules that extend Guix using the standard method. (standard-module-derivation name source core dependencies))) @@ -560,3 +620,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/colors.scm b/guix/colors.scm index 7949cf5763..b63ac37027 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -31,6 +31,8 @@ colorize-string highlight + dim + color-rules color-output? isatty?*)) @@ -133,14 +135,16 @@ that subsequent output will not have any colors in effect." (not (getenv "NO_COLOR")) (isatty?* port))) -(define %highlight-color (color BOLD)) +(define (coloring-procedure color) + "Return a procedure that applies COLOR to the given string." + (lambda* (str #:optional (port (current-output-port))) + "Return STR with extra ANSI color attributes if PORT supports it." + (if (color-output? port) + (colorize-string str color) + str))) -(define* (highlight str #:optional (port (current-output-port))) - "Return STR with extra ANSI color attributes to highlight it if PORT -supports it." - (if (color-output? port) - (colorize-string str %highlight-color) - str)) +(define highlight (coloring-procedure (color BOLD))) +(define dim (coloring-procedure (color DARK))) (define (colorize-matches rules) "Return a procedure that, when passed a string, returns that string diff --git a/guix/gexp.scm b/guix/gexp.scm index d9bdde2e42..600750e846 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 @@ -1506,24 +1504,37 @@ are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." #:module-path path #:system system #:target target))) - (return (gexp (eval-when (expand load eval) - (set! %load-path - (cons (ungexp modules) - (append (map (lambda (extension) - (string-append extension - "/share/guile/site/" - (effective-version))) - '((ungexp-native-splicing extensions))) - %load-path))) - (set! %load-compiled-path - (cons (ungexp compiled) - (append (map (lambda (extension) - (string-append extension - "/lib/guile/" - (effective-version) - "/site-ccache")) - '((ungexp-native-splicing extensions))) - %load-compiled-path))))))))) + (return + (gexp (eval-when (expand load eval) + ;; Augment the load paths and delete duplicates. Do that + ;; without loading (srfi srfi-1) or anything. + (let ((extensions '((ungexp-native-splicing extensions))) + (prepend (lambda (items lst) + ;; This is O(N²) but N is typically small. + (let loop ((items items) + (lst lst)) + (if (null? items) + lst + (loop (cdr items) + (cons (car items) + (delete (car items) lst)))))))) + (set! %load-path + (prepend (cons (ungexp modules) + (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + extensions)) + %load-path)) + (set! %load-compiled-path + (prepend (cons (ungexp compiled) + (map (lambda (extension) + (string-append extension + "/lib/guile/" + (effective-version) + "/site-ccache")) + extensions)) + %load-compiled-path))))))))) (define* (gexp->script name exp #:key (guile (default-guile)) 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/crate.scm b/guix/import/crate.scm index fd1974eae8..8dc014d232 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -40,6 +40,7 @@ #:use-module (srfi srfi-26) #:export (crate->guix-package guix-package->crate-name + crate-recursive-import %crate-updater)) @@ -218,16 +219,24 @@ latest version of CRATE-NAME." (cargo-development-inputs (sort (map crate-dependency-id dev-dep-crates) string-ci<?))) - (make-crate-sexp #:name crate-name - #:version (crate-version-number version*) - #:cargo-inputs cargo-inputs - #:cargo-development-inputs cargo-development-inputs - #:home-page (or (crate-home-page crate) - (crate-repository crate)) - #:synopsis (crate-description crate) - #:description (crate-description crate) - #:license (and=> (crate-version-license version*) - string->license))))) + (values + (make-crate-sexp #:name crate-name + #:version (crate-version-number version*) + #:cargo-inputs cargo-inputs + #:cargo-development-inputs cargo-development-inputs + #:home-page (or (crate-home-page crate) + (crate-repository crate)) + #:synopsis (crate-description crate) + #:description (crate-description crate) + #:license (and=> (crate-version-license version*) + string->license)) + (append cargo-inputs cargo-development-inputs))))) + +(define (crate-recursive-import crate-name) + (recursive-import crate-name #f + #:repo->guix-package (lambda (name repo) + (crate->guix-package name)) + #:guix-name crate-name->package-name)) (define (guix-package->crate-name package) "Return the crate name of PACKAGE." 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..d6d2053ab8 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) @@ -133,8 +136,8 @@ it's an old Guix." (object->string `(begin (primitive-load ,(search-path %load-path - "guix/scripts/repl.scm")) - ((@ (guix scripts repl) machine-repl)))))) + "guix/repl.scm")) + ((@ (guix repl) machine-repl)))))) pipe))) (define* (port->inferior pipe #:optional (close close-port)) @@ -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/download.scm b/guix/scripts/download.scm index d8fe71ce12..22cd75ea0b 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -33,6 +33,7 @@ #:use-module (web uri) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-14) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (rnrs bytevectors) @@ -54,9 +55,23 @@ (url-fetch url file #:mirrors %mirrors))) file)) +(define (ensure-valid-store-file-name name) + "Replace any character not allowed in a stror name by an underscore." + + (define valid + ;; according to nix/libstore/store-api.cc + (string->char-set (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "abcdefghijklmnopqrstuvwxyz" + "0123456789" "+-._?="))) + (string-map (lambda (c) + (if (char-set-contains? valid c) c #\_)) + name)) + + (define* (download-to-store* url #:key (verify-certificate? #t)) (with-store store (download-to-store store url + (ensure-valid-store-file-name (basename url)) #:verify-certificate? verify-certificate?))) (define %default-options diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index cfe0a37c42..d78ca0f303 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -453,7 +453,7 @@ regexps in WHITE-LIST." (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? - map-cwd?) + map-cwd? (white-list '())) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to the search paths of MANIFEST. The global shell is BASH, a file name for a GNU Bash binary in the @@ -462,7 +462,10 @@ USER-MAPPINGS, a list of file system mappings, contains the user-specified host file systems to mount inside the container. If USER is not #f, each target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from -~/.guix-profile to the environment profile." +~/.guix-profile to the environment profile. + +Preserve environment variables whose name matches the one of the regexps in +WHILE-LIST." (define (optional-mapping->fs mapping) (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) @@ -488,6 +491,11 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (group-entry (gid 65534) ;the overflow GID (name "overflow")))) (home-dir (password-entry-directory passwd)) + (environ (filter (match-lambda + ((variable . value) + (find (cut regexp-exec <> variable) + white-list))) + (get-environment-variables))) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. @@ -556,6 +564,12 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (override-user-dir user home cwd) home-dir)) + ;; Set environment variables that match WHITE-LIST. + (for-each (match-lambda + ((variable . value) + (setenv variable value))) + environ) + (primitive-exit/status ;; A container's environment is already purified, so no need to ;; request it be purified again. @@ -759,6 +773,7 @@ message if any test fails." #:user-mappings mappings #:profile profile #:manifest manifest + #:white-list white-list #:link-profile? link-prof? #:network? network? #:map-cwd? (not no-cwd?)))) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index 7ae8638911..4690cceb4d 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-crate)) @@ -44,6 +45,9 @@ (display (G_ "Usage: guix import crate PACKAGE-NAME Import and convert the crate.io package for PACKAGE-NAME.\n")) (display (G_ " + -r, --recursive import packages recursively")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -59,6 +63,9 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import crate"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -79,22 +86,31 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) (let* ((opts (parse-options)) (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) + (('argument . value) + value) + (_ #f)) (reverse opts)))) (match args ((spec) (define-values (name version) (package-name->name+version spec)) - (let ((sexp (crate->guix-package name version))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - (if version - (string-append name "@" version) - name))) - sexp)) + (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (crate-recursive-import name)))) + (let ((sexp (crate->guix-package name version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + (if version + (string-append name "@" version) + name))) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 0c0dd9d516..bb307cefd1 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -243,7 +243,8 @@ instead of '~a' of type '~a'~%") ;; of these; if we fail, that means all the build slots are already taken. ;; Inspired by Nix's build-remote.pl. (string-append (string-append %state-directory "/offload/" - (build-machine-name machine) + (build-machine-name machine) ":" + (number->string (build-machine-port machine)) "/" (number->string slot)))) (define (acquire-build-slot machine) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a43c96516f..1a58d43e5c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -39,6 +39,7 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:autoload (guix describe) (package-provenance) + #:autoload (guix store roots) (gc-roots) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) @@ -359,6 +360,8 @@ Install, remove, or upgrade packages in a single transaction.\n")) switch to a generation matching PATTERN")) (display (G_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (display (G_ " + --list-profiles list the user's profiles")) (newline) (display (G_ " --allow-collisions do not treat collisions in the profile as an error")) @@ -458,6 +461,11 @@ command-line option~%") (values (cons `(query list-generations ,arg) result) #f))) + (option '("list-profiles") #f #f + (lambda (opt name arg result arg-handler) + (values (cons `(query list-profiles #t) + result) + #f))) (option '(#\d "delete-generations") #f #t (lambda (opt name arg result arg-handler) (values (alist-cons 'delete-generations arg @@ -607,7 +615,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 @@ -746,6 +758,19 @@ processed, #f otherwise." (string<? name1 name2)))))) #t)) + (('list-profiles _) + (let ((profiles (delete-duplicates + (filter-map (lambda (root) + (and (or (zero? (getuid)) + (user-owned? root)) + (generation-profile root))) + (gc-roots))))) + (leave-on-EPIPE + (for-each (lambda (profile) + (display (user-friendly-profile profile)) + (newline)) + (sort profiles string<?))))) + (('search _) (let* ((patterns (filter-map (match-lambda (('query 'search rx) rx) @@ -760,7 +785,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..04970cf503 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 (dim (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_ " ~a 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_ " ~a 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/self.scm b/guix/self.scm index 7b0634e8b6..207e80d842 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -124,7 +124,11 @@ NODE's modules, under their FHS directories: share/guile/site and lib/guile." (symlink #$(node-compiled node) object)))) (computed-file (string-append (node-name node) "-modules") - build)) + build + #:options '(#:local-build? #t + + ;; "Building" it locally is faster. + #:substitutable? #f))) (define (node-fold proc init nodes) (let loop ((nodes nodes) 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..3e4bd5787e 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 @@ -848,6 +867,17 @@ warning." ('profile-hook #t) (_ #f))) +(define (colorize-store-file-name file) + "Colorize FILE, a store file name, such that the hash part is less prominent +that the rest." + (let ((len (string-length file)) + (prefix (+ (string-length (%store-prefix)) 32 2))) + (if (< len prefix) + file + (string-append (colorize-string (string-take file prefix) + (color DARK)) + (string-drop file prefix))))) + (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) (mode (build-mode normal))) @@ -871,6 +901,11 @@ check and report what is prerequisites are available for download." (substitution-oracle store inputs #:mode mode) (const #f))) + (define colorized-store-item + (if (color-output? (current-error-port)) + colorize-store-file-name + identity)) + (let*-values (((build download) (derivation-build-plan store inputs #:mode mode @@ -916,7 +951,7 @@ check and report what is prerequisites are available for download." (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]" "~:[The following derivations would be built:~%~{ ~a~%~}~;~]" (length build)) - (null? build) build) + (null? build) (map colorized-store-item build)) (if display-download-size? (format (current-error-port) ;; TRANSLATORS: "MB" is for "megabyte"; it should be @@ -924,29 +959,31 @@ check and report what is prerequisites are available for download." (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]") (null? download) download-size - (map substitutable-path download)) + (map (compose colorized-store-item substitutable-path) + download)) (format (current-error-port) (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) - (map substitutable-path download))) + (map (compose colorized-store-item substitutable-path) + download))) (format (current-error-port) (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" (length graft)) - (null? graft) graft) + (null? graft) (map colorized-store-item graft)) (format (current-error-port) (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]" "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]" (length hook)) - (null? hook) hook)) + (null? hook) (map colorized-store-item hook))) (begin (format (current-error-port) (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" "~:[The following derivations will be built:~%~{ ~a~%~}~;~]" (length build)) - (null? build) build) + (null? build) (map colorized-store-item build)) (if display-download-size? (format (current-error-port) ;; TRANSLATORS: "MB" is for "megabyte"; it should be @@ -954,23 +991,25 @@ check and report what is prerequisites are available for download." (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]") (null? download) download-size - (map substitutable-path download)) + (map (compose colorized-store-item substitutable-path) + download)) (format (current-error-port) (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) - (map substitutable-path download))) + (map (compose colorized-store-item substitutable-path) + download))) (format (current-error-port) (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" (length graft)) - (null? graft) graft) + (null? graft) (map colorized-store-item graft)) (format (current-error-port) (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]" "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]" (length hook)) - (null? hook) hook))) + (null? hook) (map colorized-store-item hook)))) (check-available-space installed-size) @@ -1281,33 +1320,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 |