diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/r.scm | 2 | ||||
| -rw-r--r-- | guix/import/cran.scm | 4 | ||||
| -rw-r--r-- | guix/import/egg.scm | 37 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 7 | ||||
| -rw-r--r-- | guix/profiles.scm | 110 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 48 | ||||
| -rw-r--r-- | guix/scripts/home/import.scm | 24 | ||||
| -rw-r--r-- | guix/scripts/import/egg.scm | 34 | ||||
| -rw-r--r-- | guix/scripts/shell.scm | 16 | ||||
| -rw-r--r-- | guix/ui.scm | 3 |
10 files changed, 237 insertions, 48 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index be6a600c28..2c82390ba6 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -61,7 +61,7 @@ release corresponding to NAME and VERSION." "/src/contrib/" name "_" version ".tar.gz") ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.13" + (string-append "https://bioconductor.org/packages/3.14" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 9387a82065..420cd3b63a 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -155,9 +155,9 @@ package definition." (define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.13. Bioconductor packages should be +;; The latest Bioconductor release is 3.14. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.13") +(define %bioconductor-version "3.14") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" diff --git a/guix/import/egg.scm b/guix/import/egg.scm index 75b7659944..0b88020554 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -52,10 +52,10 @@ ;;; ;;; The following happens under the hood: ;;; -;;; * <git://code.call-cc.org/eggs-5-latest> is a Git repository that contains -;;; the latest version of all CHICKEN eggs. We look clone this repository -;;; and retrieve the latest version number, and the PACKAGE.egg file, which -;;; contains a list of lists containing metadata about the egg. +;;; * <git://code.call-cc.org/eggs-5-all> is a Git repository that contains +;;; all versions of all CHICKEN eggs. We look clone this repository and, by +;;; default, retrieve the latest version number, and the PACKAGE.egg file, +;;; which contains a list of lists containing metadata about the egg. ;;; ;;; * All the eggs are stored as tarballs at ;;; <https://code.call-cc.org/egg-tarballs/5>, so we grab the tarball for @@ -97,7 +97,7 @@ NAME." (define (eggs-repository) "Update or fetch the latest version of the eggs repository and return the path to the repository." - (let* ((url "git://code.call-cc.org/eggs-5-latest") + (let* ((url "git://code.call-cc.org/eggs-5-all") (directory commit _ (update-cached-checkout url))) directory)) @@ -113,12 +113,13 @@ to the repository." (last directory) #f))) -(define* (egg-metadata name #:optional file) - "Return the package metadata file for the egg NAME, or if FILE is specified, -return the package metadata in FILE." +(define* (egg-metadata name #:key (version #f) (file #f)) + "Return the package metadata file for the egg NAME at version VERSION, or if +FILE is specified, return the package metadata in FILE." (call-with-input-file (or file (string-append (egg-directory name) "/" - (find-latest-version name) + (or version + (find-latest-version name)) "/" name ".egg")) read)) @@ -174,10 +175,11 @@ return the package metadata in FILE." ;;; Egg importer. ;;; -(define* (egg->guix-package name #:key (file #f) (source #f)) - "Import a CHICKEN egg called NAME from either the given .egg FILE, or from -the latest NAME metadata downloaded from the official repository if FILE is #f. -Return a <package> record or #f on failure. +(define* (egg->guix-package name version #:key (file #f) (source #f)) + "Import a CHICKEN egg called NAME from either the given .egg FILE, or from the +latest NAME metadata downloaded from the official repository if FILE is #f. +Return a <package> record or #f on failure. If VERSION is specified, import +the particular version from the egg repository. SOURCE is a ``file-like'' object containing the source code corresponding to the egg. If SOURCE is not specified, the latest tarball for egg NAME will be @@ -187,8 +189,8 @@ Specifying the SOURCE argument is mainly useful for developing a CHICKEN egg locally. Note that if FILE and SOURCE are specified, recursive import will not work." (define egg-content (if file - (egg-metadata name file) - (egg-metadata name))) + (egg-metadata name #:file file) + (egg-metadata name #:version version))) (if (not egg-content) (values #f '()) ; egg doesn't exist (let* ((version* (or (assoc-ref egg-content 'version) @@ -324,10 +326,11 @@ not work." (define egg->guix-package/m ;memoized variant (memoize egg->guix-package)) -(define (egg-recursive-import package-name) +(define* (egg-recursive-import package-name #:optional version) (recursive-import package-name + #:version version #:repo->guix-package (lambda* (name #:key version repo) - (egg->guix-package/m name)) + (egg->guix-package/m name version)) #:guix-name egg-name->guix-name)) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 05b4a45f2f..d20e274db7 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -337,9 +337,10 @@ the package named PACKAGE-NAME." type '<elpa-package>'." (define melpa-recipe - (if (eq? repo 'melpa) - (package-name->melpa-recipe (elpa-package-name pkg)) - #f)) + ;; XXX: Call 'identity' to work around a Guile 3.0.[5-7] compiler bug: + ;; <https://bugs.gnu.org/48368>. + (and (eq? (identity repo) 'melpa) + (package-name->melpa-recipe (elpa-package-name pkg)))) (define name (elpa-package-name pkg)) diff --git a/guix/profiles.scm b/guix/profiles.scm index aad23c0c0e..dcd0d30de1 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1682,11 +1682,119 @@ the entries in MANIFEST." `((type . profile-hook) (hook . manual-database)))) +(define (manual-database/optional manifest) + "Return a derivation to build the manual database of MANIFEST, but only if +MANIFEST contains the \"man-db\" package. Otherwise, return #f." + ;; Building the man database (for "man -k") is expensive and rarely used. + ;; Build it only if the profile also contains "man-db". + (mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db"))) + (if man-db + (manual-database manifest) + (return #f)))) + +(define (texlive-configuration manifest) + "Return a derivation that builds a TeXlive configuration for the entries in +MANIFEST." + (define entry->texlive-input + (match-lambda + (($ <manifest-entry> name version output thing deps) + (if (string-prefix? "texlive-" name) + (cons (gexp-input thing output) + (append-map entry->texlive-input deps)) + '())))) + (define texlive-bin + (module-ref (resolve-interface '(gnu packages tex)) 'texlive-bin)) + (define coreutils + (module-ref (resolve-interface '(gnu packages base)) 'coreutils)) + (define sed + (module-ref (resolve-interface '(gnu packages base)) 'sed)) + (define updmap.cfg + (module-ref (resolve-interface '(gnu packages tex)) + 'texlive-default-updmap.cfg)) + (define build + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (guix build utils) + (guix build union) + (ice-9 popen)) + + ;; Build a modifiable union of all texlive inputs. We do this so + ;; that TeX live can resolve the parent and grandparent directories + ;; correctly. There might be a more elegant way to accomplish this. + (union-build #$output + '#$(append-map entry->texlive-input + (manifest-entries manifest)) + #:create-all-directories? #t + #:log-port (%make-void-port "w")) + (let ((texmf.cnf (string-append + #$output + "/share/texmf-dist/web2c/texmf.cnf"))) + (when (file-exists? texmf.cnf) + (substitute* texmf.cnf + (("^TEXMFROOT = .*") + (string-append "TEXMFROOT = " #$output "/share\n")) + (("^TEXMF = .*") + "TEXMF = $TEXMFROOT/share/texmf-dist\n")) + + ;; XXX: This is annoying, but it's necessary because texlive-bin + ;; does not provide wrapped executables. + (setenv "PATH" + (string-append #$(file-append coreutils "/bin") + ":" + #$(file-append sed "/bin"))) + (setenv "PERL5LIB" #$(file-append texlive-bin "/share/tlpkg")) + (setenv "TEXMF" (string-append #$output "/share/texmf-dist")) + + ;; Remove invalid maps from config file. + (let* ((web2c (string-append #$output "/share/texmf-config/web2c/")) + (maproot (string-append #$output "/share/texmf-dist/fonts/map/")) + (updmap.cfg (string-append web2c "updmap.cfg"))) + (mkdir-p web2c) + + ;; Some profiles may already have this file, which prevents us + ;; from copying it. Since we need to generate it from scratch + ;; anyway, we delete it here. + (when (file-exists? updmap.cfg) + (delete-file updmap.cfg)) + (copy-file #$updmap.cfg updmap.cfg) + (make-file-writable updmap.cfg) + (let* ((port (open-pipe* OPEN_WRITE + #$(file-append texlive-bin "/bin/updmap-sys") + "--syncwithtrees" + "--nohash" + "--force" + (string-append "--cnffile=" web2c "updmap.cfg")))) + (display "Y\n" port) + (when (not (zero? (status:exit-val (close-pipe port)))) + (error "failed to filter updmap.cfg"))) + + ;; Generate font maps. + (invoke #$(file-append texlive-bin "/bin/updmap-sys") + (string-append "--cnffile=" web2c "updmap.cfg") + (string-append "--dvipdfmxoutputdir=" + maproot "updmap/dvipdfmx/") + (string-append "--dvipsoutputdir=" + maproot "updmap/dvips/") + (string-append "--pdftexoutputdir=" + maproot "updmap/pdftex/"))))) + #t))) + + (mlet %store-monad ((texlive-base (manifest-lookup-package manifest "texlive-base"))) + (if texlive-base + (gexp->derivation "texlive-configuration" build + #:substitutable? #f + #:local-build? #t + #:properties + `((type . profile-hook) + (hook . texlive-configuration))) + (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. (list info-dir-file - manual-database + manual-database/optional fonts-dir-file ghc-package-cache-file ca-certificate-bundle diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index cca0ad991b..8176de4a5e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -34,6 +34,7 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix transformations) + #:autoload (ice-9 ftw) (scandir) #:autoload (gnu build linux-container) (call-with-container %namespaces user-namespace-supported? unprivileged-user-namespace-supported? @@ -401,7 +402,12 @@ regexps in WHITE-LIST." (match command ((program . args) - (apply execlp program program args)))) + (catch 'system-error + (lambda () + (apply execlp program program args)) + (lambda _ + ;; Following established convention, exit with 127 upon ENOENT. + (primitive-_exit 127)))))) (define (child-shell-environment shell profile manifest) "Create a child process, load PROFILE and MANIFEST, and then run SHELL in @@ -552,6 +558,38 @@ running in a \"container\", immune to the issue described above.")) (info (G_ "All is good! The shell gets correct environment \ variables.~%"))))) +(define (suggest-command-name profile command) + "COMMAND was not found in PROFILE so display a hint suggesting the closest +command name." + (define not-dot? + (match-lambda + ((or "." "..") #f) + (_ #t))) + + (match (scandir (string-append profile "/bin") not-dot?) + (() #f) + (available + (match command + ((executable _ ...) + ;; Look for a suggestion with a high threshold: a suggestion is + ;; usually better than no suggestion. + (let ((closest (string-closest executable available + #:threshold 12))) + (unless (or (not closest) (string=? closest executable)) + (display-hint (format #f (G_ "Did you mean '~a'?~%") + closest))))))))) + +(define (validate-exit-status profile command status) + "When STATUS, an integer as returned by 'waitpid', is 127, raise a \"command +not found\" error. Otherwise return STATUS." + ;; Most likely, exit value 127 means ENOENT. + (when (eqv? (status:exit-val status) 127) + (report-error (G_ "~a: command not found~%") + (first command)) + (suggest-command-name profile command) + (exit 1)) + status) + (define* (launch-environment/fork command profile manifest #:key pure? (white-list '())) "Run COMMAND in a new process with an environment containing PROFILE, with @@ -563,7 +601,8 @@ regexps in WHITE-LIST." #:pure? pure? #:white-list white-list)) (pid (match (waitpid pid) - ((_ . status) status))))) + ((_ . status) + (validate-exit-status profile command status)))))) (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? @@ -584,6 +623,9 @@ WHILE-LIST." (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) + (define (exit/status* status) + (exit/status (validate-exit-status profile command status))) + (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -640,7 +682,7 @@ WHILE-LIST." '()) (map file-system-mapping->bind-mount mappings)))) - (exit/status + (exit/status* (call-with-container file-systems (lambda () ;; Setup global shell. diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 7a7712dd96..fbf89069a7 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -27,6 +27,9 @@ #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 popen) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (import-manifest @@ -56,12 +59,33 @@ FILE-NAME with \"-\", and return the basename of it." (define (destination-append path) (string-append destination-directory "/" path)) + (define (bash-alias->pair line) + (if (string-prefix? "alias" line) + (let ((matched (string-match "alias (.+)=\"?'?([^\"']+)\"?'?" line))) + `(,(match:substring matched 1) . ,(match:substring matched 2))) + '())) + + (define (parse-aliases input) + (let loop ((line (read-line input)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line input) + (cons (bash-alias->pair line) result))))) + (let ((rc (destination-append ".bashrc")) (profile (destination-append ".bash_profile")) (logout (destination-append ".bash_logout"))) `((service home-bash-service-type (home-bash-configuration ,@(if (file-exists? rc) + `((aliases + ',(let* ((port (open-pipe* OPEN_READ "bash" "-i" "-c" "alias")) + (alist (parse-aliases port))) + (close-port port) + (filter (negate null?) alist)))) + '()) + ,@(if (file-exists? rc) `((bashrc (list (local-file ,rc ,(basename+remove-dots rc))))) diff --git a/guix/scripts/import/egg.scm b/guix/scripts/import/egg.scm index 829cdc2ca0..6a9657d12c 100644 --- a/guix/scripts/import/egg.scm +++ b/guix/scripts/import/egg.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-egg)) @@ -83,21 +84,24 @@ Import and convert the egg package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) - (egg-recursive-import package-name)) - ;; Single import - (let ((sexp (egg->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (egg-recursive-import name version)) + ;; Single import + (let ((sexp (egg->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/shell.scm b/guix/scripts/shell.scm index 5749485a44..bd62803cb1 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -387,8 +387,14 @@ echo ~a >> ~a (display-hint (G_ "Consider passing the @option{--check} option once to make sure your shell does not clobber environment variables."))) ) - (let ((result (guix-environment* opts))) - (maybe-remove-expired-cache-entries (%profile-cache-directory) - cache-entries - #:entry-expiration entry-expiration) - result)) + ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use + ;; of cached profiles, and (2) cleanup actually happens, even when + ;; 'guix-environment*' calls 'exit'. + (add-hook! exit-hook + (lambda _ + (maybe-remove-expired-cache-entries + (%profile-cache-directory) + cache-entries + #:entry-expiration entry-expiration))) + + (guix-environment* opts)) diff --git a/guix/ui.scm b/guix/ui.scm index b01bb3d587..bd999103ff 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -377,7 +377,8 @@ ARGS is the list of arguments received by the 'throw' handler." (+ 2 (string-contains message ": "))))) (format (current-error-port) (G_ "~amissing closing parenthesis~%") location)) - (apply throw args))) + (report-error (G_ "read error while loading '~a': ~a~%") + file (apply format #f message args)))) (('syntax-error proc message properties form subform . rest) (let ((loc (source-properties->location properties))) (report-error loc (G_ "~s: ~a~%") |