diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build/ruby-build-system.scm | 53 | ||||
-rw-r--r-- | guix/git.scm | 8 | ||||
-rw-r--r-- | guix/gnu-maintenance.scm | 3 | ||||
-rw-r--r-- | guix/inferior.scm | 26 | ||||
-rw-r--r-- | guix/scripts/archive.scm | 2 | ||||
-rw-r--r-- | guix/scripts/build.scm | 2 | ||||
-rw-r--r-- | guix/scripts/copy.scm | 2 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 55 | ||||
-rw-r--r-- | guix/scripts/pack.scm | 6 | ||||
-rw-r--r-- | guix/scripts/package.scm | 3 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 65 | ||||
-rw-r--r-- | guix/scripts/system.scm | 22 | ||||
-rw-r--r-- | guix/self.scm | 20 | ||||
-rw-r--r-- | guix/status.scm | 3 | ||||
-rw-r--r-- | guix/ui.scm | 11 |
15 files changed, 197 insertions, 84 deletions
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 3a658e2557..ba0de1259e 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -86,28 +86,29 @@ operation is not deterministic, we replace it with `find`." "Remove the original gemspec, if present, and replace it with a new one. This avoids issues with upstream gemspecs requiring tools such as git to generate the files list." - (when (gem-archive? source) - (let ((gemspec (or (false-if-exception (first-gemspec)) - ;; Make new gemspec if one wasn't shipped. - ".gemspec"))) - - (when (file-exists? gemspec) (delete-file gemspec)) - - ;; Extract gemspec from source gem. - (let ((pipe (open-pipe* OPEN_READ "gem" "spec" "--ruby" source))) - (dynamic-wind - (const #t) - (lambda () - (call-with-output-file gemspec - (lambda (out) - ;; 'gem spec' writes to stdout, but 'gem build' only reads - ;; gemspecs from a file, so we redirect the output to a file. - (while (not (eof-object? (peek-char pipe))) - (write-char (read-char pipe) out)))) - #t) - (lambda () - (close-pipe pipe))))) - #t)) + (if (gem-archive? source) + (let ((gemspec (or (false-if-exception (first-gemspec)) + ;; Make new gemspec if one wasn't shipped. + ".gemspec"))) + + (when (file-exists? gemspec) (delete-file gemspec)) + + ;; Extract gemspec from source gem. + (let ((pipe (open-pipe* OPEN_READ "gem" "spec" "--ruby" source))) + (dynamic-wind + (const #t) + (lambda () + (call-with-output-file gemspec + (lambda (out) + ;; 'gem spec' writes to stdout, but 'gem build' only reads + ;; gemspecs from a file, so we redirect the output to a file. + (while (not (eof-object? (peek-char pipe))) + (write-char (read-char pipe) out)))) + #t) + (lambda () + (close-pipe pipe))))) + (display "extract-gemspec: skipping as source is not a gem archive\n")) + #t) (define* (build #:key source #:allow-other-keys) "Build a new gem using the gemspec from the SOURCE gem." @@ -138,11 +139,13 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." (gem-file-basename (basename gem-file)) (gem-name (substring gem-file-basename 0 - (- (string-length gem-file-basename) 4)))) + (- (string-length gem-file-basename) 4))) + (gem-dir (string-append vendor-dir "/gems/" gem-name))) (setenv "GEM_VENDOR" vendor-dir) (or (zero? (apply system* "gem" "install" gem-file + "--verbose" "--local" "--ignore-dependencies" "--vendor" ;; Executables should go into /bin, not ;; /lib/ruby/gems. @@ -163,7 +166,7 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." ;; For gems with native extensions, several Makefile-related files ;; are created that contain timestamps or other elements making ;; them not reproducible. They are unnecessary so we remove them. - (when (file-exists? (string-append vendor-dir "/ext")) + (when (file-exists? (string-append gem-dir "/ext")) (for-each (lambda (file) (log-file-deletion file) (delete-file file)) @@ -172,7 +175,7 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." "page-Makefile.ri") (find-files (string-append vendor-dir "/extensions") "gem_make.out") - (find-files (string-append vendor-dir "/ext") + (find-files (string-append gem-dir "/ext") "Makefile")))) #t)) diff --git a/guix/git.scm b/guix/git.scm index 0e3ce37e26..289537dedf 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -300,6 +300,14 @@ Log progress and checkout info to LOG-PORT." #:select? (negate dot-git?)) commit))) +(define (print-git-error port key args default-printer) + (match args + (((? git-error? error) . _) + (format port (G_ "Git error: ~a~%") + (git-error-message error))))) + +(set-exception-printer! 'git-error print-git-error) + ;;; ;;; Checkouts. diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index bfd47a831d..36b3c930d7 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -623,8 +623,7 @@ releases are on gnu.org." (package-upstream-name package) #:server "mirrors.mit.edu" #:directory - (string-append "/kde" (dirname (dirname (uri-path uri)))) - #:file->signature (const #f))))) + (string-append "/kde" (dirname (dirname (uri-path uri)))))))) (define (latest-xorg-release package) "Return the latest release of PACKAGE, the name of an X.org package." diff --git a/guix/inferior.scm b/guix/inferior.scm index 6cfa146029..027418a98d 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -61,6 +61,7 @@ inferior-object? inferior-packages + inferior-available-packages lookup-inferior-packages inferior-package? @@ -256,6 +257,31 @@ equivalent. Return #f if the inferior could not be launched." vlist-null (inferior-packages inferior))) +(define (inferior-available-packages inferior) + "Return the list of name/version pairs corresponding to the set of packages +available in INFERIOR. + +This is faster and requires less resource-intensive than calling +'inferior-packages'." + (if (inferior-eval '(defined? 'fold-available-packages) + inferior) + (inferior-eval '(fold-available-packages + (lambda* (name version result + #:key supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (acons name version result) + result)) + '()) + inferior) + + ;; As a last resort, if INFERIOR is old and lacks + ;; 'fold-available-packages', fall back to 'inferior-packages'. + (map (lambda (package) + (cons (inferior-package-name package) + (inferior-package-version package))) + (inferior-packages inferior)))) + (define* (lookup-inferior-packages inferior name #:optional version) "Return the sorted list of inferior packages matching NAME in INFERIOR, with highest version numbers first. If VERSION is true, return only packages with diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 950f0f41d8..d349b5d590 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -23,7 +23,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index fb7e04904d..6b29c470fb 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -47,7 +47,7 @@ #:autoload (guix download) (download-to-store) #:autoload (guix git-download) (git-reference?) #:autoload (guix git) (git-checkout?) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:export (%standard-build-options diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index be4ce4364b..ce70f2f0b3 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -21,7 +21,7 @@ #:use-module (guix scripts) #:use-module (guix ssh) #:use-module (guix store) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix utils) #:use-module (guix derivations) #:use-module (guix scripts build) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 116b8dcbce..3966531efa 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -21,7 +21,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) @@ -57,20 +57,27 @@ (define %default-shell (or (getenv "SHELL") "/bin/sh")) -(define (purify-environment) - "Unset almost all environment variables. A small number of variables such -as 'HOME' and 'USER' are left untouched." +(define (purify-environment white-list) + "Unset all environment variables except those that match the regexps in +WHITE-LIST and those listed in %PRECIOUS-VARIABLES. A small number of +variables such as 'HOME' and 'USER' are left untouched." (for-each unsetenv - (remove (cut member <> %precious-variables) + (remove (lambda (variable) + (or (member variable %precious-variables) + (find (cut regexp-exec <> variable) + white-list))) (match (get-environment-variables) (((names . _) ...) names))))) -(define* (create-environment profile manifest #:key pure?) - "Set the environment variables specified by MANIFEST for PROFILE. When PURE? -is #t, unset the variables in the current environment. Otherwise, augment -existing environment variables with additional search paths." - (when pure? (purify-environment)) +(define* (create-environment profile manifest + #:key pure? (white-list '())) + "Set the environment variables specified by MANIFEST for PROFILE. When +PURE? is #t, unset the variables in the current environment except those that +match the regexps in WHITE-LIST. Otherwise, augment existing environment +variables with additional search paths." + (when pure? + (purify-environment white-list)) (for-each (match-lambda ((($ <search-path-specification> variable _ separator) . value) (let ((current (getenv variable))) @@ -134,6 +141,8 @@ COMMAND or an interactive shell in that environment.\n")) (display (G_ " --pure unset existing environment variables")) (display (G_ " + --inherit=REGEXP inherit environment variables that match REGEXP")) + (display (G_ " --search-paths display needed environment variable definitions")) (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) @@ -206,6 +215,11 @@ COMMAND or an interactive shell in that environment.\n")) (option '("pure") #f #f (lambda (opt name arg result) (alist-cons 'pure #t result))) + (option '("inherit") #t #f + (lambda (opt name arg result) + (alist-cons 'inherit-regexp + (make-regexp* arg) + result))) (option '(#\E "exec") #t #f ; deprecated (lambda (opt name arg result) (alist-cons 'exec (list %default-shell "-c" arg) result))) @@ -397,25 +411,30 @@ and suitable for 'exit'." (define primitive-exit/status (compose primitive-exit status->exit-code)) (define* (launch-environment command profile manifest - #:key pure?) + #:key pure? (white-list '())) "Run COMMAND in a new environment containing INPUTS, using the native search paths defined by the list PATHS. When PURE?, pre-existing environment -variables are cleared before setting the new ones." +variables are cleared before setting the new ones, except those matching the +regexps in WHITE-LIST." ;; Properly handle SIGINT, so pressing C-c in an interactive terminal ;; application works. (sigaction SIGINT SIG_DFL) - (create-environment profile manifest #:pure? pure?) + (create-environment profile manifest + #:pure? pure? #:white-list white-list) (match command ((program . args) (apply execlp program program args)))) -(define* (launch-environment/fork command profile manifest #:key pure?) +(define* (launch-environment/fork command profile manifest + #:key pure? (white-list '())) "Run COMMAND in a new process with an environment containing PROFILE, with the search paths specified by MANIFEST. When PURE?, pre-existing environment -variables are cleared before setting the new ones." +variables are cleared before setting the new ones, except those matching the +regexps in WHITE-LIST." (match (primitive-fork) (0 (launch-environment command profile manifest - #:pure? pure?)) + #:pure? pure? + #:white-list white-list)) (pid (match (waitpid pid) ((_ . status) status))))) @@ -672,7 +691,8 @@ message if any test fails." ;; within the container. '("/bin/sh") (list %default-shell)))) - (mappings (pick-all opts 'file-system-mapping))) + (mappings (pick-all opts 'file-system-mapping)) + (white-list (pick-all opts 'inherit-regexp))) (when container? (assert-container-features)) @@ -741,4 +761,5 @@ message if any test fails." (return (exit/status (launch-environment/fork command profile manifest + #:white-list white-list #:pure? pure?)))))))))))))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 40e59a6101..3f76336abf 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -26,7 +26,7 @@ #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix store) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix modules) @@ -104,7 +104,9 @@ found." ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. (append-map (lambda (package) (cons package - (package-transitive-propagated-inputs package))) + (match (package-transitive-propagated-inputs package) + (((labels packages) ...) + packages)))) (list guile-gcrypt guile-sqlite3))) (define (store-database items) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 8a71467b52..0e70315708 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -24,7 +24,7 @@ (define-module (guix scripts package) #:use-module (guix ui) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix derivations) @@ -55,6 +55,7 @@ #:autoload (gnu packages bootstrap) (%bootstrap-guile) #:export (build-and-use-profile delete-generations + delete-matching-generations display-search-paths guix-package)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 3320200c07..730b6a0bf2 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -20,7 +20,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) #:use-module (guix utils) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) @@ -45,6 +45,7 @@ #:select (%bootstrap-guile)) #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -169,11 +170,14 @@ Download and deploy the latest version of Guix.\n")) (reverse (profile-generations profile))) ((current previous _ ...) (newline) - (let ((old (fold-packages (lambda (package result) - (alist-cons (package-name package) - (package-version package) - result)) - '())) + (let ((old (fold-available-packages + (lambda* (name version result + #:key supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (alist-cons name version result) + result)) + '())) (new (profile-package-alist (generation-file-name profile current)))) (display-new/upgraded-packages old new @@ -338,24 +342,24 @@ way and displaying details about the channel's source code." (define profile-package-alist (mlambda (profile) "Return a name/version alist representing the packages in PROFILE." - (fold (lambda (package lst) - (alist-cons (inferior-package-name package) - (inferior-package-version package) - lst)) - '() - (let* ((inferior (open-inferior profile)) - (packages (inferior-packages inferior))) - (close-inferior inferior) - packages)))) - -(define* (display-new/upgraded-packages alist1 alist2 - #:key (heading "")) - "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." + (let* ((inferior (open-inferior profile)) + (packages (inferior-available-packages inferior))) + (close-inferior inferior) + packages))) + +(define (new/upgraded-packages alist1 alist2) + "Compare ALIST1 and ALIST2, both of which are lists of package name/version +pairs, and return two values: the list of packages new in ALIST2, and the list +of packages upgraded in ALIST2." (let* ((old (fold (match-lambda* (((name . version) table) - (vhash-cons name version table))) + (match (vhash-assoc name table) + (#f + (vhash-cons name version table)) + ((_ . previous-version) + (if (version>? version previous-version) + (vhash-cons name version table) + table))))) vlist-null alist1)) (new (remove (match-lambda @@ -364,14 +368,21 @@ and ALIST2 differ, display HEADING upfront." alist2)) (upgraded (filter-map (match-lambda ((name . new-version) - (match (vhash-fold* cons '() name old) - (() #f) - ((= (cut sort <> version>?) old-versions) - (and (version>? new-version - (first old-versions)) + (match (vhash-assoc name old) + (#f #f) + ((_ . old-version) + (and (version>? new-version old-version) (string-append name "@" new-version)))))) alist2))) + (values new upgraded))) + +(define* (display-new/upgraded-packages alist1 alist2 + #:key (heading "")) + "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." + (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) (unless (and (null? new) (null? upgraded)) (display heading)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 569b826acd..d67b9f8185 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -23,7 +23,7 @@ (define-module (guix scripts system) #:use-module (guix config) #:use-module (guix ui) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix store) #:autoload (guix store database) (register-path) #:use-module (guix grafts) @@ -36,6 +36,8 @@ #:use-module (guix profiles) #:use-module (guix scripts) #:use-module (guix scripts build) + #:autoload (guix scripts package) (delete-generations + delete-matching-generations) #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix build utils) @@ -490,7 +492,8 @@ STORE is an open connection to the store." ;; Make the specified system generation the default entry. (params (profile-boot-parameters %system-profile (list number))) - (old-generations (delv number (generation-numbers %system-profile))) + (old-generations + (delv number (reverse (generation-numbers %system-profile)))) (old-params (profile-boot-parameters %system-profile old-generations)) (entries (map boot-parameters->menu-entry params)) @@ -963,9 +966,11 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ "\ roll-back switch to the previous operating system configuration\n")) (display (G_ "\ + list-generations list the system generations\n")) + (display (G_ "\ switch-generation switch to an existing operating system configuration\n")) (display (G_ "\ - list-generations list the system generations\n")) + delete-generations delete old system generations\n")) (display (G_ "\ build build the operating system without installing anything\n")) (display (G_ "\ @@ -1202,6 +1207,14 @@ argument list and OPTS is the option alist." (apply (resolve-subcommand "search") args)) ;; The following commands need to use the store, but they do not need an ;; operating system configuration file. + ((delete-generations) + (let ((pattern (match args + (() "") + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store store + (delete-matching-generations store %system-profile pattern) + (reinstall-bootloader store (generation-number %system-profile))))) ((switch-generation) (let ((pattern (match args ((pattern) pattern) @@ -1228,7 +1241,8 @@ argument list and OPTS is the option alist." (let ((action (string->symbol arg))) (case action ((build container vm vm-image disk-image reconfigure init - extension-graph shepherd-graph list-generations roll-back + extension-graph shepherd-graph + list-generations delete-generations roll-back switch-generation search docker-image) (alist-cons 'action action result)) (else (leave (G_ "~a: unknown action~%") action)))))) diff --git a/guix/self.scm b/guix/self.scm index a45470a0a6..ccff9be5b3 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -390,6 +390,10 @@ that provide Guile modules." guile (guile-version (effective-version))) "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its load path." + (define glibc-utf8-locales + (module-ref (resolve-interface '(gnu packages base)) + 'glibc-utf8-locales)) + (define module-directory ;; To minimize the number of 'stat' calls needed to locate a module, ;; create the union of all the module directories. @@ -410,6 +414,16 @@ load path." "/site-ccache") %load-compiled-path)) + ;; To maximize the chances that locales are set up right + ;; out-of-the-box, bundle "common" UTF-8 locales. + (let ((locpath (getenv "GUIX_LOCPATH"))) + (setenv "GUIX_LOCPATH" + (string-append (if locpath + (string-append locpath ":") + "") + #$(file-append glibc-utf8-locales + "/lib/locale")))) + (let ((guix-main (module-ref (resolve-interface '(guix ui)) 'guix-main))) #$(if source @@ -757,7 +771,7 @@ Info manual." ((_ variable rest ...) (cons `(variable . ,variable) (variables rest ...)))))) - (variables %localstatedir %storedir %sysconfdir %system))) + (variables %localstatedir %storedir %sysconfdir))) (define* (make-config.scm #:key zlib gzip xz bzip2 (package-name "GNU Guix") @@ -775,6 +789,7 @@ Info manual." %guix-version %guix-bug-report-address %guix-home-page-url + %system %store-directory %state-directory %store-database-directory @@ -784,6 +799,9 @@ Info manual." %bzip2 %xz)) + (define %system + #$(%current-system)) + #$@(map (match-lambda ((name . value) #~(define-public #$name #$value))) diff --git a/guix/status.scm b/guix/status.scm index cd5027ef17..bddaa003db 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -506,6 +506,7 @@ addition to build events." (match event (('build-started drv . _) + (erase-current-line*) (let ((properties (derivation-properties (read-derivation-from-file drv)))) (match (assq-ref properties 'type) @@ -552,10 +553,12 @@ addition to build events." (format port (info (G_ "View build log at '~a'.")) log))) (newline port)) (('substituter-started item _ ...) + (erase-current-line*) (when (or print-log? (not (extended-build-trace-supported?))) (format port (info (G_ "substituting ~a...")) item) (newline port))) (('download-started item uri _ ...) + (erase-current-line*) (format port (info (G_ "downloading from ~a...")) uri) (newline port)) (('download-progress item uri diff --git a/guix/ui.scm b/guix/ui.scm index f0465519b6..2fc001d2eb 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -374,9 +374,16 @@ ARGS is the list of arguments received by the 'throw' handler." (report-error (G_ "exception thrown: ~s~%") obj)) (when (fix-hint? obj) (display-hint (condition-fix-hint obj)))) - ((error args ...) + ((key args ...) (report-error (G_ "failed to load '~a':~%") file) - (apply display-error frame (current-error-port) args)))) + (match args + (((? symbol? proc) (? string? message) (args ...) . rest) + (display-error frame (current-error-port) proc message + args rest)) + (_ + ;; Some exceptions like 'git-error' do not follow Guile's convention + ;; above and need to be printed with 'print-exception'. + (print-exception (current-error-port) frame key args)))))) (define (warn-about-load-error file args) ;FIXME: factorize with ↑ "Report the failure to load FILE, a user-provided Scheme file, without |