diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/gexp.scm | 59 | ||||
| -rw-r--r-- | guix/import/cpan.scm | 6 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 121 | ||||
| -rw-r--r-- | guix/import/utils.scm | 10 | ||||
| -rw-r--r-- | guix/inferior.scm | 21 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 161 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 71 |
7 files changed, 309 insertions, 140 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index a657921741..133e0f5679 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -82,6 +82,9 @@ raw-derivation-file raw-derivation-file? + with-parameters + parameterized? + load-path-expression gexp-modules @@ -523,6 +526,62 @@ SUFFIX." (base (expand base lowered output))) (string-append base (string-concatenate suffix))))))) +;; Representation of SRFI-39 parameter settings in the dynamic scope of an +;; object lowering. +(define-record-type <parameterized> + (parameterized bindings thunk) + parameterized? + (bindings parameterized-bindings) ;list of parameter/value pairs + (thunk parameterized-thunk)) ;thunk + +(define-syntax-rule (with-parameters ((param value) ...) body ...) + "Bind each PARAM to the corresponding VALUE for the extent during which BODY +is lowered. Consider this example: + + (with-parameters ((%current-system \"x86_64-linux\")) + coreutils) + +It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to +x86_64-linux when COREUTILS is lowered." + (parameterized (list (list param (lambda () value)) ...) + (lambda () + body ...))) + +(define-gexp-compiler compile-parameterized <parameterized> + compiler => + (lambda (parameterized system target) + (match (parameterized-bindings parameterized) + (((parameters values) ...) + (let ((fluids (map parameter-fluid parameters)) + (thunk (parameterized-thunk parameterized))) + ;; Install the PARAMETERS for the dynamic extent of THUNK. + (with-fluids* fluids + (map (lambda (thunk) (thunk)) values) + (lambda () + ;; Special-case '%current-system' and '%current-target-system' to + ;; make sure we get the desired effect. + (let ((system (if (memq %current-system parameters) + (%current-system) + system)) + (target (if (memq %current-target-system parameters) + (%current-target-system) + target))) + (lower-object (thunk) system #:target target)))))))) + + expander => (lambda (parameterized lowered output) + (match (parameterized-bindings parameterized) + (((parameters values) ...) + (let ((fluids (map parameter-fluid parameters)) + (thunk (parameterized-thunk parameterized))) + ;; Install the PARAMETERS for the dynamic extent of THUNK. + (with-fluids* fluids + (map (lambda (thunk) (thunk)) values) + (lambda () + ;; Delegate to the expander of the wrapped object. + (let* ((base (thunk)) + (expand (lookup-expander base))) + (expand base lowered output))))))))) + ;;; ;;; Inputs & outputs. diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 7a97c7f8e8..6bcd2ce9eb 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -181,9 +181,9 @@ return \"Test-Simple\"" or #f on failure. MODULE should be the distribution name, such as \"Test-Script\" for the \"Test::Script\" module." ;; This API always returns the latest release of the module. - (json->cpan-release - (json-fetch (string-append (%metacpan-base-url) "/release/" - name)))) + (and=> (json-fetch (string-append (%metacpan-base-url) "/release/" + name)) + json->cpan-release)) (define (cpan-home name) (string-append "https://metacpan.org/release/" name)) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 10450155a0..f93fa8831f 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> -;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> @@ -43,6 +43,7 @@ #:use-module (guix import utils) #:use-module ((guix download) #:prefix download:) #:use-module (guix import json) + #:use-module (guix json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module ((guix licenses) #:prefix license:) @@ -55,10 +56,67 @@ pypi->guix-package %pypi-updater)) +;; The PyPI API (notice the rhyme) is "documented" at: +;; <https://warehouse.readthedocs.io/api-reference/json/>. + +(define non-empty-string-or-false + (match-lambda + ("" #f) + ((? string? str) str) + ((or #nil #f) #f))) + +;; PyPI project. +(define-json-mapping <pypi-project> make-pypi-project pypi-project? + json->pypi-project + (info pypi-project-info "info" json->project-info) ;<project-info> + (last-serial pypi-project-last-serial "last_serial") ;integer + (releases pypi-project-releases "releases" ;string/<distribution>* pairs + (match-lambda + (((versions . dictionaries) ...) + (map (lambda (version vector) + (cons version + (map json->distribution + (vector->list vector)))) + versions dictionaries)))) + (distributions pypi-project-distributions "urls" ;<distribution>* + (lambda (vector) + (map json->distribution (vector->list vector))))) + +;; Project metadata. +(define-json-mapping <project-info> make-project-info project-info? + json->project-info + (name project-info-name) ;string + (author project-info-author) ;string + (maintainer project-info-maintainer) ;string + (classifiers project-info-classifiers ;list of strings + "classifiers" vector->list) + (description project-info-description) ;string + (summary project-info-summary) ;string + (keywords project-info-keywords) ;string + (license project-info-license) ;string + (download-url project-info-download-url ;string | #f + "download_url" non-empty-string-or-false) + (home-page project-info-home-page ;string + "home_page") + (url project-info-url "project_url") ;string + (release-url project-info-release-url "release_url") ;string + (version project-info-version)) ;string + +;; Distribution: a URL along with cryptographic hashes and metadata. +(define-json-mapping <distribution> make-distribution distribution? + json->distribution + (url distribution-url) ;string + (digests distribution-digests) ;list of string pairs + (file-name distribution-file-name "filename") ;string + (has-signature? distribution-has-signature? "hash_sig") ;Boolean + (package-type distribution-package-type "packagetype") ;"bdist_wheel" | ... + (python-version distribution-package-python-version + "python_version")) + (define (pypi-fetch name) - "Return an alist representation of the PyPI metadata for the package NAME, -or #f on failure." - (json-fetch (string-append "https://pypi.org/pypi/" name "/json"))) + "Return a <pypi-project> record for package NAME, or #f on failure." + (and=> (json-fetch (string-append "https://pypi.org/pypi/" name "/json")) + json->pypi-project)) ;; For packages found on PyPI that lack a source distribution. (define-condition-type &missing-source-error &error @@ -67,22 +125,24 @@ or #f on failure." (define (latest-source-release pypi-package) "Return the latest source release for PYPI-PACKAGE." - (let ((releases (assoc-ref* pypi-package "releases" - (assoc-ref* pypi-package "info" "version")))) + (let ((releases (assoc-ref (pypi-project-releases pypi-package) + (project-info-version + (pypi-project-info pypi-package))))) (or (find (lambda (release) - (string=? "sdist" (assoc-ref release "packagetype"))) - (vector->list releases)) + (string=? "sdist" (distribution-package-type release))) + releases) (raise (condition (&missing-source-error (package pypi-package))))))) (define (latest-wheel-release pypi-package) "Return the url of the wheel for the latest release of pypi-package, or #f if there isn't any." - (let ((releases (assoc-ref* pypi-package "releases" - (assoc-ref* pypi-package "info" "version")))) + (let ((releases (assoc-ref (pypi-project-releases pypi-package) + (project-info-version + (pypi-project-info pypi-package))))) (or (find (lambda (release) - (string=? "bdist_wheel" (assoc-ref release "packagetype"))) - (vector->list releases)) + (string=? "bdist_wheel" (distribution-package-type release))) + releases) #f))) (define (python->package-name name) @@ -411,23 +471,25 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (lambda* (package-name) "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." - (let ((package (pypi-fetch package-name))) - (and package + (let* ((project (pypi-fetch package-name)) + (info (and project (pypi-project-info project)))) + (and project (guard (c ((missing-source-error? c) (let ((package (missing-source-error-package c))) (leave (G_ "no source release for pypi package ~a ~a~%") - (assoc-ref* package "info" "name") - (assoc-ref* package "info" "version"))))) - (let ((name (assoc-ref* package "info" "name")) - (version (assoc-ref* package "info" "version")) - (release (assoc-ref (latest-source-release package) "url")) - (wheel (assoc-ref (latest-wheel-release package) "url")) - (synopsis (assoc-ref* package "info" "summary")) - (description (assoc-ref* package "info" "summary")) - (home-page (assoc-ref* package "info" "home_page")) - (license (string->license (assoc-ref* package "info" "license")))) - (make-pypi-sexp name version release wheel home-page synopsis - description license)))))))) + (project-info-name info) + (project-info-version info))))) + (make-pypi-sexp (project-info-name info) + (project-info-version info) + (and=> (latest-source-release project) + distribution-url) + (and=> (latest-wheel-release project) + distribution-url) + (project-info-home-page info) + (project-info-summary info) + (project-info-summary info) + (string->license + (project-info-license info))))))))) (define (pypi-recursive-import package-name) (recursive-import package-name #f @@ -472,9 +534,10 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (pypi-package (pypi-fetch pypi-name))) (and pypi-package (guard (c ((missing-source-error? c) #f)) - (let* ((metadata pypi-package) - (version (assoc-ref* metadata "info" "version")) - (url (assoc-ref (latest-source-release metadata) "url"))) + (let* ((info (pypi-project-info pypi-package)) + (version (project-info-version info)) + (url (distribution-url + (latest-source-release pypi-package)))) (upstream-source (package (package-name package)) (version version) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index d17d400ddf..94c8cb040b 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net> @@ -47,7 +47,6 @@ #:export (factorize-uri flatten - assoc-ref* url-fetch guix-hash-url @@ -110,13 +109,6 @@ of the string VERSION is replaced by the symbol 'version." (cons elem memo))) '() lst)) -(define (assoc-ref* alist key . rest) - "Return the value for KEY from ALIST. For each additional key specified, -recursively apply the procedure to the sub-list." - (if (null? rest) - (assoc-ref alist key) - (apply assoc-ref* (assoc-ref alist key) rest))) - (define (url-fetch url file-name) "Save the contents of URL to FILE-NAME. Return #f on failure." (parameterize ((current-output-port (current-error-port))) diff --git a/guix/inferior.scm b/guix/inferior.scm index 0236fb61ad..6b685ece30 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -63,6 +63,9 @@ inferior-eval inferior-eval-with-store inferior-object? + inferior-exception? + inferior-exception-arguments + inferior-exception-inferior read-repl-response inferior-packages @@ -195,8 +198,15 @@ equivalent. Return #f if the inferior could not be launched." (set-record-type-printer! <inferior-object> write-inferior-object) -(define (read-repl-response port) - "Read a (guix repl) response from PORT and return it as a Scheme object." +;; Reified exception thrown by an inferior. +(define-condition-type &inferior-exception &error + inferior-exception? + (arguments inferior-exception-arguments) ;key + arguments + (inferior inferior-exception-inferior)) ;<inferior> | #f + +(define* (read-repl-response port #:optional inferior) + "Read a (guix repl) response from PORT and return it as a Scheme object. +Raise '&inferior-exception' when an exception is read from PORT." (define sexp->object (match-lambda (('value value) @@ -208,10 +218,13 @@ equivalent. Return #f if the inferior could not be launched." (('values objects ...) (apply values (map sexp->object objects))) (('exception key objects ...) - (apply throw key (map sexp->object objects))))) + (raise (condition (&inferior-exception + (arguments (cons key (map sexp->object objects))) + (inferior inferior))))))) (define (read-inferior-response inferior) - (read-repl-response (inferior-socket inferior))) + (read-repl-response (inferior-socket inferior) + inferior)) (define (send-inferior-request exp inferior) (write exp (inferior-socket inferior)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index c8d8546e29..652b4c63c4 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -365,6 +365,21 @@ added to the pack." (define database #+database) (define entry-point #$entry-point) + (define (mksquashfs args) + (apply invoke "mksquashfs" + `(,@args + + ;; Do not create a "recovery file" when appending to the + ;; file system since it's useless in this case. + "-no-recovery" + + ;; Set file times and the file system creation time to + ;; one second after the Epoch. + "-all-time" "1" "-mkfs-time" "1" + + ;; Reset all UIDs and GIDs. + "-force-uid" "0" "-force-gid" "0"))) + (setenv "PATH" (string-append #$archiver "/bin")) ;; We need an empty file in order to have a valid file argument when @@ -376,92 +391,90 @@ added to the pack." ;; Add all store items. Unfortunately mksquashfs throws away all ;; ancestor directories and only keeps the basename. We fix this ;; in the following invocations of mksquashfs. - (apply invoke "mksquashfs" - `(,@(map store-info-item - (call-with-input-file "profile" - read-reference-graph)) - #$environment - ,#$output - - ;; Do not perform duplicate checking because we - ;; don't have any dupes. - "-no-duplicates" - "-comp" - ,#+(compressor-name compressor))) + (mksquashfs `(,@(map store-info-item + (call-with-input-file "profile" + read-reference-graph)) + #$environment + ,#$output + + ;; Do not perform duplicate checking because we + ;; don't have any dupes. + "-no-duplicates" + "-comp" + ,#+(compressor-name compressor))) ;; Here we reparent the store items. For each sub-directory of ;; the store prefix we need one invocation of "mksquashfs". (for-each (lambda (dir) - (apply invoke "mksquashfs" - `(".empty" - ,#$output - "-root-becomes" ,dir))) + (mksquashfs `(".empty" + ,#$output + "-root-becomes" ,dir))) (reverse (string-tokenize (%store-directory) (char-set-complement (char-set #\/))))) ;; Add symlinks and mount points. - (apply invoke "mksquashfs" - `(".empty" - ,#$output - ;; Create SYMLINKS via pseudo file definitions. - ,@(append-map - (match-lambda - ((source '-> target) - ;; Create relative symlinks to work around a bug in - ;; Singularity 2.x: - ;; https://bugs.gnu.org/34913 - ;; https://github.com/sylabs/singularity/issues/1487 - (let ((target (string-append #$profile "/" target))) - (list "-p" - (string-join - ;; name s mode uid gid symlink - (list source - "s" "777" "0" "0" - (relative-file-name (dirname source) - target))))))) - '#$symlinks*) - - "-p" "/.singularity.d d 555 0 0" - - ;; Create the environment file. - "-p" "/.singularity.d/env d 555 0 0" - "-p" ,(string-append - "/.singularity.d/env/90-environment.sh s 777 0 0 " - (relative-file-name "/.singularity.d/env" - #$environment)) - - ;; Create /.singularity.d/actions, and optionally the 'run' - ;; script, used by 'singularity run'. - "-p" "/.singularity.d/actions d 555 0 0" - - ,@(if entry-point - `(;; This one if for Singularity 2.x. - "-p" - ,(string-append - "/.singularity.d/actions/run s 777 0 0 " - (relative-file-name "/.singularity.d/actions" - (string-append #$profile "/" - entry-point))) - - ;; This one is for Singularity 3.x. - "-p" - ,(string-append - "/.singularity.d/runscript s 777 0 0 " - (relative-file-name "/.singularity.d" - (string-append #$profile "/" - entry-point)))) - '()) - - ;; Create empty mount points. - "-p" "/proc d 555 0 0" - "-p" "/sys d 555 0 0" - "-p" "/dev d 555 0 0" - "-p" "/home d 555 0 0")) + (mksquashfs + `(".empty" + ,#$output + ;; Create SYMLINKS via pseudo file definitions. + ,@(append-map + (match-lambda + ((source '-> target) + ;; Create relative symlinks to work around a bug in + ;; Singularity 2.x: + ;; https://bugs.gnu.org/34913 + ;; https://github.com/sylabs/singularity/issues/1487 + (let ((target (string-append #$profile "/" target))) + (list "-p" + (string-join + ;; name s mode uid gid symlink + (list source + "s" "777" "0" "0" + (relative-file-name (dirname source) + target))))))) + '#$symlinks*) + + "-p" "/.singularity.d d 555 0 0" + + ;; Create the environment file. + "-p" "/.singularity.d/env d 555 0 0" + "-p" ,(string-append + "/.singularity.d/env/90-environment.sh s 777 0 0 " + (relative-file-name "/.singularity.d/env" + #$environment)) + + ;; Create /.singularity.d/actions, and optionally the 'run' + ;; script, used by 'singularity run'. + "-p" "/.singularity.d/actions d 555 0 0" + + ,@(if entry-point + `(;; This one if for Singularity 2.x. + "-p" + ,(string-append + "/.singularity.d/actions/run s 777 0 0 " + (relative-file-name "/.singularity.d/actions" + (string-append #$profile "/" + entry-point))) + + ;; This one is for Singularity 3.x. + "-p" + ,(string-append + "/.singularity.d/runscript s 777 0 0 " + (relative-file-name "/.singularity.d" + (string-append #$profile "/" + entry-point)))) + '()) + + ;; Create empty mount points. + "-p" "/proc d 555 0 0" + "-p" "/sys d 555 0 0" + "-p" "/dev d 555 0 0" + "-p" "/home d 555 0 0")) (when database ;; Initialize /var/guix. (install-database-and-gc-roots "var-etc" database #$profile) - (invoke "mksquashfs" "var-etc" #$output))))) + (mksquashfs `("var-etc" ,#$output)))))) (gexp->derivation (string-append name (compressor-extension compressor) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 629844768a..a9e0cba92a 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -175,8 +175,11 @@ about the derivations queued, as is the case with Hydra." #f ;no derivation information (lset-intersection string=? queued items))) -(define (report-server-coverage server items) - "Report the subset of ITEMS available as substitutes on SERVER." +(define* (report-server-coverage server items + #:key display-missing?) + "Report the subset of ITEMS available as substitutes on SERVER. +When DISPLAY-MISSING? is true, display the list of missing substitutes. +Return the coverage ratio, an exact number between 0 and 1." (define MiB (* (expt 2 20) 1.)) (format #t (G_ "looking for ~h store items on ~a...~%") @@ -260,7 +263,16 @@ are queued~%") system (* (throughput builds build-timestamp) 3600.)))) - (histogram build-system cons '() latest))))))) + (histogram build-system cons '() latest)))) + + (when (and display-missing? (not (null? missing))) + (newline) + (format #t (G_ "Substitutes are missing for the following items:~%")) + (format #t "~{ ~a~%~}" missing)) + + ;; Return the coverage ratio. + (let ((total (length items))) + (/ (- total (length missing)) total))))) ;;; @@ -281,6 +293,8 @@ Report the availability of substitutes.\n")) show substitute coverage for packages with at least COUNT dependents")) (display (G_ " + --display-missing display the list of missing substitutes")) + (display (G_ " -s, --system=SYSTEM consider substitutes for SYSTEM--e.g., \"i686-linux\"")) (newline) (display (G_ " @@ -318,6 +332,9 @@ Report the availability of substitutes.\n")) (alist-cons 'coverage (if arg (string->number* arg) 0) result))) + (option '("display-missing") #f #f + (lambda (opt name arg result) + (alist-cons 'display-missing? #t result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg result))))) @@ -487,17 +504,19 @@ SERVER. Display information for packages with at least THRESHOLD dependents." (define (guix-weather . args) (define (package-list opts) ;; Return the package list specified by OPTS. - (let ((file (assoc-ref opts 'manifest)) - (base (filter-map (match-lambda - (('argument . spec) - (specification->package spec)) - (_ - #f)) - opts))) - (if (and (not file) (null? base)) + (let ((files (filter-map (match-lambda + (('manifest . file) file) + (_ #f)) + opts)) + (base (filter-map (match-lambda + (('argument . spec) + (specification->package spec)) + (_ + #f)) + opts))) + (if (and (null? files) (null? base)) (all-packages) - (append base - (if file (load-manifest file) '()))))) + (append base (append-map load-manifest files))))) (with-error-handling (parameterize ((current-terminal-columns (terminal-columns)) @@ -524,14 +543,24 @@ SERVER. Display information for packages with at least THRESHOLD dependents." (lambda (system) (package-outputs packages system)) systems)))))) - (for-each (lambda (server) - (report-server-coverage server items) - (match (assoc-ref opts 'coverage) - (#f #f) - (threshold - (report-package-coverage server packages systems - #:threshold threshold)))) - urls))))) + (exit + (every (lambda (server) + (define coverage + (report-server-coverage server items + #:display-missing? + (assoc-ref opts 'display-missing?))) + (match (assoc-ref opts 'coverage) + (#f #f) + (threshold + ;; PACKAGES may include non-package objects coming from a + ;; manifest. Filter them out. + (report-package-coverage server + (filter package? packages) + systems + #:threshold threshold))) + + (= 1 coverage)) + urls)))))) ;;; Local Variables: ;;; eval: (put 'let/time 'scheme-indent-function 1) |