diff options
author | Marius Bakke <marius@gnu.org> | 2021-06-06 21:16:32 +0200 |
---|---|---|
committer | Marius Bakke <marius@gnu.org> | 2021-06-06 21:16:32 +0200 |
commit | 8d59c262ada2e2167196a8fb8cbebd9c329a79dd (patch) | |
tree | 85a74de8cc23a2f0179c0b9f0adfa4c274449a0c /guix | |
parent | e7f0835b07d868fd447aa64c873174fa385e1699 (diff) | |
parent | a068ed6a5f5b3535fce49ac4eca1fec82edd6fdc (diff) | |
download | guix-patches-8d59c262ada2e2167196a8fb8cbebd9c329a79dd.tar guix-patches-8d59c262ada2e2167196a8fb8cbebd9c329a79dd.tar.gz |
Merge branch 'master' into core-updates
Conflicts:
gnu/local.mk
gnu/packages/algebra.scm
gnu/packages/bioinformatics.scm
gnu/packages/curl.scm
gnu/packages/docbook.scm
gnu/packages/emacs-xyz.scm
gnu/packages/maths.scm
gnu/packages/plotutils.scm
gnu/packages/python-web.scm
gnu/packages/python-xyz.scm
gnu/packages/radio.scm
gnu/packages/readline.scm
gnu/packages/tls.scm
gnu/packages/xml.scm
gnu/packages/xorg.scm
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/r.scm | 2 | ||||
-rw-r--r-- | guix/ci.scm | 25 | ||||
-rw-r--r-- | guix/download.scm | 1 | ||||
-rw-r--r-- | guix/git-download.scm | 79 | ||||
-rw-r--r-- | guix/gnu-maintenance.scm | 32 | ||||
-rw-r--r-- | guix/hg-download.scm | 24 | ||||
-rw-r--r-- | guix/import/cran.scm | 4 | ||||
-rw-r--r-- | guix/import/egg.scm | 352 | ||||
-rw-r--r-- | guix/import/hackage.scm | 27 | ||||
-rw-r--r-- | guix/import/opam.scm | 4 | ||||
-rw-r--r-- | guix/licenses.scm | 8 | ||||
-rw-r--r-- | guix/lint.scm | 171 | ||||
-rw-r--r-- | guix/profiles.scm | 5 | ||||
-rw-r--r-- | guix/progress.scm | 16 | ||||
-rw-r--r-- | guix/scripts/archive.scm | 3 | ||||
-rw-r--r-- | guix/scripts/build.scm | 3 | ||||
-rw-r--r-- | guix/scripts/copy.scm | 9 | ||||
-rw-r--r-- | guix/scripts/deploy.scm | 12 | ||||
-rw-r--r-- | guix/scripts/edit.scm | 4 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 3 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 5 | ||||
-rw-r--r-- | guix/scripts/import.scm | 4 | ||||
-rw-r--r-- | guix/scripts/import/egg.scm | 107 | ||||
-rw-r--r-- | guix/scripts/package.scm | 8 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 160 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 11 | ||||
-rw-r--r-- | guix/store.scm | 16 | ||||
-rw-r--r-- | guix/swh.scm | 20 | ||||
-rw-r--r-- | guix/ui.scm | 60 |
29 files changed, 950 insertions, 225 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index c4425e0a12..be6a600c28 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.12" + (string-append "https://bioconductor.org/packages/3.13" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) diff --git a/guix/ci.scm b/guix/ci.scm index c70e5bb9e6..0af04ff97d 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -100,7 +100,7 @@ json->evaluation (id evaluation-id) ;integer (spec evaluation-spec "specification") ;string - (complete? evaluation-complete? "in-progress" + (complete? evaluation-complete? "status" (match-lambda (0 #t) (_ #f))) ;Boolean @@ -154,14 +154,21 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM." (number->string evaluation))))) (json->evaluation evaluation))) -(define* (latest-evaluations url #:optional (limit %query-limit)) - "Return the latest evaluations performed by the CI server at URL." - (map json->evaluation - (vector->list - (json->scm - (http-fetch (string-append url "/api/evaluations?nr=" - (number->string limit))))))) - +(define* (latest-evaluations url + #:optional (limit %query-limit) + #:key spec) + "Return the latest evaluations performed by the CI server at URL. If SPEC +is passed, only consider the evaluations for the given SPEC specification." + (let ((spec (if spec + (format #f "&spec=~a" spec) + ""))) + (map json->evaluation + (vector->list + (json->scm + (http-fetch + (string-append url "/api/evaluations?nr=" + (number->string limit) + spec))))))) (define* (evaluations-for-commit url commit #:optional (limit %query-limit)) "Return the evaluations among the latest LIMIT evaluations that have COMMIT diff --git a/guix/download.scm b/guix/download.scm index 72094e7318..b6eb97e6fa 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -35,6 +35,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%mirrors + %disarchive-mirrors (url-fetch* . url-fetch) url-fetch/executable url-fetch/tarbomb diff --git a/guix/git-download.scm b/guix/git-download.scm index 199effece5..5e624b9ae9 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -33,6 +33,9 @@ repository-discover repository-head repository-working-directory) + #:autoload (git submodule) (repository-submodules + submodule-lookup + submodule-path) #:autoload (git commit) (commit-lookup commit-tree) #:autoload (git reference) (reference-target) #:autoload (git tree) (tree-list) @@ -194,11 +197,17 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;;; 'git-predicate'. ;;; -(define (git-file-list directory) +(define* (git-file-list directory #:optional prefix #:key (recursive? #t)) "Return the list of files checked in in the Git repository at DIRECTORY. The result is similar to that of the 'git ls-files' command, except that it -also includes directories, not just regular files. The returned file names -are relative to DIRECTORY, which is not necessarily the root of the checkout." +also includes directories, not just regular files. + +When RECURSIVE? is true, also list files in submodules, similar to the 'git +ls-files --recurse-submodules' command. This is enabled by default. + +The returned file names are relative to DIRECTORY, which is not necessarily +the root of the checkout. If a PREFIX is provided, it is prepended to each +file name." (let* (;; 'repository-working-directory' always returns a trailing "/", ;; so add one here to ease the comparisons below. (directory (string-append (canonicalize-path directory) "/")) @@ -209,33 +218,65 @@ are relative to DIRECTORY, which is not necessarily the root of the checkout." (oid (reference-target head)) (commit (commit-lookup repository oid)) (tree (commit-tree commit)) - (files (tree-list tree))) + (files (tree-list tree)) + (submodules (if recursive? + (map (lambda (name) + (submodule-path + (submodule-lookup repository name))) + (repository-submodules repository)) + '())) + (relative (and (not (string=? workdir directory)) + (string-drop directory (string-length workdir)))) + (included? (lambda (path) + (or (not relative) + (string-prefix? relative path)))) + (make-relative (lambda (path) + (if relative + (string-drop path (string-length relative)) + path))) + (add-prefix (lambda (path) + (if prefix + (string-append prefix "/" path) + path))) + (rectify (compose add-prefix make-relative))) (repository-close! repository) - (if (string=? workdir directory) - files - (let ((relative (string-drop directory (string-length workdir)))) - (filter-map (lambda (file) - (and (string-prefix? relative file) - (string-drop file (string-length relative)))) - files))))) - -(define (git-predicate directory) + (append + (if (or relative prefix) + (filter-map (lambda (file) + (and (included? file) + (rectify file))) + files) + files) + (append-map (lambda (submodule) + (if (included? submodule) + (git-file-list + (string-append workdir submodule) + (rectify submodule)) + '())) + submodules)))) + +(define* (git-predicate directory #:key (recursive? #t)) "Return a predicate that returns true if a file is part of the Git checkout living at DIRECTORY. If DIRECTORY does not lie within a Git checkout, and upon Git errors, return #f instead of a predicate. +When RECURSIVE? is true, the predicate also returns true if a file is part of +any Git submodule under DIRECTORY. This is enabled by default. + The returned predicate takes two arguments FILE and STAT where FILE is an absolute file name and STAT is the result of 'lstat'." (libgit2-init!) (catch 'git-error (lambda () - (let* ((files (git-file-list directory)) + (let* ((files (git-file-list directory #:recursive? recursive?)) (inodes (fold (lambda (file result) - (let ((stat - (lstat (string-append directory "/" - file)))) - (vhash-consv (stat:ino stat) (stat:dev stat) - result))) + (let* ((file (string-append directory "/" file)) + (stat (false-if-exception (lstat file)))) + ;; Ignore FILE if it has been deleted. + (if stat + (vhash-consv (stat:ino stat) (stat:dev stat) + result) + result))) vlist-null files))) (lambda (file stat) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index fece84b341..e7edbf6656 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -243,7 +243,8 @@ network to check in GNU's database." ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz". ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2". ;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages. - (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|zip$)")) + ;; Accept 'v' or 'V' prefix as in 'PKG-v2.3.tgz'. + (make-regexp "^([^.]+)[-_][vV]?([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|tgz|zip$)")) (define %alpha-tarball-rx (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) @@ -495,9 +496,30 @@ are unavailable." (define (url->release url) (let* ((base (basename url)) - (url (if (string=? base url) - (string-append base-url directory "/" url) - url))) + (base-url (string-append base-url directory)) + (url (cond ((and=> (string->uri url) uri-scheme) ;full URL? + url) + ((string-prefix? "/" url) ;absolute path? + (let ((uri (string->uri base-url))) + (uri->string + (build-uri (uri-scheme uri) + #:host (uri-host uri) + #:port (uri-port uri) + #:path url)))) + + ;; URL is a relative path and BASE-URL may or may not + ;; end in slash. + ((string-suffix? "/" base-url) + (string-append base-url url)) + (else + ;; If DIRECTORY is non-empty, assume BASE-URL + ;; denotes a directory; otherwise, assume BASE-URL + ;; denotes a file within a directory, and that URL + ;; is relative to that directory. + (string-append (if (string-null? directory) + (dirname base-url) + base-url) + "/" url))))) (and (release-file? package base) (let ((version (tarball->version base))) (upstream-source @@ -596,7 +618,7 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)." (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. - (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src|\\.src|\\.orig)?")) + (make-regexp "^(.*)[-_][vV]?(([0-9]|\\.)+)(-src|\\.src|\\.orig)?")) (define (gnu-package-name->name+version name+version) "Return the package name and version number extracted from NAME+VERSION." diff --git a/guix/hg-download.scm b/guix/hg-download.scm index c6cee2dbb8..eb7c345489 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,8 @@ #:use-module (guix modules) #:use-module (guix packages) #:autoload (guix build-system gnu) (standard-packages) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) @@ -34,7 +37,9 @@ hg-reference-changeset hg-reference-recursive? hg-predicate - hg-fetch)) + hg-fetch + hg-version + hg-file-name)) ;;; Commentary: ;;; @@ -102,6 +107,23 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:recursive? #t #:guile-for-build guile))) +(define (hg-version version revision changeset) + "Return the version string for packages using hg-download." + ;; hg-version is almost exclusively executed while modules are being loaded. + ;; This makes any errors hide their backtrace. Avoid the mysterious error + ;; "Value out of range 0 to N: 7" when the commit ID is too short, which + ;; can happen, for example, when the user swapped the revision and commit + ;; arguments by mistake. + (when (< (string-length changeset) 7) + (raise + (condition + (&message (message "hg-version: changeset ID unexpectedly short"))))) + (string-append version "-" revision "." (string-take changeset 7))) + +(define (hg-file-name name version) + "Return the file-name for packages using hg-download." + (string-append name "-" version "-checkout")) + (define (hg-file-list directory) "Evaluates to a list of files contained in the repository at path @var{directory}" diff --git a/guix/import/cran.scm b/guix/import/cran.scm index dbc858cb84..f649928c5a 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -153,9 +153,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.12. Bioconductor packages should be +;; The latest Bioconductor release is 3.13. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.12") +(define %bioconductor-version "3.13") (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 new file mode 100644 index 0000000000..26f8364732 --- /dev/null +++ b/guix/import/egg.scm @@ -0,0 +1,352 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; +;;; 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 import egg) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:use-module (gcrypt hash) + #:use-module (guix git) + #:use-module (guix i18n) + #:use-module (guix base32) + #:use-module (guix diagnostics) + #:use-module (guix memoization) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix build-system) + #:use-module (guix build-system chicken) + #:use-module (guix store) + #:use-module ((guix download) #:select (download-to-store url-fetch)) + #:use-module (guix import utils) + #:use-module ((guix licenses) #:prefix license:) + #:export (egg->guix-package + egg-recursive-import + %egg-updater + + ;; For tests. + guix-package->egg-name)) + +;;; Commentary: +;;; +;;; (guix import egg) provides package importer for CHICKEN eggs. See the +;;; official specification format for eggs +;;; <https://wiki.call-cc.org/man/5/Egg%20specification%20format>. +;;; +;;; 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. +;;; +;;; * All the eggs are stored as tarballs at +;;; <https://code.call-cc.org/egg-tarballs/5>, so we grab the tarball for +;;; the egg from there. +;;; +;;; * The rest of the package fields will be parsed from the PACKAGE.egg file. +;;; +;;; Todos: +;;; +;;; * Support for CHICKEN 4? +;;; +;;; * Some packages will specify a specific version of a depencency in the +;;; PACKAGE.egg file, how should we handle this? +;;; +;;; Code: + + +;;; +;;; Egg metadata fetcher and helper functions. +;;; + +(define package-name-prefix "chicken-") + +(define %eggs-url + (make-parameter "https://code.call-cc.org/egg-tarballs/5")) + +(define %eggs-home-page + (make-parameter "https://wiki.call-cc.org/egg")) + +(define (egg-source-url name version) + "Return the URL to the source tarball for version VERSION of the CHICKEN egg +NAME." + (string-append (%eggs-url) "/" name "/" name "-" version ".tar.gz")) + +(define (egg-name->guix-name name) + "Return the package name for CHICKEN egg NAME." + (string-append package-name-prefix 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") + (directory commit _ (update-cached-checkout url))) + directory)) + +(define (egg-directory name) + "Return the directory containing the source code for the egg NAME." + (let ((eggs-directory (eggs-repository))) + (string-append eggs-directory "/" name))) + +(define (find-latest-version name) + "Get the latest version of the egg NAME." + (let ((directory (scandir (egg-directory name)))) + (if directory + (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." + (call-with-input-file (or file + (string-append (egg-directory name) "/" + (find-latest-version name) + "/" name ".egg")) + read)) + +(define (guix-name->egg-name name) + "Return the CHICKEN egg name corresponding to the Guix package NAME." + (if (string-prefix? package-name-prefix name) + (string-drop name (string-length package-name-prefix)) + name)) + +(define (guix-package->egg-name package) + "Return the CHICKEN egg name of the Guix CHICKEN PACKAGE." + (or (assq-ref (package-properties package) 'upstream-name) + (guix-name->egg-name (package-name package)))) + +(define (egg-package? package) + "Check if PACKAGE is an CHICKEN egg package." + (and (eq? (package-build-system package) chicken-build-system) + (string-prefix? package-name-prefix (package-name package)))) + +(define string->license + ;; Doesn't seem to use a specific format. + ;; <https://wiki.call-cc.org/eggs-licensing> + (match-lambda + ("GPL-2" 'license:gpl2) + ("GPL-2+" 'license:gpl2+) + ("GPL-3" 'license:gpl3) + ("GPL-3+" 'license:gpl3+) + ("GPL" 'license:gpl?) + ("AGPL-3" 'license:agpl3) + ("AGPL" 'license:agpl?) + ("LGPL-2.0" 'license:lgpl2.0) + ("LGPL-2.0+" 'license:lgpl2.0+) + ("LGPL-2.1" 'license:lgpl2.1) + ("LGPL-2.1+" 'license:lgpl2.1+) + ("LGPL-3" 'license:lgpl3) + ("LGPL-3" 'license:lgpl3+) + ("LGPL" 'license:lgpl?) + ("BSD-1-Clause" 'license:bsd-1) + ("BSD-2-Clause" 'license:bsd-2) + ("BSD-3-Clause" 'license:bsd-3) + ("BSD" 'license:bsd?) + ("MIT" 'license:expat) + ("ISC" 'license:isc) + ("Artistic-2" 'license:artistic2.0) + ("Apache-2.0" 'license:asl2.0) + ("Public Domain" 'license:public-domain) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) + (_ #f))) + + +;;; +;;; Egg importer. +;;; + +(define* (egg->guix-package name #:key (file #f) (source #f)) + "Import CHICKEN egg NAME from and return a <package> record type for the +egg, or #f on failure. FILE is the filepath to the NAME.egg file. SOURCE is +the a ``file-like'' object containing the source code corresonding to the egg. +If SOURCE is not specified, the tarball for the egg will be downloaded. + +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))) + (if (not egg-content) + (values #f '()) ; egg doesn't exist + (let* ((version* (or (assoc-ref egg-content 'version) + (find-latest-version name))) + (version (if (list? version*) (first version*) version*)) + (source-url (if source #f (egg-source-url name version))) + (tarball (if source + #f + (with-store store + (download-to-store store source-url))))) + + (define egg-home-page + (string-append (%eggs-home-page) "/" name)) + + (define egg-synopsis + (match (assoc-ref egg-content 'synopsis) + ((synopsis) synopsis) + (_ #f))) + + (define egg-licenses + (let ((licenses* + (match (assoc-ref egg-content 'license) + ((license) + (map string->license (string-split license #\/))) + (#f + '())))) + (match licenses* + ((license) license) + ((license1 license2 ...) `(list ,@licenses*))))) + + (define (maybe-symbol->string sym) + (if (symbol? sym) (symbol->string sym) sym)) + + (define (prettify-system-dependency name) + ;; System dependencies sometimes have spaces and/or upper case + ;; letters in them. + ;; + ;; There will probably still be some weird edge cases. + (string-map (lambda (char) + (case char + ((#\space) #\-) + (else char))) + (maybe-symbol->string name))) + + (define* (egg-parse-dependency name #:key (system? #f)) + (define extract-name + (match-lambda + ((name version) name) + (name name))) + + (define (prettify-name name) + (if system? + (prettify-system-dependency name) + (maybe-symbol->string name))) + + (let ((name (prettify-name (extract-name name)))) + ;; Dependencies are sometimes specified as symbols and sometimes + ;; as strings + (list (string-append (if system? "" package-name-prefix) + name) + (list 'unquote + (string->symbol (string-append + (if system? "" package-name-prefix) + name)))))) + + (define egg-propagated-inputs + (let ((dependencies (assoc-ref egg-content 'dependencies))) + (if (list? dependencies) + (map egg-parse-dependency + dependencies) + '()))) + + ;; TODO: Or should these be propagated? + (define egg-inputs + (let ((dependencies (assoc-ref egg-content 'foreign-dependencies))) + (if (list? dependencies) + (map (lambda (name) + (egg-parse-dependency name #:system? #t)) + dependencies) + '()))) + + (define egg-native-inputs + (let* ((test-dependencies (or (assoc-ref egg-content + 'test-dependencies) + '())) + (build-dependencies (or (assoc-ref egg-content + 'build-dependencies) + '())) + (test+build-dependencies (append test-dependencies + build-dependencies))) + (match test+build-dependencies + ((_ _ ...) (map egg-parse-dependency + test+build-dependencies)) + (() '())))) + + ;; Copied from (guix import hackage). + (define (maybe-inputs input-type inputs) + (match inputs + (() + '()) + ((inputs ...) + (list (list input-type + (list 'quasiquote inputs)))))) + + (values + `(package + (name ,(egg-name->guix-name name)) + (version ,version) + (source + ,(if source + source + `(origin + (method url-fetch) + (uri ,source-url) + (sha256 + (base32 ,(if tarball + (bytevector->nix-base32-string + (file-sha256 tarball)) + "failed to download tar archive")))))) + (build-system chicken-build-system) + (arguments ,(list 'quasiquote (list #:egg-name name))) + ,@(maybe-inputs 'native-inputs egg-native-inputs) + ,@(maybe-inputs 'inputs egg-inputs) + ,@(maybe-inputs 'propagated-inputs egg-propagated-inputs) + (home-page ,egg-home-page) + (synopsis ,egg-synopsis) + (description #f) + (license ,egg-licenses)) + (filter (lambda (name) + (not (member name '("srfi-4")))) + (map (compose guix-name->egg-name first) + (append egg-propagated-inputs + egg-native-inputs))))))) + +(define egg->guix-package/m ;memoized variant + (memoize egg->guix-package)) + +(define (egg-recursive-import package-name) + (recursive-import package-name + #:repo->guix-package (lambda* (name #:key version repo) + (egg->guix-package/m name)) + #:guix-name egg-name->guix-name)) + + +;;; +;;; Updater. +;;; + +(define (latest-release package) + "Return an @code{<upstream-source>} for the latest release of PACKAGE." + (let* ((egg-name (guix-package->egg-name package)) + (version (find-latest-version egg-name)) + (source-url (egg-source-url egg-name version))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list source-url))))) + +(define %egg-updater + (upstream-updater + (name 'egg) + (description "Updater for CHICKEN egg packages") + (pred egg-package?) + (latest latest-release))) + +;;; egg.scm ends here diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 9f992ffe8e..f94a1e7087 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2016 Nikita <nikita@n0.is> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -163,22 +164,22 @@ version." ;; https://www.haskell.org ;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html. (match-lambda - ("GPL-2" 'gpl2) - ("GPL-3" 'gpl3) + ("GPL-2" 'license:gpl2) + ("GPL-3" 'license:gpl3) ("GPL" "'gpl??") - ("AGPL-3" 'agpl3) + ("AGPL-3" 'license:agpl3) ("AGPL" "'agpl??") - ("LGPL-2.1" 'lgpl2.1) - ("LGPL-3" 'lgpl3) + ("LGPL-2.1" 'license:lgpl2.1) + ("LGPL-3" 'license:lgpl3) ("LGPL" "'lgpl??") - ("BSD2" 'bsd-2) - ("BSD3" 'bsd-3) - ("BSD-3-Clause" 'bsd-3) - ("MIT" 'expat) - ("ISC" 'isc) - ("MPL" 'mpl2.0) - ("Apache-2.0" 'asl2.0) - ("PublicDomain" 'public-domain) + ("BSD2" 'license:bsd-2) + ("BSD3" 'license:bsd-3) + ("BSD-3-Clause" 'license:bsd-3) + ("MIT" 'license:expat) + ("ISC" 'license:isc) + ("MPL" 'license:mpl2.0) + ("Apache-2.0" 'license:asl2.0) + ("PublicDomain" 'license:public-domain) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) (_ #f))) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 670973b193..0201376457 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -335,7 +336,8 @@ or #f on failure." (home-page ,(metadata-ref opam-content "homepage")) (synopsis ,(metadata-ref opam-content "synopsis")) (description ,(metadata-ref opam-content "description")) - (license #f)) + (license ,(spdx-string->license + (metadata-ref opam-content "license")))) (filter (lambda (name) (not (member name '("dune" "jbuilder")))) diff --git a/guix/licenses.scm b/guix/licenses.scm index 4718ccf83f..e7457799ce 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -17,6 +17,7 @@ ;;; Copyright © 2020 André Batista <nandre@riseup.net> ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> ;;; Copyright © 2021 Felix Gruber <felgru@posteo.net> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,7 +41,7 @@ apsl2 asl1.1 asl2.0 boost1.0 - bsd-0 bsd-2 bsd-3 bsd-4 + bsd-0 bsd-1 bsd-2 bsd-3 bsd-4 non-copyleft cc0 cc-by2.0 cc-by3.0 cc-by4.0 @@ -166,6 +167,11 @@ "https://spdx.org/licenses/0BSD.html" "https://opensource.org/licenses/0BSD")) +(define bsd-1 + (license "BSD 1-Clause" + "https://spdx.org/licenses/BSD-1-Clause.html" + "https://opensource.org/licenses/BSD-1-Clause")) + (define bsd-2 (license "FreeBSD" "http://directory.fsf.org/wiki/License:FreeBSD" diff --git a/guix/lint.scm b/guix/lint.scm index 1bebfe03d3..5cd6db5842 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -12,6 +12,7 @@ ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ (define-module (guix lint) #:use-module (guix store) + #:autoload (guix base16) (bytevector->base16-string) #:use-module (guix base32) #:use-module (guix diagnostics) #:use-module (guix download) @@ -95,6 +97,7 @@ check-archival check-profile-collisions check-haskell-stackage + check-tests-true lint-warning lint-warning? @@ -190,6 +193,26 @@ #:field 'name))) (else '())))) +(define (check-tests-true package) + "Check whether PACKAGE explicitly requests to run tests, which is +superfluous when building natively and incorrect when cross-compiling." + (define (tests-explicitly-enabled?) + (apply (lambda* (#:key tests? #:allow-other-keys) + (eq? tests? #t)) + (package-arguments package))) + (if (and (tests-explicitly-enabled?) + ;; Some packages, e.g. gnutls, set #:tests? + ;; differently depending on whether it is being + ;; cross-compiled. + (parameterize ((%current-target-system "aarch64-linux-gnu")) + (tests-explicitly-enabled?))) + (list (make-warning package + ;; TRANSLATORS: #:tests? and #t are Scheme constants + ;; and must not be translated. + (G_ "#:tests? must not be explicitly set to #t") + #:field 'arguments)) + '())) + (define (properly-starts-sentence? s) (string-match "^[(\"'`[:upper:][:digit:]]" s)) @@ -1002,57 +1025,46 @@ descriptions maintained upstream." (origin-uris origin)) '()))) -(cond-expand - (guile-3 - ;; Guile 3.0.0 does not export this predicate. - (define exception-with-kind-and-args? - (exception-predicate &exception-with-kind-and-args))) - (else ;Guile 2 - (define exception-with-kind-and-args? - (const #f)))) +;; Guile 3.0.0 does not export this predicate. +(define exception-with-kind-and-args? + (exception-predicate &exception-with-kind-and-args)) (define* (check-derivation package #:key store) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try store system) - (catch #t ;TODO: Remove 'catch' when Guile 2.x is no longer supported. - (lambda () - (guard (c ((store-protocol-error? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (store-protocol-error-message c)))) - ((exception-with-kind-and-args? c) - (make-warning package - (G_ "failed to create ~a derivation: ~s") - (list system - (cons (exception-kind c) - (exception-args c))))) - ((message-condition? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (condition-message c)))) - ((formatted-message? c) - (let ((str (apply format #f - (formatted-message-string c) - (formatted-message-arguments c)))) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system str))))) - (parameterize ((%graft? #f)) - (package-derivation store package system #:graft? #f) - - ;; If there's a replacement, make sure we can compute its - ;; derivation. - (match (package-replacement package) - (#f #t) - (replacement - (package-derivation store replacement system - #:graft? #f)))))) - (lambda args - (make-warning package - (G_ "failed to create ~a derivation: ~s") - (list system args))))) + (guard (c ((store-protocol-error? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) + ((exception-with-kind-and-args? c) + (make-warning package + (G_ "failed to create ~a derivation: ~s") + (list system + (cons (exception-kind c) + (exception-args c))))) + ((message-condition? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (condition-message c)))) + ((formatted-message? c) + (let ((str (apply format #f + (formatted-message-string c) + (formatted-message-arguments c)))) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system str))))) + (parameterize ((%graft? #f)) + (package-derivation store package system #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement system + #:graft? #f)))))) (define (check-with-store store) (filter lint-warning? @@ -1227,6 +1239,43 @@ upstream releases") #:field 'source))))))) +(define (lookup-disarchive-spec hash) + "If Disarchive mirrors have a spec for HASH, return the list of SWH +directory identifiers the spec refers to. Otherwise return #f." + (define (extract-swh-id spec) + ;; Return the list of SWH directory identifiers SPEC refers to, where SPEC + ;; is a Disarchive sexp. Instead of attempting to parse it, traverse it + ;; in a pretty unintelligent fashion. + (let loop ((sexp spec) + (ids '())) + (match sexp + ((? string? str) + (let ((prefix "swh:1:dir:")) + (if (string-prefix? prefix str) + (cons (string-drop str (string-length prefix)) ids) + ids))) + ((head tail ...) + (loop tail (loop head ids))) + (_ ids)))) + + (any (lambda (mirror) + (with-networking-fail-safe + (format #f (G_ "failed to access Disarchive database at ~a") + mirror) + #f + (guard (c ((http-get-error? c) #f)) + (let* ((url (string-append mirror + (symbol->string + (content-hash-algorithm hash)) + "/" + (bytevector->base16-string + (content-hash-value hash)))) + (port (http-fetch (string->uri url) #:text? #t)) + (spec (read port))) + (close-port port) + (extract-swh-id spec))))) + %disarchive-mirrors)) + (define (check-archival package) "Check whether PACKAGE's source code is archived on Software Heritage. If it's not, and if its source code is a VCS snapshot, then send a \"save\" @@ -1302,10 +1351,26 @@ try again later") (symbol->string (content-hash-algorithm hash))) (#f - (list (make-warning package - (G_ "source not archived on Software \ -Heritage") - #:field 'source))) + ;; If SWH doesn't have HASH as is, it may be because it's + ;; a hand-crafted tarball. In that case, check whether + ;; the Disarchive database has an entry for that tarball. + (match (lookup-disarchive-spec hash) + (#f + (list (make-warning package + (G_ "source not archived on Software \ +Heritage and missing from the Disarchive database") + #:field 'source))) + (directory-ids + (match (find (lambda (id) + (not (lookup-directory id))) + directory-ids) + (#f '()) + (id + (list (make-warning package + (G_ " +Disarchive entry refers to non-existent SWH directory '~a'") + (list id) + #:field 'source))))))) ((? content?) '()))) '())))) @@ -1482,6 +1547,10 @@ them for PACKAGE." (description "Validate package names") (check check-name)) (lint-checker + (name 'tests-true) + (description "Check if tests are explicitly enabled") + (check check-tests-true)) + (lint-checker (name 'description) (description "Validate package descriptions") (check check-description-style)) diff --git a/guix/profiles.scm b/guix/profiles.scm index 2ec78b080a..5f9a8a87a9 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -334,7 +334,10 @@ file name." (filter-map (lambda (entry) (let ((other (lookup (manifest-entry-name entry) (manifest-entry-output entry)))) - (and other (list entry other)))) + (and other + (not (eq? (manifest-entry-item entry) + (manifest-entry-item other))) + (list entry other)))) (manifest-transitive-entries manifest))) (define lower-pair diff --git a/guix/progress.scm b/guix/progress.scm index 334bd40547..0cbc804ec1 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -347,15 +347,25 @@ should be a <progress-reporter> object." (report total) (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) -(define* (progress-report-port reporter port #:key (close? #t)) +(define* (progress-report-port reporter port + #:key + (close? #t) + download-size) "Return a port that continuously reports the bytes read from PORT using REPORTER, which should be a <progress-reporter> object. When CLOSE? is true, -PORT is closed when the returned port is closed." +PORT is closed when the returned port is closed. + +When DOWNLOAD-SIZE is passed, do not read more than DOWNLOAD-SIZE bytes from +PORT. This is important to avoid blocking when the remote side won't close +the underlying connection." (match reporter (($ <progress-reporter> start report stop) (let* ((total 0) (read! (lambda (bv start count) - (let ((n (match (get-bytevector-n! port bv start count) + (let* ((count (if download-size + (min count (- download-size total)) + count)) + (n (match (get-bytevector-n! port bv start count) ((? eof-object?) 0) (x x)))) (set! total (+ total n)) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index ceac640432..f8678aa5f9 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -260,6 +260,9 @@ build and a list of store files to transfer." resulting archive to the standard output port." (let-values (((drv files) (options->derivations+files store opts))) + (when (null? files) + (warning (G_ "no arguments specified; creating an empty archive~%"))) + (if (build-derivations store drv) (export-paths store files (current-output-port) #:recursive? (assoc-ref opts 'export-recursive?)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 2decdb45ed..97e2f5a167 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -679,6 +679,9 @@ needed." (_ #f)) opts))) + (when (and (null? drv) (null? items)) + (warning (G_ "no arguments specified, nothing to do~%"))) + (cond ((assoc-ref opts 'log-file?) ;; Pass 'show-build-log' the output file names, not the ;; derivation file names, because there can be several diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 52b476db54..07357af420 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -62,6 +62,10 @@ number (or #f) corresponding to SPEC." (x (leave (G_ "~a: invalid SSH specification~%") spec)))) +(define (warn-if-empty items) + (when (null? items) + (warning (G_ "no arguments specified, nothing to copy~%")))) + (define (send-to-remote-host local target opts) "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; package names, build the underlying packages before sending them." @@ -69,6 +73,7 @@ package names, build the underlying packages before sending them." (ssh-spec->user+host+port target)) ((drv items) (options->derivations+files local opts))) + (warn-if-empty items) (and (build-derivations local drv) (let* ((session (open-ssh-session host #:user user #:port (or port 22))) @@ -94,7 +99,9 @@ package names, build the underlying packages before sending them." (let*-values (((drv items) (options->derivations+files local opts)) ((retrieved) - (retrieve-files local items remote #:recursive? #t))) + (begin + (warn-if-empty items) + (retrieve-files local items remote #:recursive? #t)))) (close-connection remote) (disconnect! session) (format #t "~{~a~%~}" retrieved) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 0725fba54b..7c62b05d12 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 David Thompson <davet@gnu.org> ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -125,10 +125,7 @@ Perform the deployment specified by FILE.\n")) ;; and include a '&message'. However, that message only contains ;; the format string. Thus, special-case it here to avoid ;; displaying a bare format string. - ((cond-expand - (guile-3 - ((exception-predicate &exception-with-kind-and-args) c)) - (else #f)) + (((exception-predicate &exception-with-kind-and-args) c) (raise c)) ((message-condition? c) @@ -156,7 +153,10 @@ Perform the deployment specified by FILE.\n")) (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)) '()))) + (machines (and file (load-source-file file)))) + (unless file + (leave (G_ "missing deployment file argument~%"))) + (show-what-to-deploy machines) (with-status-verbosity (assoc-ref opts 'verbosity) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index b4c0507591..a2e1ffb434 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; @@ -91,6 +91,8 @@ line." (with-error-handling (let* ((specs (reverse (parse-arguments))) (locations (map specification->location specs))) + (when (null? specs) + (leave (G_ "no packages specified, nothing to edit~%"))) (catch 'system-error (lambda () diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0360761683..5ceb86f7a9 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -755,6 +755,9 @@ message if any test fails." (> (length (manifest-entries manifest-from-opts)) 0)) (leave (G_ "'--profile' cannot be used with package options~%"))) + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; creating an empty environment~%"))) + (set-build-options-from-command-line store opts) ;; Use the bootstrap Guile when requested. diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index ddfc6ba497..66de824ef4 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -593,6 +593,9 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (read/eval-package-expression exp))) (_ #f)) opts))) + (when (null? items) + (warning (G_ "no arguments specified; creating an empty graph~%"))) + (run-with-store store ;; XXX: Since grafting can trigger unsolicited builds, disable it. (mlet %store-monad ((_ (set-grafting #f)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index bbd9a3b190..f53d1ac1f4 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -76,8 +76,8 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" - "go" "cran" "crate" "texlive" "json" "opam")) +(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" + "gem" "go" "cran" "crate" "texlive" "json" "opam")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/egg.scm b/guix/scripts/import/egg.scm new file mode 100644 index 0000000000..7dbd6fcd5a --- /dev/null +++ b/guix/scripts/import/egg.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; +;;; 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 import egg) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import egg) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-egg)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import egg PACKAGE-NAME +Import and convert the egg package for PACKAGE-NAME.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import egg"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-egg . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (repo (and=> (assoc-ref opts 'repo) string->symbol)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #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))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e3d40d5142..6db83807af 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1044,6 +1044,14 @@ processed, #f otherwise." (warn-about-old-distro) + (when (and (null? files) (manifest-transaction-null? trans)) + ;; We can reach this point because the user did not specify any action + ;; (as in "guix package"), did not specify any package (as in "guix + ;; install"), or because there's nothing to upgrade (as when running + ;; "guix upgrade" on an up-to-date profile). We cannot distinguish + ;; among these here; all we can say is that there's nothing to do. + (warning (G_ "nothing to do~%"))) + (unless (manifest-transaction-null? trans) ;; When '--manifest' is used, display information about TRANS as if we ;; were starting from an empty profile. diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index ef6fa5f074..f35f81dc34 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -25,6 +25,7 @@ #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 poll) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:use-module (ice-9 threads) @@ -33,6 +34,7 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -869,60 +871,115 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." exp ...) (const #f))) -(define (nar-response-port response compression) - "Return a port on which to write the body of RESPONSE, the response of a -/nar request, according to COMPRESSION." +(define (nar-compressed-port port compression) + "Return a port on which to write the body of the response of a /nar request, +according to COMPRESSION." (match compression (($ <compression> 'gzip level) ;; Note: We cannot used chunked encoding here because ;; 'make-gzip-output-port' wants a file port. - (make-gzip-output-port (response-port response) + (make-gzip-output-port port #:level level #:buffer-size %default-buffer-size)) (($ <compression> 'lzip level) - (make-lzip-output-port (response-port response) + (make-lzip-output-port port #:level level)) (($ <compression> 'zstd level) - (make-zstd-output-port (response-port response) + (make-zstd-output-port port #:level level)) (($ <compression> 'none) - (response-port response)) + port) (#f - (response-port response)))) + port))) (define (http-write server client response body) "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid blocking." + ;; XXX: The default Guile web server implementation supports the keep-alive + ;; mechanism. However, as we run our own modified version of the http-write + ;; procedure, we need to access a few server implementation details to keep + ;; it functional. + (define *error-events* + (logior POLLHUP POLLERR)) + + (define *read-events* + POLLIN) + + (define *events* + (logior *error-events* *read-events*)) + + ;; Access the server poll set variable. + (define http-poll-set + (@@ (web server http) http-poll-set)) + + ;; Copied from (web server http). + (define (keep-alive? response) + (let ((v (response-version response))) + (and (or (< (response-code response) 400) + (= (response-code response) 404)) + (case (car v) + ((1) + (case (cdr v) + ((1) (not (memq 'close (response-connection response)))) + ((0) (memq 'keep-alive (response-connection response))))) + (else #f))))) + + (define (keep-alive port) + "Add the given PORT the server poll set." + (force-output port) + (poll-set-add! (http-poll-set server) port *events*)) + + (define compression + (assoc-ref (response-headers response) 'x-nar-compression)) + (match (response-content-type response) (('application/x-nix-archive . _) - ;; Sending the the whole archive can take time so do it in a separate - ;; thread so that the main thread can keep working in the meantime. - (call-with-new-thread - (lambda () - (set-thread-name "publish nar") - (let* ((compression (assoc-ref (response-headers response) - 'x-nar-compression)) - (response (write-response (sans-content-length response) - client)) - (port (begin - (force-output client) - (configure-socket client) - (nar-response-port response compression)))) - ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in - ;; 'render-nar', BODY here is just the file name of the store item. - ;; We call 'write-file' from here because we know that's the only - ;; way to avoid building the whole nar in memory, which could - ;; quickly become a real problem. As a bonus, we even do - ;; sendfile(2) directly from the store files to the socket. - (swallow-zlib-error - (swallow-EPIPE - (write-file (utf8->string body) port))) - (swallow-zlib-error - (close-port port)) - (values))))) + ;; When compressing the NAR on the go, we cannot announce its size + ;; beforehand to the client. Hence, the keep-alive mechanism cannot work + ;; here. + (let ((keep-alive? (and (eq? (compression-type compression) 'none) + (keep-alive? response)))) + ;; Add the client to the server poll set, so that we can receive + ;; further requests without closing the connection. + (when keep-alive? + (keep-alive client)) + ;; Sending the the whole archive can take time so do it in a separate + ;; thread so that the main thread can keep working in the meantime. + (call-with-new-thread + (lambda () + (set-thread-name "publish nar") + (let* ((response (write-response (sans-content-length response) + client)) + (port (begin + (force-output client) + (configure-socket client) + ;; Duplicate the response port, so that it is + ;; not automatically closed when closing the + ;; returned port. This is needed for the + ;; keep-alive mechanism. + (nar-compressed-port + (duplicate-port + (response-port response) "w+0b") + compression)))) + ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> + ;; in 'render-nar', BODY here is just the file name of the store + ;; item. We call 'write-file' from here because we know that's + ;; the only way to avoid building the whole nar in memory, which + ;; could quickly become a real problem. As a bonus, we even do + ;; sendfile(2) directly from the store files to the socket. + (swallow-zlib-error + (swallow-EPIPE + (write-file (utf8->string body) port))) + (swallow-zlib-error + (close-port port) + (unless keep-alive? + (close-port client))) + (values)))))) (_ (match (assoc-ref (response-headers response) 'x-raw-file) ((? string? file) + (when (keep-alive? response) + (keep-alive client)) ;; Send a raw file in a separate thread. (call-with-new-thread (lambda () @@ -932,19 +989,20 @@ blocking." (call-with-input-file file (lambda (input) (let* ((size (stat:size (stat input))) - (response (write-response (with-content-length response - size) - client)) + (response (write-response + (with-content-length response size) + client)) (output (response-port response))) (configure-socket client) (if (file-port? output) (sendfile output input size) (dump-port input output)) - (close-port output) + (unless (keep-alive? response) + (close-port output)) (values))))) (lambda args - ;; If the file was GC'd behind our back, that's fine. Likewise if - ;; the client closes the connection. + ;; If the file was GC'd behind our back, that's fine. Likewise + ;; if the client closes the connection. (unless (memv (system-error-errno args) (list ENOENT EPIPE ECONNRESET)) (apply throw args)) @@ -980,6 +1038,18 @@ methods, return the applicable compression." compressions) (default-compression requested-type))) +(define (preserve-connection-headers request response) + "Add REQUEST's 'connection' header, if any, to HEADERS, a list of response +headers." + (if (pair? response) + (let ((connection + (assq 'connection (request-headers request)))) + (append response + (if connection + (list connection) + '()))) + response)) + (define* (make-request-handler store #:key cache pool @@ -993,7 +1063,7 @@ methods, return the applicable compression." (let ((expected (split-and-decode-uri-path nar-path))) (cut equal? expected <>))) - (lambda (request body) + (define (handle request body) (format #t "~a ~a~%" (request-method request) (uri-path (request-uri request))) @@ -1065,7 +1135,15 @@ methods, return the applicable compression." (not-found request))) (x (not-found request))) - (not-found request)))) + (not-found request))) + + ;; Preserve the request's 'connection' header in the response, so that the + ;; server can close the connection if this is requested by the client. + (lambda (request body) + (let-values (((response response-body) + (handle request body))) + (values (preserve-connection-headers request response) + response-body)))) (define (service-name) "Return the Avahi service name of the server." diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8e4eae00b3..44448ff3e9 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -163,7 +163,9 @@ if file doesn't exist, and the narinfo otherwise." (define (lookup-narinfo caches path authorized?) "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH was found." - (match (lookup-narinfos/diverse caches (list path) authorized?) + (match (lookup-narinfos/diverse + caches (list path) authorized? + #:open-connection open-connection-for-uri/cached) ((answer) answer) (_ #f))) @@ -518,8 +520,11 @@ PORT." (current-error-port) #:abbreviation nar-uri-abbreviation)))) ;; Keep RAW open upon completion so we can later reuse - ;; the underlying connection. - (progress-report-port reporter raw #:close? #f))) + ;; the underlying connection. Pass the download size so + ;; that this procedure won't block reading from RAW. + (progress-report-port reporter raw + #:close? #f + #:download-size dl-size))) ((input pids) ;; NOTE: This 'progress' port of current process will be ;; closed here, while the child process doing the diff --git a/guix/store.scm b/guix/store.scm index 9d706ae590..cf5d5eeccc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -648,18 +648,10 @@ connection. Use with care." (close-connection store) (apply values results))))) - (cond-expand - (guile-3 - (with-exception-handler (lambda (exception) - (close-connection store) - (raise-exception exception)) - thunk)) - (else ;Guile 2.2 - (catch #t - thunk - (lambda (key . args) - (close-connection store) - (apply throw key args))))))) + (with-exception-handler (lambda (exception) + (close-connection store) + (raise-exception exception)) + thunk))) (define-syntax-rule (with-store store exp ...) "Bind STORE to an open connection to the store and evaluate EXPs; diff --git a/guix/swh.scm b/guix/swh.scm index 06d2957252..f6d5241e06 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -148,20 +148,12 @@ url (string-append url "/"))) -(cond-expand - (guile-3 - ;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would - ;; be ignored (<https://bugs.gnu.org/40486>). - (define* (http-get* uri #:rest rest) - (apply http-request uri #:method 'GET rest)) - (define* (http-post* uri #:rest rest) - (apply http-request uri #:method 'POST rest))) - (else ;Guile 2.2 - ;; Guile 2.2 did not have #:verify-certificate? so ignore it. - (define* (http-get* uri #:key verify-certificate? streaming?) - (http-request uri #:method 'GET #:streaming? streaming?)) - (define* (http-post* uri #:key verify-certificate? streaming?) - (http-request uri #:method 'POST #:streaming? streaming?)))) +;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would +;; be ignored (<https://bugs.gnu.org/40486>). +(define* (http-get* uri #:rest rest) + (apply http-request uri #:method 'GET rest)) +(define* (http-post* uri #:rest rest) + (apply http-request uri #:method 'POST rest)) (define %date-regexp ;; Match strings like "2014-11-17T22:09:38+01:00" or diff --git a/guix/ui.scm b/guix/ui.scm index 05b3f5f84c..d3e01f846d 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -196,17 +196,11 @@ information, or #f if it could not be found." (stack-ref stack 1) ;skip the 'throw' frame last)))) -(cond-expand - (guile-3 - (define-syntax-rule (without-compiler-optimizations exp) - ;; Compile with the baseline compiler (-O1), which is much less expensive - ;; than -O2. - (parameterize (((@ (system base compile) default-optimization-level) 1)) - exp))) - (else - (define-syntax-rule (without-compiler-optimizations exp) - ;; No easy way to turn off optimizations on Guile 2.2. - exp))) +(define-syntax-rule (without-compiler-optimizations exp) + ;; Compile with the baseline compiler (-O1), which is much less expensive + ;; than -O2. + (parameterize (((@ (system base compile) default-optimization-level) 1)) + exp)) (define* (load* file user-module #:key (on-error 'nothing-special)) @@ -674,22 +668,17 @@ or variants of @code{~a} in the same profile.") or remove one of them from the profile.") name1 name2))))) -(cond-expand - (guile-3 - ;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise. To - ;; preserve useful backtraces in case of unhandled errors, we want that to - ;; happen before the stack has been unwound, hence 'guard*'. - (define-syntax-rule (guard* (var clauses ...) exp ...) - "This variant of SRFI-34 'guard' does not unwind the stack before +;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise. To +;; preserve useful backtraces in case of unhandled errors, we want that to +;; happen before the stack has been unwound, hence 'guard*'. +(define-syntax-rule (guard* (var clauses ...) exp ...) + "This variant of SRFI-34 'guard' does not unwind the stack before evaluating the tests and bodies of CLAUSES." - (with-exception-handler - (lambda (var) - (cond clauses ... (else (raise var)))) - (lambda () exp ...) - #:unwind? #f))) - (else - (define-syntax-rule (guard* (var clauses ...) exp ...) - (guard (var clauses ...) exp ...)))) + (with-exception-handler + (lambda (var) + (cond clauses ... (else (raise var)))) + (lambda () exp ...) + #:unwind? #f)) (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." @@ -822,11 +811,13 @@ directories:~{ ~a~}~%") ;; Furthermore, use of 'guard*' ensures that the stack has not ;; been unwound when we re-raise, since that would otherwise show ;; useless backtraces. - ((cond-expand - (guile-3 - ((exception-predicate &exception-with-kind-and-args) c)) - (else #f)) - (raise c)) + (((exception-predicate &exception-with-kind-and-args) c) + (if (eq? 'system-error (exception-kind c)) ;EPIPE & co. + (match (exception-args c) + ((proc format-string format-args . _) + (leave (G_ "~a: ~a~%") proc + (apply format #f format-string format-args)))) + (raise c))) ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. @@ -836,12 +827,7 @@ directories:~{ ~a~}~%") (when (fix-hint? c) (display-hint (condition-fix-hint c))) (exit 1))) - ;; Catch EPIPE and the likes. - (catch 'system-error - thunk - (lambda (key proc format-string format-args . rest) - (leave (G_ "~a: ~a~%") proc - (apply format #f format-string format-args)))))) + (thunk))) (define-syntax-rule (leave-on-EPIPE exp ...) "Run EXP... in a context where EPIPE errors are caught and lead to 'exit' |