diff options
Diffstat (limited to 'guix')
68 files changed, 2616 insertions, 625 deletions
diff --git a/guix/build-system/elm.scm b/guix/build-system/elm.scm new file mode 100644 index 0000000000..f5321f811b --- /dev/null +++ b/guix/build-system/elm.scm @@ -0,0 +1,206 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build-system elm) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix search-paths) + #:use-module (guix git-download) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (elm->package-name + guix-package->elm-name + infer-elm-package-name + elm-package-origin + %elm-build-system-modules + %elm-default-modules + elm-build + elm-build-system)) + +(define (elm->package-name name) + "Given the NAME of an Elm package, return a Guix-style package name." + (let ((converted + (string-join (string-split (string-downcase name) #\/) "-"))) + (if (string-prefix? "elm-" converted) + converted + (string-append "elm-" converted)))) + +(define (guix-package->elm-name package) + "Given an Elm PACKAGE, return the possibly-inferred upstream name, or #f the +upstream name is not specified and can't be inferred." + (or (assoc-ref (package-properties package) 'upstream-name) + (infer-elm-package-name (package-name package)))) + +(define (infer-elm-package-name guix-name) + "Given the GUIX-NAME of an Elm package, return the inferred upstream name, +or #f if it can't be inferred. If the result is not #f, supplying it to +'elm->package-name' would produce GUIX-NAME. + +See also 'guix-package->elm-name', which respects the 'upstream-name' +property." + (define (parts-join part0 parts) + (string-join (cons part0 parts) "-")) + (match (string-split guix-name #\-) + (("elm" "explorations" part0 parts ...) + (string-append "elm-explorations/" + (parts-join part0 parts))) + (("elm" owner part0 parts ...) + (string-append owner "/" (parts-join part0 parts))) + (("elm" repo) + (string-append "elm/" repo)) + (_ + #f))) + +(define (elm-package-origin elm-name version hash) + "Return an origin for the Elm package with upstream name ELM-NAME at the +given VERSION with sha256 checksum HASH." + ;; elm requires this very specific repository structure and tagging regime + (origin + (method git-fetch) + (uri (git-reference + (url (string-append "https://github.com/" elm-name)) + (commit version))) + (file-name (git-file-name (elm->package-name elm-name) version)) + (sha256 hash))) + +(define %elm-build-system-modules + ;; Build-side modules imported by default. + `((guix build elm-build-system) + (guix build json) + (guix build union) + ,@%gnu-build-system-modules)) + +(define %elm-default-modules + ;; Modules in scope in the build-side environment. + '((guix build elm-build-system) + (guix build utils) + (guix build json) + (guix build union))) + +(define (default-elm) + "Return the default Elm package for builds." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((elm (resolve-interface '(gnu packages elm)))) + (module-ref elm 'elm-sans-reactor))) + +(define (default-elm-core) + "Return the default elm-core package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((elm (resolve-interface '(gnu packages elm)))) + (module-ref elm 'elm-core))) + +(define (default-elm-json) + "Return the default elm-json package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((elm (resolve-interface '(gnu packages elm)))) + (module-ref elm 'elm-json))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (implicit-elm-package-inputs? #t) + (elm (default-elm)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:target #:implicit-elm-package-inputs? #:elm #:inputs #:native-inputs)) + (cond + (target + ;; Cross-compilation is not yet supported. It should be easy, though, + ;; since the build products are all platform-independent. + #f) + (else + (bag + (name name) + (system system) + (host-inputs + `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ("elm" ,elm) + ,@(cond + (implicit-elm-package-inputs? + ;; These are needed for elm-build-system even if not actually + ;; needed by the package being built. But "elm/json" is often + ;; present in practice, and "elm/core" always is: only add the + ;; default packages if no suitable inputs have been given + ;; explicitly. + (filter-map + (match-lambda + ((name get-default) + (cond + ((find (match-lambda + ((_ pkg . _) + (equal? name (guix-package->elm-name pkg)))) + inputs) + #f) + (else + `(,name ,(get-default)))))) + `(("elm/core" ,default-elm-core) + ("elm/json" ,default-elm-json)))) + (else + '())) + ;; TODO: probably don't need most of (standard-packages) + ,@(standard-packages))) + (outputs outputs) + (build elm-build) + (arguments (strip-keyword-arguments private-keywords arguments)))))) + +(define* (elm-build name inputs + #:key + source + (tests? #t) + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %elm-build-system-modules) + (modules %elm-default-modules)) + "Build SOURCE using ELM." + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (elm-build #:name #$name + #:source #+source + #:system #$system + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) + +(define elm-build-system + (build-system + (name 'elm) + (description "The Elm build system") + (lower lower))) diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index e82a9ca65c..94a293da13 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -28,6 +28,7 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) + #:use-module (guix platform) #:use-module (ice-9 match) #:export (%linux-module-build-system-modules linux-module-build @@ -50,8 +51,7 @@ (module-ref module 'linux-libre))) (define (system->arch system) - (let ((module (resolve-interface '(gnu packages linux)))) - ((module-ref module 'system->linux-architecture) system))) + (platform-linux-architecture (lookup-platform-by-target-or-system system))) (define (make-linux-module-builder linux) (package diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 2c82390ba6..620822b870 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.14" + (string-append "https://bioconductor.org/packages/3.15" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm index 86ee11391d..a0f5e15880 100644 --- a/guix/build/bzr.scm +++ b/guix/build/bzr.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2018, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,7 +28,7 @@ ;;; Code: (define* (bzr-fetch url revision directory - #:key (bzr-command "bzr")) + #:key (bzr-command "brz")) "Fetch REVISION from URL into DIRECTORY. REVISION must be a valid Bazaar revision identifier. Return #t on success, else throw an exception." ;; Do not attempt to write .bzr.log to $HOME, which doesn't exist. @@ -37,8 +37,6 @@ revision identifier. Return #t on success, else throw an exception." (invoke bzr-command "-Ossl.cert_reqs=none" "checkout" "--lightweight" "-r" revision url directory) (with-directory-excursion directory - (begin - (delete-file-recursively ".bzr") - #t))) + (delete-file-recursively ".bzr"))) ;;; bzr.scm ends here diff --git a/guix/build/elm-build-system.scm b/guix/build/elm-build-system.scm new file mode 100644 index 0000000000..02d7c029dd --- /dev/null +++ b/guix/build/elm-build-system.scm @@ -0,0 +1,380 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build elm-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (guix build json) + #:use-module (guix build union) + #:use-module (ice-9 ftw) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:export (%standard-phases + patch-application-dependencies + patch-json-string-escapes + read-offline-registry->vhash + elm-build)) + +;;; Commentary: +;;; +;;; Elm draws a sharp distinction between "projects" with `{"type":"package"}` +;;; vs. `{"type":"application"}` in the "elm.json" file: see +;;; <https://github.com/elm/compiler/blob/master/docs/elm.json/package.md> and +;;; <https://github.com/elm/compiler/blob/master/docs/elm.json/application.md>. +;;; For now, `elm-build-system` is designed for "package"s: packaging +;;; "application"s requires ad-hoc replacements for some phases---but see +;;; `patch-application-dependencies`, which helps to work around a known issue +;;; discussed below. It would be nice to add more streamlined support for +;;; "application"s one we have more experience building them in Guix. For +;;; example, we could incorporate the `uglifyjs` advice from +;;; <https://github.com/elm/compiler/blob/master/hints/optimize.md>. +;;; +;;; We want building an Elm "package" to produce: +;;; +;;; - a "docs.json" file with extracted documentation; and +;;; +;;; - an "artifacts.dat" file with compilation results for use in building +;;; "package"s and "application"s. +;;; +;;; Unfortunately, there isn't an entry point to the Elm compiler that builds +;;; those files directly. Building with `elm make` does something different, +;;; more oriented toward development, testing, and building "application"s. +;;; We work around this limitation by staging the "package" we're building as +;;; though it were already installed in ELM_HOME, generating a trivial Elm +;;; "application" that depends on the "package", and building the +;;; "application", which causes the files for the "package" to be built. +;;; +;;; Much of the ceremony involved is to avoid using `elm` in ways that would +;;; make it try to do network IO beyond the bare minimum functionality for +;;; which we've patched a replacement into our `elm`. On the other hand, we +;;; get to take advantage of the very regular structure required of Elm +;;; packages. +;;; +;;; *Known issue:* Elm itself supports multiple versions of "package"s +;;; coexisting simultaneously under ELM_HOME, but we do not support this yet. +;;; Sometimes, parallel versions coexisting causes `elm` to try to write to +;;; built "artifacts.dat" files. For now, two workarounds are possible: +;;; +;;; - Use `patch-application-dependencies` to rewrite an "application"'s +;;; "elm.json" file to refer to the versions of its inputs actually +;;; packaged in Guix. +;;; +;;; - Use a Guix package transformation to rewrite your "application"'s +;;; dependencies recursively, so that only one version of each Elm +;;; "package" is included in your "application"'s build environment. +;;; +;;; Patching `elm` more extensively---perhaps adding an `elm guix` +;;; subcommand`---might let us address these issues more directly. +;;; +;;; Code: +;;; + +(define %essential-elm-packages + ;; elm/json isn't essential in a fundamental sense, + ;; but it's required for a {"type":"application"}, + ;; which we are generating to trigger the build + '("elm/core" "elm/json")) + +(define* (target-elm-version #:optional elm) + "Return the version of ELM or whichever 'elm' is in $PATH. +Return #false if it cannot be determined." + (let* ((pipe (open-pipe* OPEN_READ + (or elm "elm") + "--version")) + (line (read-line pipe))) + (and (zero? (close-pipe pipe)) + (string? line) + line))) + +(define* (prepare-elm-home #:key native-inputs inputs #:allow-other-keys) + "Set the ELM_HOME environment variable and populate the indicated directory +with the union of the Elm \"package\" inputs. Also, set GUIX_ELM_VERSION to +the version of the Elm compiler in use." + (let* ((elm (search-input-file (or native-inputs inputs) "/bin/elm")) + (elm-version (target-elm-version elm))) + (setenv "GUIX_ELM_VERSION" elm-version) + (mkdir "../elm-home") + (with-directory-excursion "../elm-home" + (union-build elm-version + (search-path-as-list + (list (string-append "share/elm/" elm-version)) + (map cdr inputs)) + #:create-all-directories? #t) + (setenv "ELM_HOME" (getcwd))))) + +(define* (stage #:key native-inputs inputs #:allow-other-keys) + "Extract the installable files from the Elm \"package\" into a staging +directory and link it into the ELM_HOME tree. Also, set GUIX_ELM_PKG_NAME and +GUIX_ELM_PKG_VERSION to the name and version, respectively, of the Elm package +being built, as defined in its \"elm.json\" file." + (let* ((elm-version (getenv "GUIX_ELM_VERSION")) + (elm-home (getenv "ELM_HOME")) + (info (match (call-with-input-file "elm.json" read-json) + (('@ . alist) alist))) + (name (assoc-ref info "name")) + (version (assoc-ref info "version")) + (rel-dir (string-append elm-version "/packages/" name "/" version)) + (staged-dir (string-append elm-home "/../staged/" rel-dir))) + (setenv "GUIX_ELM_PKG_NAME" name) + (setenv "GUIX_ELM_PKG_VERSION" version) + (mkdir-p staged-dir) + (mkdir-p (string-append elm-home "/" (dirname rel-dir))) + (symlink staged-dir + (string-append elm-home "/" rel-dir)) + (copy-recursively "src" (string-append staged-dir "/src")) + (install-file "elm.json" staged-dir) + (install-file "README.md" staged-dir) + (when (file-exists? "LICENSE") + (install-file "LICENSE" staged-dir)))) + +(define (patch-json-string-escapes file) + "Work around a bug in the Elm compiler's JSON parser by attempting to +replace REVERSE-SOLIDUS--SOLIDUS escape sequences in FILE with unescaped +SOLIDUS characters." + ;; https://github.com/elm/compiler/issues/2255 + (substitute* file + (("\\\\/") + "/"))) + +(define (directory-list dir) + "Like DIRECTORY-LIST from 'racket/base': lists the contents of DIR, not +including the special \".\" and \"..\" entries." + (scandir dir (lambda (f) + (not (member f '("." "..")))))) + +(define* (make-offline-registry-file #:key inputs #:allow-other-keys) + "Generate an \"offline-package-registry.json\" file and set +GUIX_ELM_OFFLINE_REGISTRY_FILE to its path, cooperating with a patch to `elm` +to avoid attempting to download a list of all published Elm package names and +versions from the internet." + (let* ((elm-home (getenv "ELM_HOME")) + (elm-version (getenv "GUIX_ELM_VERSION")) + (registry-file + (string-append elm-home "/../offline-package-registry.json")) + (registry-alist + ;; here, we don't need to look up entries, so we build the + ;; alist directly, rather than using a vhash + (with-directory-excursion + (string-append elm-home "/" elm-version "/packages") + (append-map (lambda (org) + (with-directory-excursion org + (map (lambda (repo) + (cons (string-append org "/" repo) + (directory-list repo))) + (directory-list ".")))) + (directory-list "."))))) + (call-with-output-file registry-file + (lambda (out) + (write-json `(@ ,@registry-alist) out))) + (patch-json-string-escapes registry-file) + (setenv "GUIX_ELM_OFFLINE_REGISTRY_FILE" registry-file))) + +(define (read-offline-registry->vhash) + "Return a vhash mapping Elm \"package\" names to lists of available version +strings." + (alist->vhash + (match (call-with-input-file (getenv "GUIX_ELM_OFFLINE_REGISTRY_FILE") + read-json) + (('@ . alist) alist)))) + +(define (find-indirect-dependencies registry-vhash root-pkg root-version) + "Return the recursive dependencies of ROOT-PKG, an Elm \"package\" name, at +version ROOT-VERSION as an alist mapping Elm \"package\" names to (single) +versions. The resulting alist will not include entries for +%ESSENTIAL-ELM-PACKAGES or for ROOT-PKG itself. The REGISTRY-VHASH is used in +conjunction with the ELM_HOME environment variable to find dependencies." + (with-directory-excursion + (string-append (getenv "ELM_HOME") + "/" (getenv "GUIX_ELM_VERSION") + "/packages") + (define (get-dependencies pkg version acc) + (let* ((elm-json-alist + (match (call-with-input-file + (string-append pkg "/" version "/elm.json") + read-json) + (('@ . alist) alist))) + (deps-alist + (match (assoc-ref elm-json-alist "dependencies") + (('@ . alist) alist))) + (deps-names + (filter-map (match-lambda + ((name . range) + (and (not (member name %essential-elm-packages)) + name))) + deps-alist))) + (fold register-dependency acc deps-names))) + (define (register-dependency pkg acc) + ;; Using vhash-cons unconditionally would add duplicate entries, + ;; which would then cause problems when we must emit JSON. + ;; Plus, we can avoid needlessly duplicating work. + (if (vhash-assoc pkg acc) + acc + (match (vhash-assoc pkg registry-vhash) + ((_ version . _) + ;; in the rare case that multiple versions are present, + ;; just picking an arbitrary one seems to work well enough for now + (get-dependencies pkg version (vhash-cons pkg version acc)))))) + (vlist->list + (get-dependencies root-pkg root-version vlist-null)))) + +(define* (patch-application-dependencies #:key inputs #:allow-other-keys) + "Rewrites the \"elm.json\" file in the working directory---which must be of +`\"type\":\"application\"`, not `\"type\":\"package\"`---to refer to the +dependency versions actually provided via Guix. The +GUIX_ELM_OFFLINE_REGISTRY_FILE environment variable is used to find available +versions." + (let* ((registry-vhash (read-offline-registry->vhash)) + (rewrite-dep-version + (match-lambda + ((name . _) + (cons name (match (vhash-assoc name registry-vhash) + ((_ version) ;; no dot + version)))))) + (rewrite-direct/indirect + (match-lambda + ;; a little checking to avoid confusing misuse with "package" + ;; project dependencies, which have a different shape + (((and key (or "direct" "indirect")) + '@ . alist) + `(,key @ ,@(map rewrite-dep-version alist))))) + (rewrite-json-section + (match-lambda + (((and key (or "dependencies" "test-dependencies")) + '@ . alist) + `(,key @ ,@(map rewrite-direct/indirect alist))) + ((k . v) + (cons k v)))) + (rewrite-elm-json + (match-lambda + (('@ . alist) + `(@ ,@(map rewrite-json-section alist)))))) + (with-atomic-file-replacement "elm.json" + (lambda (in out) + (write-json (rewrite-elm-json (read-json in)) + out))) + (patch-json-string-escapes "elm.json"))) + +(define* (configure #:key native-inputs inputs #:allow-other-keys) + "Generate a trivial Elm \"application\" with a direct dependency on the Elm +\"package\" currently being built." + (let* ((info (match (call-with-input-file "elm.json" read-json) + (('@ . alist) alist))) + (name (getenv "GUIX_ELM_PKG_NAME")) + (version (getenv "GUIX_ELM_PKG_VERSION")) + (elm-home (getenv "ELM_HOME")) + (registry-vhash (read-offline-registry->vhash)) + (app-dir (string-append elm-home "/../fake-app"))) + (mkdir-p (string-append app-dir "/src")) + (with-directory-excursion app-dir + (call-with-output-file "elm.json" + (lambda (out) + (write-json + `(@ ("type" . "application") + ("source-directories" "src") ;; intentionally no dot + ("elm-version" . ,(getenv "GUIX_ELM_VERSION")) + ("dependencies" + @ ("direct" + @ ,@(map (lambda (pkg) + (match (vhash-assoc pkg registry-vhash) + ((_ pkg-version . _) + (cons pkg + (if (equal? pkg name) + version + pkg-version))))) + (if (member name %essential-elm-packages) + %essential-elm-packages + (cons name %essential-elm-packages)))) + ("indirect" + @ ,@(if (member name %essential-elm-packages) + '() + (find-indirect-dependencies registry-vhash + name + version)))) + ("test-dependencies" + @ ("direct" @) + ("indirect" @))) + out))) + (patch-json-string-escapes "elm.json") + (with-output-to-file "src/Main.elm" + ;; the most trivial possible elm program + (lambda () + (display "module Main exposing (..) +main : Program () () () +main = Platform.worker + { init = \\_ -> ( (), Cmd.none ) + , update = \\_ -> \\_ -> ( (), Cmd.none ) + , subscriptions = \\_ -> Sub.none }")))))) + +(define* (build #:key native-inputs inputs #:allow-other-keys) + "Run `elm make` to build the Elm \"application\" generated by CONFIGURE." + (with-directory-excursion (string-append (getenv "ELM_HOME") "/../fake-app") + (invoke (search-input-file (or native-inputs inputs) "/bin/elm") + "make" + "src/Main.elm"))) + +(define* (check #:key tests? #:allow-other-keys) + "Does nothing, because the `elm-test` executable has not yet been packaged +for Guix." + (when tests? + (display "elm-test has not yet been packaged for Guix\n"))) + +(define* (install #:key outputs #:allow-other-keys) + "Installs the contents of the directory generated by STAGE, including any +files added by BUILD, to the Guix package output." + (copy-recursively + (string-append (getenv "ELM_HOME") "/../staged") + (string-append (assoc-ref outputs "out") "/share/elm"))) + +(define* (validate-compiled #:key outputs #:allow-other-keys) + "Checks that the files \"artifacts.dat\" and \"docs.json\" have been +installed." + (let ((base (string-append "/share/elm/" + (getenv "GUIX_ELM_VERSION") + "/packages/" + (getenv "GUIX_ELM_PKG_NAME") + "/" + (getenv "GUIX_ELM_PKG_VERSION"))) + (expected '("artifacts.dat" "docs.json"))) + (for-each (lambda (name) + (search-input-file outputs (string-append base "/" name))) + expected))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (add-after 'unpack 'prepare-elm-home prepare-elm-home) + (delete 'bootstrap) + (add-after 'patch-source-shebangs 'stage stage) + (add-after 'stage 'make-offline-registry-file make-offline-registry-file) + (replace 'configure configure) + (delete 'patch-generated-file-shebangs) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-before 'validate-documentation-location 'validate-compiled + validate-compiled))) + +(define* (elm-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Builds the given Elm project, applying all of the PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 64ef40e25a..60a754b9e9 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> -;;; Copyright © 2018, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2018, 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -28,6 +28,8 @@ emacs-batch-disable-compilation emacs-generate-autoloads emacs-byte-compile-directory + + as-display emacs-substitute-sexps emacs-substitute-variables)) @@ -82,6 +84,24 @@ true, evaluate using dynamic scoping." (byte-recompile-directory (file-name-as-directory ,dir) 0 1)))) (emacs-batch-eval expr))) +(define as-display ;syntactic keyword for 'emacs-substitute-sexps' + '(as display)) + +(define-syntax replacement-helper + (syntax-rules (as-display) + ((_ (leading-regexp replacement (as-display))) + `(progn (goto-char (point-min)) + (re-search-forward ,leading-regexp) + (kill-sexp) + (insert " ") + (insert ,(format #f "~a" replacement)))) + ((_ (leading-regexp replacement)) + `(progn (goto-char (point-min)) + (re-search-forward ,leading-regexp) + (kill-sexp) + (insert " ") + (insert ,(format #f "~s" replacement)))))) + (define-syntax emacs-substitute-sexps (syntax-rules () "Substitute the S-expression immediately following the first occurrence of @@ -95,14 +115,15 @@ LEADING-REGEXP by the string returned by REPLACEMENT in FILE. For example: This replaces the default values of the `w3m-command' and `w3m-image-viewer' variables declared in `w3m.el' with the results of the `string-append' calls -above. Note that LEADING-REGEXP uses Emacs regexp syntax." - ((emacs-substitute-sexps file (leading-regexp replacement) ...) +above. Note that LEADING-REGEXP uses Emacs regexp syntax. + +Here is another example that uses the '(as-display)' subform to avoid having +the Elisp procedure symbol from being double quoted: + (emacs-substitute-sexps \"gnugo.el\" + (\"defvar gnugo-xpms\" \"#'gnugo-imgen-create-xpms\" (as-display))" + ((_ file replacement-spec ...) (emacs-batch-edit-file file - `(progn (progn (goto-char (point-min)) - (re-search-forward ,leading-regexp) - (kill-sexp) - (insert " ") - (insert ,(format #f "~S" replacement))) + `(progn ,(replacement-helper replacement-spec) ... (basic-save-buffer)))))) @@ -117,11 +138,15 @@ REPLACEMENT in FILE. For example: This replaces the default values of the `w3m-command' and `w3m-image-viewer' variables declared in `w3m.el' with the results of the `string-append' calls -above." - ((emacs-substitute-variables file (variable replacement) ...) +above. Similarly to `emacs-substitute-sexps', the '(as-display)' subform can +be used to have the replacement formatted like `display' would, which can be +useful to avoid double quotes being added when the replacement is provided as +a string." + ((_ file (variable replacement modifier ...) ...) (emacs-substitute-sexps file ((string-append "(def[a-z]+[[:space:]\n]+" variable "\\>") - replacement) + replacement + modifier ...) ...)))) ;;; emacs-utils.scm ends here diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm index 010e0decff..d97f84838e 100644 --- a/guix/bzr-download.scm +++ b/guix/bzr-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2017, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -48,7 +48,7 @@ (define (bzr-package) "Return the default Bazaar package." (let ((distro (resolve-interface '(gnu packages version-control)))) - (module-ref distro 'bazaar))) + (module-ref distro 'breezy))) (define* (bzr-fetch ref hash-algo hash #:optional name @@ -64,7 +64,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (use-modules (guix build bzr)) (bzr-fetch (getenv "bzr url") (getenv "bzr reference") #$output - #:bzr-command (string-append #+bzr "/bin/bzr"))))) + #:bzr-command (string-append #+bzr "/bin/brz"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "bzr-branch") build diff --git a/guix/cache.scm b/guix/cache.scm index 51009809bd..be0de90e67 100644 --- a/guix/cache.scm +++ b/guix/cache.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,9 +18,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix cache) + #:use-module ((guix utils) #:select (with-atomic-file-output)) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module ((ice-9 textual-ports) #:select (get-string-all)) #:export (obsolete? delete-file* file-expiration-time @@ -93,7 +96,9 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups." (define last-expiry-date (catch 'system-error (lambda () - (call-with-input-file expiry-file read)) + (or (string->number + (call-with-input-file expiry-file get-string-all)) + 0)) (const 0))) (when (obsolete? last-expiry-date now cleanup-period) @@ -103,7 +108,7 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups." #:delete-entry delete-entry) (catch 'system-error (lambda () - (call-with-output-file expiry-file + (with-atomic-file-output expiry-file (cute write (time-second now) <>))) (lambda args ;; ENOENT means CACHE does not exist. diff --git a/guix/colors.scm b/guix/colors.scm index ae0a583d94..543f4c3ec5 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -26,17 +26,24 @@ #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:autoload (web uri) (encode-and-join-uri-path) #:export (color color? + coloring-procedure colorize-string highlight highlight/warn dim + colorize-full-matches color-rules color-output? - isatty?*)) + isatty?* + + supports-hyperlinks? + file-hyperlink + hyperlink)) ;;; Commentary: ;;; @@ -147,6 +154,27 @@ that subsequent output will not have any colors in effect." (define highlight/warn (coloring-procedure (color BOLD MAGENTA))) (define dim (coloring-procedure (color DARK))) +(define (colorize-full-matches rules) + "Return a procedure that, given a string, colorizes according to RULES. +RULES must be a list of regexp/color pairs; the whole match of a regexp is +colorized with the corresponding color." + (define proc + (lambda (str) + (if (string-index str #\nul) + str + (let loop ((rules rules)) + (match rules + (() + str) + (((regexp . color) . rest) + (match (regexp-exec regexp str) + (#f (loop rest)) + (m (string-append (proc (match:prefix m)) + (colorize-string (match:substring m) + color) + (proc (match:suffix m))))))))))) + proc) + (define (colorize-matches rules) "Return a procedure that, when passed a string, returns that string colorized according to RULES. RULES must be a list of tuples like: @@ -191,3 +219,31 @@ on." ((_ (regexp colors ...) ...) (colorize-matches `((,(make-regexp regexp) ,(color colors) ...) ...))))) + + +;;; +;;; Hyperlinks. +;;; + +(define (hyperlink uri text) + "Return a string that denotes a hyperlink using an OSC escape sequence as +documented at +<https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda>." + (string-append "\x1b]8;;" uri "\x1b\\" + text "\x1b]8;;\x1b\\")) + +(define* (supports-hyperlinks? #:optional (port (current-output-port))) + "Return true if PORT is a terminal that supports hyperlink escapes." + ;; Note that terminals are supposed to ignore OSC escapes they don't + ;; understand (this is the case of xterm as of version 349, for instance.) + ;; However, Emacs comint as of 26.3 does not ignore it and instead lets it + ;; through, hence the 'INSIDE_EMACS' special case below. + (and (isatty?* port) + (not (getenv "INSIDE_EMACS")))) + +(define* (file-hyperlink file #:optional (text file)) + "Return TEXT with escapes for a hyperlink to FILE." + (hyperlink (string-append "file://" (gethostname) + (encode-and-join-uri-path + (string-split file #\/))) + text)) diff --git a/guix/cpu.scm b/guix/cpu.scm index a44cd082f1..83e7dc615c 100644 --- a/guix/cpu.scm +++ b/guix/cpu.scm @@ -62,31 +62,51 @@ (lambda (port) (let loop ((vendor #f) (family #f) - (model #f)) + (model #f) + (flags (set))) (match (read-line port) ((? eof-object?) - #f) + (cpu (utsname:machine (uname)) + vendor family model flags)) + ;; vendor for x86_64 and i686 ((? (prefix? "vendor_id") str) (match (string-tokenize str) (("vendor_id" ":" vendor) - (loop vendor family model)))) + (loop vendor family model flags)))) + ;; vendor for aarch64 and armhf + ((? (prefix? "CPU implementer") str) + (match (string-tokenize str) + (("CPU" "implementer" ":" vendor) + (loop vendor family model flags)))) + ;; family for x86_64 and i686 ((? (prefix? "cpu family") str) (match (string-tokenize str) (("cpu" "family" ":" family) - (loop vendor (string->number family) model)))) + (loop vendor (string->number family) model flags)))) + ;; model for x86_64 and i686 ((? (prefix? "model") str) (match (string-tokenize str) (("model" ":" model) - (loop vendor family (string->number model))) + (loop vendor family (string->number model) flags)) (_ - (loop vendor family model)))) + (loop vendor family model flags)))) + ;; model for aarch64 and armhf + ((? (prefix? "CPU part") str) + (match (string-tokenize str) + (("CPU" "part" ":" model) + (loop vendor family (string->number (string-drop model 2) 16) flags)))) + ;; flags for x86_64 and i686 ((? (prefix? "flags") str) (match (string-tokenize str) (("flags" ":" flags ...) - (cpu (utsname:machine (uname)) - vendor family model (list->set flags))))) + (loop vendor family model (list->set flags))))) + ;; flags for aarch64 and armhf + ((? (prefix? "Features") str) + (match (string-tokenize str) + (("Features" ":" flags ...) + (loop vendor family model (list->set flags))))) (_ - (loop vendor family model)))))))) + (loop vendor family model flags)))))))) (define (cpu->gcc-architecture cpu) "Return the architecture name, suitable for GCC's '-march' flag, that @@ -191,6 +211,57 @@ corresponds to CPU, a record as returned by 'current-cpu'." ;; TODO: Recognize CENTAUR/CYRIX/NSC? "x86_64")) + ("aarch64" + ;; Transcribed from GCC's list of aarch64 processors in aarch64-cores.def + ;; What to do with big.LITTLE cores? + (match (cpu-vendor cpu) + ("0x41" + (match (cpu-model cpu) + ((or #xd02 #xd04 #xd03 #xd07 #xd08 #xd09) + "armv8-a") + ((or #xd05 #xd0a #xd0b #xd0e #xd0d #xd41 #xd42 #xd4b #xd46 #xd43 #xd44 #xd41 #xd0c #xd4a) + "armv8.2-a") + (#xd40 + "armv8.4-a") + (#xd15 + "armv8-r") + ((or #xd46 #xd47 #xd48 #xd49 #xd4f) + "armv9-a"))) + ("0x42" + "armv8.1-a") + ("0x43" + (match (cpu-model cpu) + ((or #x0a0 #x0a1 #x0a2 #x0a3) + "armv8-a") + (#x0af + "armv8.1-a") + ((or #x0b0 #x0b1 #x0b2 #x0b3 #x0b4 #x0b5) + "armv8.2-a") + (#x0b8 + "armv8.3-a"))) + ("0x46" + "armv8.2-a") + ("0x48" + "armv8.2-a") + ("0x50" + "armv8-a") + ("0x51" + (match (cpu-model cpu) + (#xC00 + "armv8-a") + (#x516 + "armv8.1-a") + (#xC01 + "armv8.4-a"))) + ("0x53" + "armv8-a") + ("0x68" + "armv8-a") + ("0xC0" + "armv8.6-a") + (_ + "armv8-a")) + "armv8-a") (architecture - ;; TODO: AArch64. + ;; TODO: More architectures architecture))) diff --git a/guix/deprecation.scm b/guix/deprecation.scm index 09a27789c9..8147a01e24 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -25,6 +25,7 @@ define-deprecated/public define-deprecated/alias + define-deprecated/public-alias warn-about-old-daemon warn-about-deprecation)) @@ -124,3 +125,10 @@ This will write a deprecation warning to GUIX-WARNING-PORT." (id (identifier? #'id) #'replacement))))) + +(define-syntax-rule (define-deprecated/public-alias deprecated replacement) + "Like define-deprecated/alias, but exporting DEPRECATED. +It is assumed, that REPLACEMENT is already public." + (begin + (define-deprecated/alias deprecated replacement) + (export deprecated))) diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 337a73c1a2..9f0d558f2f 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -39,6 +39,7 @@ source-properties->location location->source-properties location->string + location->hyperlink &error-location error-location? @@ -203,7 +204,10 @@ macro-expansion time." (gettext prefix %gettext-domain)))) (if location (format (guix-warning-port) "~a: ~a" - (location-color (location->string location)) + (location-color + (if (supports-hyperlinks? (guix-warning-port)) + (location->hyperlink location) + (location->string location))) (prefix-color prefix)) (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" (program-name) (program-name) @@ -228,7 +232,7 @@ macro-expansion time." by Guile's `source-properties', `frame-source', `current-source-location', etc." ;; In accordance with the GCS, start line and column numbers at 1. Note - ;; that unlike LINE and `port-column', COL is actually 1-indexed here... + ;; that unlike LINE and `port-column', COL is actually 0-indexed here... (match loc ((('line . line) ('column . col) ('filename . file)) ;common case (and file line col @@ -259,6 +263,16 @@ a location object." (($ <location> file line column) (format #f "~a:~a:~a" file line column)))) +(define (location->hyperlink location) + "Return a string corresponding to LOCATION, with escapes for a hyperlink." + (let ((str (location->string location)) + (file (if (string-prefix? "/" (location-file location)) + (location-file location) + (search-path %load-path (location-file location))))) + (if file + (file-hyperlink file str) + str))) + (define-condition-type &error-location &error error-location? (location error-location)) ;<location> diff --git a/guix/download.scm b/guix/download.scm index 4e219c9f49..1a80e3abd2 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2016, 2017, 2020, 2022 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2019 Guy Fleury Iteriteka <hoonandon@gmail.com> ;;; @@ -245,6 +246,11 @@ "http://cran.stat.auckland.ac.nz/" "http://cran.mirror.ac.za/" "http://cran.csie.ntu.edu.tw/") + (ctan + ;; This is the CTAN mirror multiplexor service, which automatically + ;; redirect to a mirror in or close to the country of the requester + ;; (see: https://ctan.org/mirrors/). + "https://mirror.ctan.org/") (imagemagick ;; from http://www.imagemagick.org/script/download.php ;; (without mirrors that are unavailable or not up to date) @@ -261,8 +267,8 @@ "http://ftp.debian.org/debian/" "http://archive.debian.org/debian/") (kde - "http://download.kde.org" - "http://download.kde.org/Attic" ; for when it gets archived. + "https://download.kde.org/" + "https://download.kde.org/Attic/" ; for when it gets archived. ;; Mirrors from http://files.kde.org/extra/mirrors.html ;; Europe "http://mirror.easyname.at/kde" diff --git a/guix/gexp.scm b/guix/gexp.scm index 9fdb7a30be..ef92223048 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -118,6 +118,7 @@ mixed-text-file file-union directory-union + references-file imported-files imported-modules @@ -2173,6 +2174,49 @@ is true, the derivation will not print anything." #:resolve-collision (ungexp resolve-collision))))))))) +(define* (references-file item #:optional (name "references") + #:key guile) + "Return a file that contains the list of direct and indirect references (the +closure) of ITEM." + (if (struct? item) ;lowerable object + (computed-file name + (gexp (begin + (use-modules (srfi srfi-1) + (ice-9 rdelim) + (ice-9 match)) + + (define (drop-lines port n) + ;; Drop N lines read from PORT. + (let loop ((n n)) + (unless (zero? n) + (read-line port) + (loop (- n 1))))) + + (define (read-graph port) + ;; Return the list of references read from + ;; PORT. This is a stripped-down version of + ;; 'read-reference-graph'. + (let loop ((items '())) + (match (read-line port) + ((? eof-object?) + (delete-duplicates items)) + ((? string? item) + (let ((deriver (read-line port)) + (count + (string->number (read-line port)))) + (drop-lines port count) + (loop (cons item items))))))) + + (call-with-output-file (ungexp output) + (lambda (port) + (write (call-with-input-file "graph" + read-graph) + port))))) + #:guile guile + #:options `(#:local-build? #t + #:references-graphs (("graph" ,item)))) + (plain-file name "()"))) + ;;; ;;; Syntactic sugar. diff --git a/guix/git-download.scm b/guix/git-download.scm index 5e624b9ae9..a1566bed4d 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -104,6 +104,12 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define gnutls (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) + (define glibc-locales + ;; Note: pick the '-final' variant to avoid circular dependency on + ;; i586-gnu, where 'glibc-utf8-locales' indirectly depends on Git. + (module-ref (resolve-interface '(gnu packages commencement)) + 'glibc-utf8-locales-final)) + (define modules (delete '(guix config) (source-module-closure '((guix build git) @@ -125,6 +131,13 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define recursive? (call-with-input-string (getenv "git recursive?") read)) + ;; Let Guile interpret file names as UTF-8, otherwise + ;; 'delete-file-recursively' might fail to delete all of + ;; '.git'--see <https://issues.guix.gnu.org/54893>. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + ;; The 'git submodule' commands expects Coreutils, sed, ;; grep, etc. to be in $PATH. (set-path-environment-variable "PATH" '("bin") diff --git a/guix/http-client.scm b/guix/http-client.scm index 143ed6de31..9138a627ac 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -145,7 +145,7 @@ Raise an '&http-get-error' condition if downloading fails." (or (not (uri-host uri)) (string=? host (uri-host uri))) port) - (open-connection uri* + (open-connection uri #:verify-certificate? verify-certificate? #:timeout timeout))))) @@ -296,6 +296,7 @@ returning." #f #f base64url-alphabet)))) (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text? + (headers '((user-agent . "GNU Guile"))) (write-cache dump-port) (cache-miss (const #t)) (log-port (current-error-port)) @@ -307,21 +308,27 @@ Call WRITE-CACHE with the HTTP input port and the cache output port to write the data to cache. Call CACHE-MISS with URI just before fetching data from URI. +HEADERS is an alist of extra HTTP headers, to which cache-related headers are +added automatically as appropriate. + TIMEOUT specifies the timeout in seconds for connection establishment. Write information about redirects to LOG-PORT." - (let ((file (cache-file-for-uri uri))) + (let* ((uri (if (string? uri) + (string->uri uri) + uri)) + (file (cache-file-for-uri uri))) (define (update-cache cache-port) (define cache-time (and cache-port (stat:mtime (stat cache-port)))) - (define headers - `((user-agent . "GNU Guile") - ,@(if cache-time - `((if-modified-since - . ,(time-utc->date (make-time time-utc 0 cache-time)))) - '()))) + (define extended-headers + (if cache-time + `((if-modified-since + . ,(time-utc->date (make-time time-utc 0 cache-time))) + ,@headers) + headers)) ;; Update the cache and return an input port. (guard (c ((http-get-error? c) @@ -332,7 +339,8 @@ Write information about redirects to LOG-PORT." (raise c)))) (let ((port (http-fetch uri #:text? text? #:log-port log-port - #:headers headers #:timeout timeout))) + #:headers extended-headers + #:timeout timeout))) (cache-miss uri) (mkdir-p (dirname file)) (when cache-port diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 98d7234098..4410c12500 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -74,6 +74,7 @@ cabal-executable-dependencies cabal-library? + cabal-library-name cabal-library-dependencies cabal-test-suite? @@ -149,7 +150,7 @@ to the stack." (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB COMMON OCURLY) (left: OR) (left: PROPERTY AND) - (right: ELSE NOT)) + (right: ELIF ELSE NOT)) ;; --- rules (body (properties sections) : (append $1 $2)) (sections (sections flags) : (append $1 $2) @@ -189,36 +190,36 @@ to the stack." (bm-sec) : (list $1)) (bm-sec (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3) (BENCHMARK open exprs close) : `(section benchmark ,$1 ,$3)) - (lib-sec (LIB OCURLY exprs CCURLY) : `(section library ,$3) - (LIB open exprs close) : `(section library ,$3)) + (lib-sec (LIB OCURLY exprs CCURLY) : `(section library ,$1 ,$3) + (LIB open exprs close) : `(section library ,$1 ,$3)) (exprs (exprs PROPERTY) : (append $1 (list $2)) (PROPERTY) : (list $1) - (exprs if-then-else) : (append $1 (list $2)) - (if-then-else) : (list $1) - (exprs if-then) : (append $1 (list $2)) - (if-then) : (list $1)) - (if-then-else (IF tests OCURLY exprs CCURLY ELSE OCURLY exprs CCURLY) - : `(if ,$2 ,$4 ,$8) - (IF tests open exprs close ELSE OCURLY exprs CCURLY) - : `(if ,$2 ,$4 ,$8) - ;; The 'open' token after 'tests' is shifted after an 'exprs' - ;; is found. This is because, instead of 'exprs' a 'OCURLY' - ;; token is a valid alternative. For this reason, 'open' - ;; pushes a <parse-context> with a line indentation equal to - ;; the indentation of 'exprs'. - ;; - ;; Differently from this, without the rule above this - ;; comment, when an 'ELSE' token is found, the 'open' token - ;; following the 'ELSE' would be shifted immediately, before - ;; the 'exprs' is found (because there are no other valid - ;; tokens). The 'open' would therefore create a - ;; <parse-context> with the indentation of 'ELSE' and not - ;; 'exprs', creating an inconsistency. We therefore allow - ;; mixed style conditionals. - (IF tests open exprs close ELSE open exprs close) - : `(if ,$2 ,$4 ,$8)) - (if-then (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ()) - (IF tests open exprs close) : `(if ,$2 ,$4 ())) + (exprs elif-else) : (append $1 (list ($2 '(())))) + (elif-else) : (list ($1 '(())))) + ;; LALR(1) parsers prefer to be left-recursive, which make if-statements slightly involved. + ;; XXX: This technically allows multiple else statements. + (elif-else (elif-else ELIF tests OCURLY exprs CCURLY) : (lambda (y) ($1 (list (append (list 'if $3 $5) y)))) + (elif-else ELIF tests open exprs close) : (lambda (y) ($1 (list (append (list 'if $3 $5) y)))) + (elif-else ELSE OCURLY exprs CCURLY) : (lambda (y) ($1 (list $4))) + ;; The 'open' token after 'tests' is shifted after an 'exprs' + ;; is found. This is because, instead of 'exprs' a 'OCURLY' + ;; token is a valid alternative. For this reason, 'open' + ;; pushes a <parse-context> with a line indentation equal to + ;; the indentation of 'exprs'. + ;; + ;; Differently from this, without the rule above this + ;; comment, when an 'ELSE' token is found, the 'open' token + ;; following the 'ELSE' would be shifted immediately, before + ;; the 'exprs' is found (because there are no other valid + ;; tokens). The 'open' would therefore create a + ;; <parse-context> with the indentation of 'ELSE' and not + ;; 'exprs', creating an inconsistency. We therefore allow + ;; mixed style conditionals. + (elif-else ELSE open exprs close) : (lambda (y) ($1 (list $4))) + ;; Terminating rule. + (if-then) : (lambda (y) (append $1 y))) + (if-then (IF tests OCURLY exprs CCURLY) : (list 'if $2 $4) + (IF tests open exprs close) : (list 'if $2 $4)) (tests (TEST OPAREN ID CPAREN) : `(,$1 ,$3) (TRUE) : 'true (FALSE) : 'false @@ -354,7 +355,7 @@ matching a string against the created regexp." (make-regexp pat)))) (cut regexp-exec rx <>))) -(define is-layout-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?[^{}]*)$" +(define is-layout-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?[^{}]*)" regexp/icase)) (define is-braced-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*\\{[ \t]*$" @@ -382,9 +383,12 @@ matching a string against the created regexp." (define is-benchmark (make-rx-matcher "^benchmark +([a-z0-9_-]+)" regexp/icase)) -(define is-lib (make-rx-matcher "^library *" regexp/icase)) +;; Libraries can have optional names since Cabal 2.0. +(define is-lib (make-rx-matcher "^library(\\s+([a-z0-9_-]+))?\\s*" regexp/icase)) -(define is-else (make-rx-matcher "^else" regexp/icase)) +(define (is-else s) (string-ci=? s "else")) + +(define (is-elif s) (string-ci=? s "elif")) (define (is-if s) (string-ci=? s "if")) @@ -402,8 +406,8 @@ matching a string against the created regexp." (define (is-id s port loc) (let ((cabal-reserved-words - '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup" - "source-repository" "benchmark" "common")) + '("if" "else" "elif" "library" "flag" "executable" "test-suite" + "custom-setup" "source-repository" "benchmark" "common")) (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) (c (peek-char port))) (unread-string spaces port) @@ -463,7 +467,10 @@ string with the read characters." (value (match:substring k-v-rx-res 2))) (make-lexical-token 'PROPERTY loc - (list key `(,(read-value port value (current-indentation))))))) + (list key `(,(if (eqv? (peek-char port) #\newline) ; The next character + ; is not necessarily a newline if a bracket follows the property. + (read-value port value (current-indentation)) + value)))))) (define (lex-braced-property k-rx-res loc port) (let ((key (string-downcase (match:substring k-rx-res 1)))) @@ -471,8 +478,9 @@ string with the read characters." 'PROPERTY loc (list key `(,(read-braced-value port)))))) -(define (lex-rx-res rx-res token loc) - (let ((name (string-downcase (match:substring rx-res 1)))) +(define* (lex-rx-res rx-res token loc #:optional (substring-id 1)) + (let* ((match (match:substring rx-res substring-id)) + (name (if match (string-downcase match) match))) (make-lexical-token token loc name))) (define (lex-flag flag-rx-res loc) (lex-rx-res flag-rx-res 'FLAG loc)) @@ -490,10 +498,12 @@ string with the read characters." (define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc)) -(define (lex-lib loc) (make-lexical-token 'LIB loc #f)) +(define (lex-lib lib-rx-res loc) (lex-rx-res lib-rx-res 'LIB loc 2)) (define (lex-else loc) (make-lexical-token 'ELSE loc #f)) +(define (lex-elif loc) (make-lexical-token 'ELIF loc #f)) + (define (lex-if loc) (make-lexical-token 'IF loc #f)) (define (lex-true loc) (make-lexical-token 'TRUE loc #t)) @@ -566,8 +576,10 @@ location." (define (lex-word port loc) "Process tokens which can be recognized by reading the next word form PORT. LOC is the current port location." - (let* ((w (read-delimited " <>=()\t\n" port 'peek))) + (let* ((w (read-delimited " <>=():\t\n" port 'peek))) (cond ((is-if w) (lex-if loc)) + ((is-elif w) (lex-elif loc)) + ((is-else w) (lex-else loc)) ((is-test w port) (lex-test w loc)) ((is-true w) (lex-true loc)) ((is-false w) (lex-false loc)) @@ -590,12 +602,13 @@ the current port location." ((is-common s) => (cut lex-common <> loc)) ((is-custom-setup s) => (cut lex-custom-setup <> loc)) ((is-benchmark s) => (cut lex-benchmark <> loc)) - ((is-lib s) (lex-lib loc)) - ((is-else s) (lex-else loc)) + ((is-lib s) => (cut lex-lib <> loc)) (else (unread-string s port) #f)))) (define (lex-property port loc) - (let* ((s (read-delimited "\n" port 'peek))) + ;; Stop reading on a }, so closing brackets (for example during + ;; if-clauses) work properly. + (let* ((s (read-delimited "\n}" port 'peek))) (cond ((is-braced-property s) => (cut lex-braced-property <> loc port)) ((is-layout-property s) => (cut lex-layout-property <> loc port)) @@ -719,8 +732,9 @@ If #f use the function 'port-filename' to obtain it." (dependencies cabal-executable-dependencies)) ; list of <cabal-dependency> (define-record-type <cabal-library> - (make-cabal-library dependencies) + (make-cabal-library name dependencies) cabal-library? + (name cabal-library-name) (dependencies cabal-library-dependencies)) ; list of <cabal-dependency> (define-record-type <cabal-test-suite> @@ -851,9 +865,6 @@ the ordering operation and the version." (list 'section 'flag name parameters)) (('section 'custom-setup parameters) (list 'section 'custom-setup parameters)) - ;; library does not have a name parameter - (('section 'library parameters) - (list 'section 'library (eval parameters))) (('section type name parameters) (list 'section type name (eval parameters))) (((? string? name) values) @@ -913,6 +924,8 @@ pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of: name (lookup-join parameters "type") (lookup-join parameters "location"))) + ((library) (make-cabal-library name + (dependencies parameters))) ((flag) (let* ((default (lookup-join parameters "default")) (default-true-or-false @@ -929,8 +942,6 @@ pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of: default-true-or-false manual-true-or-false))) (else #f))) - (('section (? (cut equal? <> section-type) lib) parameters) - (make-cabal-library (dependencies parameters))) (_ #f)) sexp)) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index e848ebc789..4e1ce7c010 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -156,9 +156,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.14. Bioconductor packages should be +;; The latest Bioconductor release is 3.15. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.14") +(define %bioconductor-version "3.15") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" diff --git a/guix/import/elm.scm b/guix/import/elm.scm new file mode 100644 index 0000000000..74902b8617 --- /dev/null +++ b/guix/import/elm.scm @@ -0,0 +1,210 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix import elm) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (guix utils) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix http-client) + #:use-module (guix memoization) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module ((guix ui) #:select (display-hint)) + #:use-module ((guix build utils) + #:select ((package-name->name+version + . hyphen-package-name->name+version) + find-files + invoke)) + #:use-module (guix import utils) + #:use-module (guix git) + #:use-module (guix import json) + #:autoload (gcrypt hash) (hash-algorithm sha256) + #:use-module (json) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix build-system elm) + #:export (elm-recursive-import + %elm-package-registry + %current-elm-checkout + elm->guix-package)) + +(define %registry-url + ;; It is much nicer to fetch this small (< 40 KB gzipped) + ;; file once than to do many HTTP requests. + "https://package.elm-lang.org/all-packages") + +(define %elm-package-registry + ;; This is a parameter to support both testing and memoization. + ;; In pseudo-code, it has the contract: + ;; (parameter/c (-> json/c) + ;; (promise/c (vhash/c string? (listof string?)))) + ;; To set the parameter, provide a thunk that returns a value suitable + ;; as an argument to 'json->registry-vhash'. Accessing the parameter + ;; returns a promise wrapping the resulting vhash. + (make-parameter + (lambda () + (cond + ((json-fetch %registry-url #:http-fetch http-fetch/cached)) + (else + (raise (formatted-message + (G_ "error downloading Elm package registry from ~a") + %registry-url))))) + (lambda (thunk) + (delay (json->registry-vhash (thunk)))))) + +(define (json->registry-vhash jsobject) + "Parse the '(json)' module's representation of the Elm package registry to a +vhash mapping package names to lists of available versions, sorted from latest +to oldest." + (fold (lambda (entry vh) + (match entry + ((name . vec) + (vhash-cons name + (sort (vector->list vec) version>?) + vh)))) + vlist-null + jsobject)) + +(define (json->direct-dependencies jsobject) + "Parse the '(json)' module's representation of an 'elm.json' file's +'dependencies' or 'test-dependencies' field to a list of strings naming direct +dependencies, handling both the 'package' and 'application' grammars." + (cond + ;; *unspecified* + ((not (pair? jsobject)) + '()) + ;; {"type":"application"} + ((every (match-lambda + (((or "direct" "indirect") (_ . _) ...) + #t) + (_ + #f)) + jsobject) + (map car (or (assoc-ref jsobject "direct") '()))) + ;; {"type":"package"} + (else + (map car jsobject)))) + +;; <project-info> handles both {"type":"package"} and {"type":"application"} +(define-json-mapping <project-info> make-project-info project-info? + json->project-info + (dependencies project-info-dependencies + "dependencies" json->direct-dependencies) + (test-dependencies project-info-test-dependencies + "test-dependencies" json->direct-dependencies) + ;; "synopsis" and "license" may be missing for {"type":"application"} + (synopsis project-info-synopsis + "summary" (lambda (x) + (if (string? x) + x + ""))) + (license project-info-license + "license" (lambda (x) + (if (string? x) + (spdx-string->license x) + #f)))) + +(define %current-elm-checkout + ;; This is a parameter for testing purposes. + (make-parameter + (lambda (name version) + (define-values (checkout _commit _relation) + ;; Elm requires that packages use this very specific format + (update-cached-checkout (string-append "https://github.com/" name) + #:ref `(tag . ,version))) + checkout))) + +(define (make-elm-package-sexp name version) + "Return two values: the `package' s-expression for the Elm package with the +given NAME and VERSION, and a list of Elm packages it depends on." + (define checkout + ((%current-elm-checkout) name version)) + (define info + (call-with-input-file (string-append checkout "/elm.json") + json->project-info)) + (define dependencies + (project-info-dependencies info)) + (define test-dependencies + (project-info-test-dependencies info)) + (define guix-name + (elm->package-name name)) + (values + `(package + (name ,guix-name) + (version ,version) + (source (elm-package-origin + ,name + version ;; no , + (base32 + ,(bytevector->nix-base32-string + (file-hash* checkout + #:algorithm (hash-algorithm sha256) + #:recursive? #t))))) + (build-system elm-build-system) + ,@(maybe-propagated-inputs (map elm->package-name dependencies)) + ,@(maybe-inputs (map elm->package-name test-dependencies)) + (home-page ,(string-append "https://package.elm-lang.org/packages/" + name "/" version)) + (synopsis ,(project-info-synopsis info)) + (description + ;; Try to use the first paragraph of README.md (which Elm requires), + ;; or fall back to synopsis otherwise. + ,(beautify-description + (match (chunk-lines (call-with-input-file + (string-append checkout "/README.md") + read-lines)) + ((_ par . _) + (string-join par " ")) + (_ + (project-info-synopsis info))))) + ,@(let ((inferred-name (infer-elm-package-name guix-name))) + (if (equal? inferred-name name) + '() + `((properties '((upstream-name . ,name)))))) + (license ,(project-info-license info))) + (append dependencies test-dependencies))) + +(define elm->guix-package + (memoize + (lambda* (package-name #:key repo version) + "Fetch the metadata for PACKAGE-NAME, an Elm package registered at +package.elm.org, and return two values: the `package' s-expression +corresponding to that package (or #f on failure) and a list of Elm +dependencies." + (cond + ((vhash-assoc package-name (force (%elm-package-registry))) + => (match-lambda + ((_found latest . _versions) + (make-elm-package-sexp package-name (or version latest))))) + (else + (values #f '())))))) + +(define* (elm-recursive-import package-name #:optional version) + (recursive-import package-name + #:version version + #:repo->guix-package elm->guix-package + #:guix-name elm->package-name)) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 0d6c77e399..878a7d2f9c 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -222,13 +222,15 @@ object." '()))) (map cabal-dependency-name custom-setup-dependencies))) -(define (filter-dependencies dependencies own-name) +(define (filter-dependencies dependencies own-names) "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a -list with the names of dependencies. OWN-NAME is the name of the Cabal -package being processed and is used to filter references to itself." - (filter (lambda (d) (not (member (string-downcase d) - (cons own-name ghc-standard-libraries)))) - dependencies)) +list with the names of dependencies. OWN-NAMES is the name of the Cabal +package being processed and its internal libaries and is used to filter +references to itself." + (let ((ignored-dependencies (map string-downcase + (append own-names ghc-standard-libraries)))) + (filter (lambda (d) (not (member (string-downcase d) ignored-dependencies))) + dependencies))) (define* (hackage-module->sexp cabal cabal-hash #:key (include-test-dependencies? #t)) @@ -248,9 +250,12 @@ the hash of the Cabal file." (define source-url (hackage-source-url name version)) + (define own-names (cons (cabal-package-name cabal) + (filter (lambda (x) (not (eqv? x #f))) + (map cabal-library-name (cabal-package-library cabal))))) + (define hackage-dependencies - (filter-dependencies (cabal-dependencies->names cabal) - (cabal-package-name cabal))) + (filter-dependencies (cabal-dependencies->names cabal) own-names)) (define hackage-native-dependencies (lset-difference @@ -260,7 +265,7 @@ the hash of the Cabal file." (cabal-test-dependencies->names cabal) '()) (cabal-custom-setup-dependencies->names cabal)) - (cabal-package-name cabal)) + own-names) hackage-dependencies)) (define dependencies diff --git a/guix/import/json.scm b/guix/import/json.scm index 0c98bb25b8..ae00ee929e 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -35,13 +35,16 @@ json->scheme-file)) (define* (json-fetch url + #:key + (http-fetch http-fetch) ;; Note: many websites returns 403 if we omit a ;; 'User-Agent' header. - #:key (headers `((user-agent . "GNU Guile") - (Accept . "application/json")))) + (headers `((user-agent . "GNU Guile") + (Accept . "application/json")))) "Return a representation of the JSON resource URL (a list or hash table), or #f if URL returns 403 or 404. HEADERS is a list of HTTP headers to pass in -the query." +the query. HTTP-FETCH is called to perform the request: for example, to +enable caching, supply 'http-fetch/cached'." (guard (c ((and (http-get-error? c) (let ((error (http-get-error-code c))) (or (= 403 error) diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index 3b2cdcdcac..43cfb533e2 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -427,10 +427,10 @@ DEPENDENCIES as a list of AUTHOR/NAME strings." (match sort ("score" (warning - (G_ "The implementation with the highest score will be choosen!~%"))) + (G_ "The implementation with the highest score will be chosen!~%"))) ("downloads" (warning - (G_ "The implementation that has been downloaded the most will be choosen!~%")))) + (G_ "The implementation that has been downloaded the most will be chosen!~%")))) (package-full-name too)) (() (warning diff --git a/guix/import/opam.scm b/guix/import/opam.scm index f569c921b1..b4b5a6eaad 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -61,8 +61,8 @@ ;; Define a PEG parser for the opam format (define-peg-pattern comment none (and "#" (* COMMCHR) "\n")) -(define-peg-pattern SP none (or " " "\n" comment)) -(define-peg-pattern SP2 body (or " " "\n")) +(define-peg-pattern SP none (or " " "\n" "\t" comment)) +(define-peg-pattern SP2 body (or " " "\n" "\t")) (define-peg-pattern QUOTE none "\"") (define-peg-pattern QUOTE2 body "\"") (define-peg-pattern COLON none ":") @@ -324,6 +324,20 @@ path to the repository." (filter-map get-opam-repository repositories-specs)) (warning (G_ "opam: package '~a' not found~%") name))) +(define (opam->guix-source url-dict) + (let ((source-url (and url-dict + (or (metadata-ref url-dict "src") + (metadata-ref url-dict "archive"))))) + (if source-url + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch source-url temp) + `(origin + (method url-fetch) + (uri ,source-url) + (sha256 (base32 ,(guix-hash-url temp))))))) + 'no-source-information))) + (define* (opam->guix-package name #:key (repo 'opam) version) "Import OPAM package NAME from REPOSITORY (a directory name) or, if REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp @@ -332,9 +346,7 @@ or #f on failure." (opam-file (opam-fetch name with-opam)) (version (assoc-ref opam-file "version")) (opam-content (assoc-ref opam-file "metadata")) - (url-dict (metadata-ref opam-content "url")) - (source-url (or (metadata-ref url-dict "src") - (metadata-ref url-dict "archive"))) + (source (opam->guix-source (metadata-ref opam-content "url"))) (requirements (metadata-ref opam-content "depends")) (names (dependency-list->names requirements)) (dependencies (filter-dependencies names)) @@ -348,41 +360,34 @@ or #f on failure." (not (member name '("dune" "jbuilder")))) native-dependencies)))) (let ((use-dune? (member "dune" names))) - (call-with-temporary-output-file - (lambda (temp port) - (and (url-fetch source-url temp) - (values - `(package - (name ,(ocaml-name->guix-name name)) - (version ,version) - (source - (origin - (method url-fetch) - (uri ,source-url) - (sha256 (base32 ,(guix-hash-url temp))))) - (build-system ,(if use-dune? - 'dune-build-system - 'ocaml-build-system)) - ,@(if (null? inputs) - '() - `((propagated-inputs (list ,@inputs)))) - ,@(if (null? native-inputs) - '() - `((native-inputs (list ,@native-inputs)))) - ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) - '() - `((properties - ,(list 'quasiquote `((upstream-name . ,name)))))) - (home-page ,(metadata-ref opam-content "homepage")) - (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(beautify-description - (metadata-ref opam-content "description"))) - (license ,(spdx-string->license - (metadata-ref opam-content "license")))) - (filter - (lambda (name) - (not (member name '("dune" "jbuilder")))) - dependencies)))))))) + (values + `(package + (name ,(ocaml-name->guix-name name)) + (version ,version) + (source ,source) + (build-system ,(if use-dune? + 'dune-build-system + 'ocaml-build-system)) + ,@(if (null? inputs) + '() + `((propagated-inputs (list ,@inputs)))) + ,@(if (null? native-inputs) + '() + `((native-inputs (list ,@native-inputs)))) + ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) + '() + `((properties + ,(list 'quasiquote `((upstream-name . ,name)))))) + (home-page ,(metadata-ref opam-content "homepage")) + (synopsis ,(metadata-ref opam-content "synopsis")) + (description ,(beautify-description + (metadata-ref opam-content "description"))) + (license ,(spdx-string->license + (metadata-ref opam-content "license")))) + (filter + (lambda (name) + (not (member name '("dune" "jbuilder")))) + dependencies))))) (define* (opam-recursive-import package-name #:key repo) (recursive-import package-name diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 77b5f12f72..392fc9700b 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -457,9 +457,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (match guix-dependencies ((required-inputs native-inputs) (when (string-suffix? ".zip" source-url) - (set! native-inputs (cons - '("unzip" ,unzip) - native-inputs))) + (set! native-inputs (cons 'unzip native-inputs))) (values `(package (name ,(python->package-name name)) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 9cadbb3d5f..26eebfece5 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -11,6 +11,7 @@ ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2022 Alice Brenon <alice.brenon@ens-lyon.fr> +;;; Copyright © 2022 Kyle Meyer <kyle@kyleam.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -132,7 +133,7 @@ of the string VERSION is replaced by the symbol 'version." "Convert STR, a SPDX formatted license identifier, to a license object. Return #f if STR does not match any known identifiers." ;; https://spdx.org/licenses/ - ;; The psfl, gfl1.0, nmap, repoze + ;; The gfl1.0, nmap, repoze ;; licenses doesn't have SPDX identifiers ;; ;; Please update guix/licenses.scm when modifying @@ -143,14 +144,17 @@ of the string VERSION is replaced by the symbol 'version." ;; or "GPL-N-or-later" as appropriate. Likewise for LGPL ;; and AGPL ("AGPL-1.0" 'license:agpl1) + ("AGPL-1.0-only" 'license:agpl1) ("AGPL-3.0" 'license:agpl3) ("AGPL-3.0-only" 'license:agpl3) ("AGPL-3.0-or-later" 'license:agpl3+) ("Apache-1.1" 'license:asl1.1) ("Apache-2.0" 'license:asl2.0) + ("APSL-2.0" 'license:apsl2) ("BSL-1.0" 'license:boost1.0) ("0BSD" 'license:bsd-0) - ("BSD-2-Clause-FreeBSD" 'license:bsd-2) + ("BSD-2-Clause" 'license:bsd-2) + ("BSD-2-Clause-FreeBSD" 'license:bsd-2) ;flagged as deprecated on spdx ("BSD-3-Clause" 'license:bsd-3) ("BSD-4-Clause" 'license:bsd-4) ("CC0-1.0" 'license:cc0) @@ -161,17 +165,30 @@ of the string VERSION is replaced by the symbol 'version." ("CC-BY-SA-3.0" 'license:cc-by-sa3.0) ("CC-BY-SA-4.0" 'license:cc-by-sa4.0) ("CDDL-1.0" 'license:cddl1.0) + ("CDDL-1.1" 'license:cddl1.1) + ("CECILL-2.1" 'license:cecill) + ("CECILL-B" 'license:cecill-b) ("CECILL-C" 'license:cecill-c) ("Artistic-2.0" 'license:artistic2.0) ("ClArtistic" 'license:clarified-artistic) + ("copyleft-next-0.3.0" 'license:copyleft-next) ("CPL-1.0" 'license:cpl1.0) ("EPL-1.0" 'license:epl1.0) + ("EPL-2.0" 'license:epl2.0) + ("EUPL-1.2" 'license:eupl1.2) ("MIT" 'license:expat) + ("MIT-0" 'license:expat-0) ("FTL" 'license:freetype) + ("FreeBSD-DOC" 'license:freebsd-doc) ("Freetype" 'license:freetype) + ("FSFAP" 'license:fsf-free) + ("FSFUL" 'license:fsf-free) ("GFDL-1.1" 'license:fdl1.1+) + ("GFDL-1.1-or-later" 'license:fdl1.1+) ("GFDL-1.2" 'license:fdl1.2+) + ("GFDL-1.2-or-later" 'license:fdl1.2+) ("GFDL-1.3" 'license:fdl1.3+) + ("GFDL-1.3-or-later" 'license:fdl1.3+) ("Giftware" 'license:giftware) ("GPL-1.0" 'license:gpl1) ("GPL-1.0-only" 'license:gpl1) @@ -204,14 +221,24 @@ of the string VERSION is replaced by the symbol 'version." ("LGPL-3.0-only" 'license:lgpl3) ("LGPL-3.0+" 'license:lgpl3+) ("LGPL-3.0-or-later" 'license:lgpl3+) + ("LPPL-1.0" 'license:lppl) + ("LPPL-1.1" 'license:lppl) + ("LPPL-1.2" 'license:lppl1.2) + ("LPPL-1.3a" 'license:lppl1.3a) + ("LPPL-1.3c" 'license:lppl1.3c) + ("MirOS" 'license:miros) ("MPL-1.0" 'license:mpl1.0) ("MPL-1.1" 'license:mpl1.1) ("MPL-2.0" 'license:mpl2.0) ("MS-PL" 'license:ms-pl) ("NCSA" 'license:ncsa) + ("OGL-UK-1.0" 'license:ogl-psi1.0) ("OpenSSL" 'license:openssl) ("OLDAP-2.8" 'license:openldap2.8) + ("OPL-1.0" 'license:opl1.0+) ("CUA-OPL-1.0" 'license:cua-opl1.0) + ("PSF-2.0" 'license:psfl) + ("OSL-2.1" 'license:osl2.1) ("QPL-1.0" 'license:qpl) ("Ruby" 'license:ruby) ("SGI-B-2.0" 'license:sgifreeb2.0) @@ -220,6 +247,9 @@ of the string VERSION is replaced by the symbol 'version." ("TCL" 'license:tcl/tk) ("Unlicense" 'license:unlicense) ("Vim" 'license:vim) + ("W3C" 'license:w3c) + ("WTFPL" 'license:wtfpl2) + ("wxWindow" 'license:wxwindows3.1+) ;flagged as deprecated on spdx ("X11" 'license:x11) ("ZPL-2.1" 'license:zpl2.1) ("Zlib" 'license:zlib) diff --git a/guix/inferior.scm b/guix/inferior.scm index 6949bb3687..54200b75e4 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -141,7 +141,11 @@ regular file port (socket). This is equivalent to (open-pipe* OPEN_BOTH ...) except that the result is a regular file port that can be passed to 'select' ('open-pipe*' returns a custom binary port)." - (match (socketpair AF_UNIX SOCK_STREAM 0) + ;; Make sure the sockets are close-on-exec; failing to do that, a second + ;; inferior (for instance) would inherit the underlying file descriptor, and + ;; thus (close-port PARENT) in the original process would have no effect: + ;; the REPL process wouldn't get EOF on standard input. + (match (socketpair AF_UNIX (logior SOCK_STREAM SOCK_CLOEXEC) 0) ((parent . child) (match (primitive-fork) (0 diff --git a/guix/least-authority.scm b/guix/least-authority.scm new file mode 100644 index 0000000000..d871816fca --- /dev/null +++ b/guix/least-authority.scm @@ -0,0 +1,135 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix least-authority) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module ((guix store) #:select (%store-prefix)) + #:autoload (gnu build linux-container) (%namespaces) + #:autoload (gnu system file-systems) (file-system-mapping + file-system-mapping-source + spec->file-system + file-system->spec + file-system-mapping->bind-mount) + #:export (least-authority-wrapper)) + +;;; Commentary: +;;; +;;; This module provides tools to execute programs with the least authority +;;; necessary, using Linux namespaces. +;;; +;;; Code: + +(define %precious-variables + ;; Environment variables preserved by the wrapper by default. + '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER")) + +(define* (least-authority-wrapper program + #:key (name "pola-wrapper") + (guest-uid 1000) + (guest-gid 1000) + (mappings '()) + (namespaces %namespaces) + (directory "/") + (preserved-environment-variables + %precious-variables)) + "Return a wrapper of PROGRAM that executes it with the least authority. + +PROGRAM is executed in separate namespaces according to NAMESPACES, a list of +symbols; it turns with GUEST-UID and GUEST-GID. MAPPINGS is a list of +<file-system-mapping> records indicating directories mirrored inside the +execution environment of PROGRAM. DIRECTORY is the working directory of the +wrapped process. Each environment listed in PRESERVED-ENVIRONMENT-VARIABLES +is preserved; other environment variables are erased." + (define code + (with-imported-modules (source-module-closure + '((gnu system file-systems) + (gnu build shepherd) + (gnu build linux-container))) + #~(begin + (use-modules (gnu system file-systems) + (gnu build linux-container) + ((gnu build shepherd) #:select (default-mounts)) + (srfi srfi-1)) + + (define variables + (filter-map (lambda (variable) + (let ((value (getenv variable))) + (and value + (string-append variable "=" value)))) + '#$preserved-environment-variables)) + + (define (read-file file) + (call-with-input-file file read)) + + (define references + (delete-duplicates + (append-map read-file + '#$(map references-file + (cons program + (map file-system-mapping-source + mappings)))))) + + (define (store? file-system) + (string=? (file-system-mount-point file-system) + #$(%store-prefix))) + + (define mounts + (append (map (lambda (item) + (file-system-mapping->bind-mount + (file-system-mapping (source item) + (target item)))) + references) + (remove store? + (default-mounts + #:namespaces '#$namespaces)) + (map spec->file-system + '#$(map (compose file-system->spec + file-system-mapping->bind-mount) + mappings)))) + + (define (reify-exit-status status) + (cond ((status:exit-val status) => exit) + ((or (status:term-sig status) + (status:stop-sig status)) + => (lambda (signal) + (format (current-error-port) + "~a terminated with signal ~a~%" + #$program signal) + (exit (+ 128 signal)))))) + + ;; Note: 'call-with-container' creates a sub-process that this one + ;; waits for. This might seem suboptimal but unshare(2) isn't + ;; really applicable: the process would still run in the same PID + ;; namespace. + + (reify-exit-status + (call-with-container mounts + (lambda () + (chdir #$directory) + (environ variables) + (apply execl #$program #$program (cdr (command-line)))) + + ;; Don't assume PROGRAM can behave as an init process. + #:child-is-pid1? #f + + #:guest-uid #$guest-uid + #:guest-gid #$guest-gid + #:namespaces '#$namespaces))))) + + (program-file name code)) diff --git a/guix/licenses.scm b/guix/licenses.scm index 82ca44f42e..3b820ae07e 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -19,6 +19,7 @@ ;;; Copyright © 2021 Felix Gruber <felgru@posteo.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Noisytoot <noisytoot@disroot.org> +;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,7 +58,7 @@ epl1.0 epl2.0 eupl1.2 - expat + expat expat-0 freetype freebsd-doc giftware @@ -315,6 +316,13 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:Expat" "https://www.gnu.org/licenses/license-list.html#Expat")) +(define expat-0 + (license "Expat No Attribution" + ;; Note: There is a later formulation of the same license at + ;; <https://github.com/aws/mit-0>. + "https://romanrm.net/mit-zero" + "Expat license with the attribution paragraph removed.")) + (define freetype (license "Freetype" "http://directory.fsf.org/wiki/License:Freetype" diff --git a/guix/lint.scm b/guix/lint.scm index 767083a0ff..2b89f6a02a 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -494,16 +494,16 @@ of a package, and INPUT-NAMES, a list of package specifications such as "m4" "qttools" "yasm" "nasm" "fasm" - "python-coverage" "python2-coverage" - "python-cython" "python2-cython" - "python-docutils" "python2-docutils" - "python-mock" "python2-mock" - "python-nose" "python2-nose" - "python-pbr" "python2-pbr" - "python-pytest" "python2-pytest" - "python-pytest-cov" "python2-pytest-cov" - "python-setuptools-scm" "python2-setuptools-scm" - "python-sphinx" "python2-sphinx" + "python-coverage" + "python-cython" + "python-docutils" + "python-mock" + "python-nose" + "python-pbr" + "python-pytest" + "python-pytest-cov" + "python-setuptools-scm" + "python-sphinx" "scdoc" "swig" "qmake" @@ -523,9 +523,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as ;; Emit a warning if some inputs of PACKAGE are likely to should not be ;; an input at all. (let ((input-names '("python-setuptools" - "python2-setuptools" - "python-pip" - "python2-pip"))) + "python-pip"))) (map (lambda (input) (make-warning package @@ -1347,7 +1345,11 @@ descriptions maintained upstream." (formatted-message-arguments c)))) (make-warning package (G_ "failed to create ~a derivation: ~a") - (list system str))))) + (list system str)))) + (else + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system c)))) (parameterize ((%graft? #f)) (package-derivation store package system #:graft? #f) diff --git a/guix/packages.scm b/guix/packages.scm index 1c63eb2d3e..7425389618 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -531,7 +531,7 @@ Texinfo. Otherwise, return the string." (name package-name) ; string (version package-version) ; string (source package-source) ; <origin> instance - (build-system package-build-system) ; build system + (build-system package-build-system) ; <build-system> instance (arguments package-arguments ; arguments for the build method (default '()) (thunked)) @@ -662,7 +662,7 @@ interfaces." (assoc-ref (package-properties p) 'hidden?)) (define (package-superseded p) - "Return the package the supersedes P, or #f if P is still current." + "Return the package that supersedes P, or #f if P is still current." (assoc-ref (package-properties p) 'superseded)) (define (deprecated-package old-name p) @@ -1618,6 +1618,11 @@ and return it." (&package-error (package package)))))))))))) +(define %package-graft-cache + ;; Cache mapping <package> records to <graft> records, for packages that + ;; have a replacement. + (allocate-store-connection-cache 'package-graft-cache)) + (define (input-graft system) "Return a monadic procedure that, given a package with a graft, returns a graft, and #f otherwise." @@ -1626,9 +1631,8 @@ graft, and #f otherwise." (((? package? package) output) (let ((replacement (package-replacement package))) (if replacement - ;; XXX: We should use a separate cache instead of abusing the - ;; object cache. - (mcached (mlet %store-monad ((orig (package->derivation package system + (mcached eq? (=> %package-graft-cache) + (mlet %store-monad ((orig (package->derivation package system #:graft? #f)) (new (package->derivation replacement system #:graft? #t))) @@ -1637,7 +1641,7 @@ graft, and #f otherwise." (origin-output output) (replacement new) (replacement-output output)))) - package 'graft output system) + package output system) (return #f)))) (_ (return #f))))) diff --git a/guix/platform.scm b/guix/platform.scm new file mode 100644 index 0000000000..361241cb2e --- /dev/null +++ b/guix/platform.scm @@ -0,0 +1,139 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix platform) + #:use-module (guix discovery) + #:use-module (guix memoization) + #:use-module (guix records) + #:use-module (guix ui) + #:use-module (srfi srfi-1) + #:export (platform + platform? + platform-target + platform-system + platform-linux-architecture + platform-glibc-dynamic-linker + + platform-modules + platforms + lookup-platform-by-system + lookup-platform-by-target + lookup-platform-by-target-or-system + platform-system->target + platform-target->system + + systems + targets)) + + +;;; +;;; Platform record. +;;; + +;; Description of a platform supported by GNU Guix. +;; +;; The 'target' field must be a valid GNU triplet as defined here: +;; https://www.gnu.org/software/autoconf/manual/autoconf-2.68/html_node/Specifying-Target-Triplets.html. +;; It is used for cross-compilation purposes. +;; +;; The 'system' field is the name of the corresponding system as defined in +;; the (gnu packages bootstrap) module. It can be for instance +;; "aarch64-linux" or "armhf-linux". It is used to emulate a different host +;; architecture, for instance i686-linux on x86_64-linux-gnu, or armhf-linux +;; on x86_64-linux, using the QEMU binfmt transparent emulation mechanism. +;; +;; The 'linux-architecture' is only relevant if the kernel is Linux. In that +;; case, it corresponds to the ARCH variable used when building Linux. +;; +;; The 'glibc-dynamic-linker' field is the name of Glibc's dynamic linker for +;; the corresponding system. +(define-record-type* <platform> platform make-platform + platform? + (target platform-target) + (system platform-system) + (linux-architecture platform-linux-architecture + (default #f)) + (glibc-dynamic-linker platform-glibc-dynamic-linker)) + + +;;; +;;; Platforms. +;;; + +(define (platform-modules) + "Return the list of platform modules." + (all-modules (map (lambda (entry) + `(,entry . "guix/platforms")) + %load-path) + #:warn warn-about-load-error)) + +(define platforms + ;; The list of publically-known platforms. + (memoize + (lambda () + (fold-module-public-variables (lambda (obj result) + (if (platform? obj) + (cons obj result) + result)) + '() + (platform-modules))))) + +(define (lookup-platform-by-system system) + "Return the platform corresponding to the given SYSTEM." + (find (lambda (platform) + (let ((s (platform-system platform))) + (and (string? s) (string=? s system)))) + (platforms))) + +(define (lookup-platform-by-target target) + "Return the platform corresponding to the given TARGET." + (find (lambda (platform) + (let ((t (platform-target platform))) + (and (string? t) (string=? t target)))) + (platforms))) + +(define (lookup-platform-by-target-or-system target-or-system) + "Return the platform corresponding to the given TARGET or SYSTEM." + (or (lookup-platform-by-target target-or-system) + (lookup-platform-by-system target-or-system))) + +(define (platform-system->target system) + "Return the target matching the given SYSTEM if it exists or false +otherwise." + (let ((platform (lookup-platform-by-system system))) + (and=> platform platform-target))) + +(define (platform-target->system target) + "Return the system matching the given TARGET if it exists or false +otherwise." + (let ((platform (lookup-platform-by-target system))) + (and=> platform platform-system))) + + +;;; +;;; Systems & Targets. +;;; + +(define (systems) + "Return the list of supported systems." + (delete-duplicates + (filter-map platform-system (platforms)))) + +(define (targets) + "Return the list of supported targets." + (map platform-target (platforms))) diff --git a/guix/platforms/arm.scm b/guix/platforms/arm.scm new file mode 100644 index 0000000000..32c0fbc032 --- /dev/null +++ b/guix/platforms/arm.scm @@ -0,0 +1,37 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix platforms arm) + #:use-module (guix platform) + #:use-module (guix records) + #:export (armv7-linux + aarch64-linux)) + +(define armv7-linux + (platform + (target "arm-linux-gnueabihf") + (system "armhf-linux") + (linux-architecture "arm") + (glibc-dynamic-linker "/lib/ld-linux-armhf.so.3"))) + +(define aarch64-linux + (platform + (target "aarch64-linux-gnu") + (system "aarch64-linux") + (linux-architecture "arm64") + (glibc-dynamic-linker "/lib/ld-linux-aarch64.so.1"))) diff --git a/guix/platforms/mips.scm b/guix/platforms/mips.scm new file mode 100644 index 0000000000..e6fa9eb292 --- /dev/null +++ b/guix/platforms/mips.scm @@ -0,0 +1,29 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix platforms mips) + #:use-module (guix platform) + #:use-module (guix records) + #:export (mips64-linux)) + +(define mips64-linux + (platform + (target "mips64el-linux-gnu") + (system "mips64el-linux") + (linux-architecture "mips") + (glibc-dynamic-linker "/lib/ld.so.1"))) diff --git a/guix/platforms/powerpc.scm b/guix/platforms/powerpc.scm new file mode 100644 index 0000000000..9d0b343bc3 --- /dev/null +++ b/guix/platforms/powerpc.scm @@ -0,0 +1,37 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix platforms powerpc) + #:use-module (guix platform) + #:use-module (guix records) + #:export (powerpc-linux + powerpc64le-linux)) + +(define powerpc-linux + (platform + (target "powerpc-linux-gnu") + (system "powerpc-linux") + (linux-architecture "powerpc") + (glibc-dynamic-linker "/lib/ld.so.1"))) + +(define powerpc64le-linux + (platform + (target "powerpc64le-linux-gnu") + (system "powerpc64le-linux") + (linux-architecture "powerpc") + (glibc-dynamic-linker "/lib/ld64.so.2"))) diff --git a/guix/platforms/riscv.scm b/guix/platforms/riscv.scm new file mode 100644 index 0000000000..c716c12c12 --- /dev/null +++ b/guix/platforms/riscv.scm @@ -0,0 +1,29 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix platforms riscv) + #:use-module (guix platform) + #:use-module (guix records) + #:export (riscv64-linux)) + +(define riscv64-linux + (platform + (target "riscv64-linux-gnu") + (system "riscv64-linux") + (linux-architecture "riscv") + (glibc-dynamic-linker "/lib/ld-linux-riscv64-lp64d.so.1"))) diff --git a/guix/platforms/x86.scm b/guix/platforms/x86.scm new file mode 100644 index 0000000000..5338049d6f --- /dev/null +++ b/guix/platforms/x86.scm @@ -0,0 +1,58 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix platforms x86) + #:use-module (guix platform) + #:use-module (guix records) + #:export (i686-linux + x86_64-linux + i686-mingw + x86_64-mingw + hurd)) + +(define i686-linux + (platform + (target "i686-linux-gnu") + (system "i686-linux") + (linux-architecture "i386") + (glibc-dynamic-linker "/lib/ld-linux.so.2"))) + +(define x86_64-linux + (platform + (target "x86_64-linux-gnu") + (system "x86_64-linux") + (linux-architecture "x86_64") + (glibc-dynamic-linker "/lib/ld-linux-x86-64.so.2"))) + +(define i686-mingw + (platform + (target "i686-w64-mingw32") + (system #f) + (glibc-dynamic-linker #f))) + +(define x86_64-mingw + (platform + (target "x86_64-w64-mingw32") + (system #f) + (glibc-dynamic-linker #f))) + +(define hurd + (platform + (target "i586-pc-gnu") + (system "i586-gnu") + (glibc-dynamic-linker "/lib/ld.so.1"))) diff --git a/guix/profiles.scm b/guix/profiles.scm index 3a547de492..bf50c00a1e 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -462,7 +462,9 @@ denoting a specific output of a package." (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp search-paths)) - (properties . #$properties))) + #$@(if (null? properties) + #~() + #~((properties . #$properties))))) (($ <manifest-entry> name version output package (deps ...) (search-paths ...) _ (properties ...)) #~(#$name #$version #$output @@ -470,7 +472,9 @@ denoting a specific output of a package." (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp search-paths)) - (properties . #$properties))))) + #$@(if (null? properties) + #~() + #~((properties . #$properties))))))) (match manifest (($ <manifest> (entries ...)) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index f8678aa5f9..1e961c84e6 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -93,14 +93,14 @@ Export/import one or more packages from/to the store.\n")) (display (G_ " -S, --source build the packages' source derivations")) (display (G_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (G_ " - --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) + (newline) + (show-cross-build-options-help) + (newline) + (show-native-build-options-help) (newline) (display (G_ " @@ -166,14 +166,6 @@ Export/import one or more packages from/to the store.\n")) (option '(#\S "source") #f #f (lambda (opt name arg result) (alist-cons 'source? #t result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '("target") #t #f - (lambda (opt name arg result) - (alist-cons 'target arg - (alist-delete 'target result eq?)))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -186,7 +178,9 @@ Export/import one or more packages from/to the store.\n")) (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) - %standard-build-options)) + (append %standard-build-options + %standard-cross-build-options + %standard-native-build-options))) (define (derivation-from-expression store str package-derivation system source?) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index d9cdb6e5e0..75bbb701ae 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -21,6 +21,7 @@ (define-module (guix scripts build) #:use-module (guix ui) + #:use-module (guix colors) #:use-module (guix scripts) #:autoload (guix import json) (json->scheme-file) #:use-module (guix store) @@ -47,6 +48,7 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (gnu packages) + #:use-module (guix platform) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) @@ -54,9 +56,15 @@ #:export (log-url %standard-build-options + %standard-cross-build-options + %standard-native-build-options + set-build-options-from-command-line set-build-options-from-command-line* + show-build-options-help + show-cross-build-options-help + show-native-build-options-help guix-build register-root @@ -184,6 +192,18 @@ options handled by 'set-build-options-from-command-line', and listed in (display (G_ " --debug=LEVEL produce debugging output at LEVEL"))) +(define (show-cross-build-options-help) + (display (G_ " + --list-targets list available targets")) + (display (G_ " + --target=TRIPLET cross-build for TRIPLET--e.g., \"aarch64-linux-gnu\""))) + +(define (show-native-build-options-help) + (display (G_ " + --list-systems list available systems")) + (display (G_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))) + (define (set-build-options-from-command-line store opts) "Given OPTS, an alist as returned by 'args-fold' given '%standard-build-options', set the corresponding build options on STORE." @@ -319,6 +339,59 @@ use '--no-offload' instead~%"))) (leave (G_ "not a number: '~a' option argument: ~a~%") name arg))))))) +(define (list-systems) + "Print the available systems." + (display (G_ "The available systems are:\n")) + (newline) + (let ((systems* + (map (lambda (system) + (if (string=? system (%current-system)) + (highlight + (string-append system " [current]")) + system)) + (systems)))) + (format #t "~{ - ~a ~%~}" + (sort systems* string<?)))) + +(define (list-targets) + "Print the available targets." + (display (G_ "The available targets are:\n")) + (newline) + (format #t "~{ - ~a ~%~}" + (sort (targets) string<?))) + +(define %standard-cross-build-options + ;; Build options related to cross builds. + (list + (option '("list-targets") #f #f + (lambda (opt name arg result) + (list-targets) + (exit 0))) + (option '("target") #t #f + (lambda (opt name arg result . rest) + (let ((t (false-if-exception + (first (member arg (targets)))))) + (if t + (apply values (alist-cons 'target t result) rest) + (leave (G_ "'~a' is not a supported target~%") + arg))))))) + +(define %standard-native-build-options + ;; Build options related to native builds. + (list + (option '("list-systems") #f #f + (lambda (opt name arg result) + (list-systems) + (exit 0))) + (option '(#\s "system") #t #f + (lambda (opt name arg result . rest) + (let ((s (false-if-exception + (first (member arg (systems)))))) + (if s + (apply values (alist-cons 'system s result) rest) + (leave (G_ "'~a' is not a supported system~%") + arg))))))) + ;;; ;;; Command-line options. @@ -353,10 +426,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) --sources[=TYPE] build source derivations; TYPE may optionally be one of \"package\", \"all\" (default), or \"transitive\"")) (display (G_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (G_ " - --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (G_ " -d, --derivations return the derivation paths of the given packages")) (display (G_ " --check rebuild items to check for non-determinism issues")) @@ -374,6 +443,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (newline) (show-build-options-help) (newline) + (show-cross-build-options-help) + (newline) + (show-native-build-options-help) + (newline) (show-transformation-options-help) (newline) (display (G_ " @@ -420,13 +493,6 @@ must be one of 'package', 'all', or 'transitive'~%") (alist-cons 'build-mode (build-mode repair) result) rest))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg result))) - (option '("target") #t #f - (lambda (opt name arg result) - (alist-cons 'target arg - (alist-delete 'target result eq?)))) (option '(#\d "derivations") #f #f (lambda (opt name arg result) (alist-cons 'derivations-only? #t result))) @@ -459,7 +525,9 @@ must be one of 'package', 'all', or 'transitive'~%") (alist-cons 'log-file? #t result))) (append %transformation-options - %standard-build-options))) + %standard-build-options + %standard-cross-build-options + %standard-native-build-options))) (define (options->things-to-build opts) "Read the arguments from OPTS and return a list of high-level objects to diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index a3e3338f7e..7e4f682053 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -27,6 +27,7 @@ #:use-module (guix scripts) #:use-module (guix describe) #:use-module (guix profiles) + #:autoload (guix colors) (supports-hyperlinks? hyperlink) #:autoload (guix openpgp) (openpgp-format-fingerprint) #:use-module (git) #:autoload (json builder) (scm->json-string) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index a2e1ffb434..8e777d1405 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, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2016, 2019-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) #:export (%editor + spawn-editor guix-edit)) (define %options @@ -77,6 +78,21 @@ line." (location-line location))) (search-path* %load-path (location-file location)))) +(define (spawn-editor locations) + "Spawn (%editor) to edit the code at LOCATIONS, a list of <location> +records, and exit." + (catch 'system-error + (lambda () + (let ((file-names (append-map location->location-specification + locations))) + ;; Use `system' instead of `exec' in order to sanely handle + ;; possible command line arguments in %EDITOR. + (exit (system (string-join (cons (%editor) file-names)))))) + (lambda args + (let ((errno (system-error-errno args))) + (leave (G_ "failed to launch '~a': ~a~%") + (%editor) (strerror errno)))))) + (define-command (guix-edit . args) (category packaging) @@ -94,14 +110,4 @@ line." (when (null? specs) (leave (G_ "no packages specified, nothing to edit~%"))) - (catch 'system-error - (lambda () - (let ((file-names (append-map location->location-specification - locations))) - ;; Use `system' instead of `exec' in order to sanely handle - ;; possible command line arguments in %EDITOR. - (exit (system (string-join (cons (%editor) file-names)))))) - (lambda args - (let ((errno (system-error-errno args))) - (leave (G_ "failed to launch '~a': ~a~%") - (%editor) (strerror errno)))))))) + (spawn-editor locations)))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index ec071402f4..3216235937 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -56,6 +56,7 @@ #:use-module (srfi srfi-37) #:use-module (srfi srfi-98) #:export (assert-container-features + load-manifest guix-environment guix-environment* show-environment-options-help @@ -95,8 +96,6 @@ shell'." (display (G_ " --search-paths display needed environment variable definitions")) (display (G_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (G_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (G_ " @@ -144,6 +143,8 @@ COMMAND or an interactive shell in that environment.\n")) (newline) (show-build-options-help) (newline) + (show-native-build-options-help) + (newline) (show-transformation-options-help) (newline) (display (G_ " @@ -225,10 +226,6 @@ use '--preserve' instead~%")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) (option '(#\C "container") #f #f (lambda (opt name arg result) (alist-cons 'container? #t result))) @@ -272,7 +269,8 @@ use '--preserve' instead~%")) (alist-cons 'bootstrap? #t result))) (append %transformation-options - %standard-build-options))) + %standard-build-options + %standard-native-build-options))) (define (pick-all alist key) "Return a list of values in ALIST associated with KEY." @@ -285,6 +283,11 @@ use '--preserve' instead~%")) (_ memo))) '() alist)) +(define (load-manifest file) ;TODO: factorize + "Load the user-profile manifest (Scheme code) from FILE and return it." + (let ((user-module (make-user-module '((guix profiles) (gnu))))) + (load* file user-module))) + (define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by manifest entries for the corresponding packages." @@ -331,8 +334,7 @@ for the corresponding packages." (let ((module (make-user-module '()))) (packages->outputs (load* file module) mode))) (('manifest . file) - (let ((module (make-user-module '((guix profiles) (gnu))))) - (manifest-entries (load* file module)))) + (manifest-entries (load-manifest file))) (_ '())) opts) manifest-entry=?))) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 535875c858..2f102180c9 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -39,7 +39,9 @@ options->transformation %transformation-options)) #:use-module ((guix scripts build) - #:select (%standard-build-options)) + #:select (%standard-build-options + %standard-native-build-options + show-native-build-options-help)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -504,10 +506,6 @@ package modules, while attempting to retain user package modules." (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) (find (lambda (option) (member "load-path" (option-names option))) %standard-build-options) @@ -519,7 +517,8 @@ package modules, while attempting to retain user package modules." (lambda args (show-version-and-exit "guix graph"))) - %transformation-options)) + (append %transformation-options + %standard-native-build-options))) (define (show-help) ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be @@ -540,8 +539,6 @@ Emit a representation of the dependency graph of PACKAGE...\n")) --path display the shortest path between the given nodes")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) - (display (G_ " - -s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\"")) (newline) (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) @@ -553,6 +550,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " -V, --version display version information and exit")) (newline) + (show-native-build-options-help) + (newline) (show-bug-report-information)) (define %default-options diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index af2643014d..0f5c3388a1 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -45,6 +45,7 @@ #:use-module (guix channels) #:use-module (guix derivations) #:use-module (guix ui) + #:autoload (guix colors) (supports-hyperlinks? file-hyperlink) #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix profiles) @@ -59,6 +60,7 @@ #:autoload (guix scripts pull) (channel-commit-hyperlink) #:autoload (guix scripts system) (service-node-type shepherd-service-node-type) + #:autoload (guix scripts home edit) (guix-home-edit) #:autoload (guix scripts home import) (import-manifest) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix build utils) #:select (mkdir-p)) @@ -92,6 +94,8 @@ Some ACTIONS support additional ARGS.\n")) (newline) (display (G_ "\ search search for existing service types\n")) + (display (G_ "\ + edit edit the definition of an existing service type\n")) (display (G_ " container run the home environment configuration in a container\n")) (display (G_ "\ @@ -538,6 +542,8 @@ argument list and OPTS is the option alist." ;; an home environment file. ((search) (apply search args)) + ((edit) + (apply guix-home-edit args)) ((import) (let* ((profiles (delete-duplicates (match (filter-map (match-lambda @@ -610,7 +616,7 @@ deploy the home environment described by these files.\n") extension-graph shepherd-graph list-generations describe delete-generations roll-back - switch-generation search + switch-generation search edit import container) (alist-cons 'action action result)) (else (leave (G_ "~a: unknown action~%") action)))))) @@ -732,6 +738,7 @@ description matches REGEXPS sorted by relevance, and their score." (leave-on-EPIPE (display-search-results matches (current-output-port) #:print service-type->recutils + #:regexps regexps #:command "guix home search"))))) diff --git a/guix/scripts/home/edit.scm b/guix/scripts/home/edit.scm new file mode 100644 index 0000000000..a6c05675b3 --- /dev/null +++ b/guix/scripts/home/edit.scm @@ -0,0 +1,66 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts home edit) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module (guix ui) + #:autoload (guix utils) (string-closest) + #:use-module (gnu services) + #:use-module (gnu home services) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:autoload (guix scripts edit) (spawn-editor) + #:export (guix-home-edit)) + +(define (service-type-not-found type) + "Report an error about @var{type} not being found and exit." + (report-error (G_ "~a: no such service type~%") type) + + (let* ((type (symbol->string type)) + (available (fold-home-service-types (lambda (type lst) + (cons (symbol->string + (service-type-name type)) + lst)) + '())) + (closest (string-closest type available))) + (unless (or (not closest) (string=? closest type)) + (display-hint (format #f (G_ "Did you mean @code{~a}?~%") + closest)))) + + (exit 1)) + + +(define (guix-home-edit . args) + (when (null? args) + (leave (G_ "no service types specified, nothing to edit~%"))) + + (with-error-handling + (let* ((types (append-map (lambda (type) + (let ((type (string->symbol type))) + (match (lookup-home-service-types type) + (() (service-type-not-found type)) + ((one) (list one)) + (lst + (warning (N_ "~a: ~a matching service type~%" + "~a: ~a matching service types~%" + (length lst)) + type (length lst)) + lst)))) + args))) + (spawn-editor (filter-map service-type-location types))))) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 575fe8f688..825ccb1e73 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Arjan Adriaanse <arjan@adriaan.se> +;;; Copyright © 2022 Antero Mejr <antero@mailbox.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -170,8 +171,7 @@ user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them." ,@(delete-duplicates (concatenate modules))) (home-environment - (packages (map (compose list specification->package+output) - ,packages)) + (packages (specifications->packages ,packages)) (services (list ,@services))))))))) (define* (import-manifest diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 40fa6759ae..62aa7bdbc5 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -2,9 +2,10 @@ ;;; Copyright © 2012, 2013, 2014, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> -;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,7 @@ (define-module (guix scripts import) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module (guix scripts style) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -31,43 +33,11 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) #:export (%standard-import-options guix-import)) ;;; -;;; Helper. -;;; - -(define (newline-rewriting-port output) - "Return an output port that rewrites strings containing the \\n escape -to an actual newline. This works around the behavior of `pretty-print' -and `write', which output these as \\n instead of actual newlines, -whereas we want the `description' field to contain actual newlines -rather than \\n." - (define (write-string str) - (let loop ((chars (string->list str))) - (match chars - (() - #t) - ((#\\ #\n rest ...) - (newline output) - (loop rest)) - ((chr rest ...) - (write-char chr output) - (loop rest))))) - - (make-soft-port (vector (cut write-char <>) - write-string - (lambda _ #t) ; flush - #f - (lambda _ #t) ; close - #f) - "w")) - - -;;; ;;; Command line options. ;;; @@ -80,7 +50,7 @@ rather than \\n." (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" "gem" "go" "cran" "crate" "texlive" "json" "opam" - "minetest")) + "minetest" "elm")) (define (resolve-importer name) (let ((module (resolve-interface @@ -118,9 +88,7 @@ Run IMPORTER with ARGS.\n")) ((importer args ...) (if (member importer importers) (let ((print (lambda (expr) - (pretty-print expr (newline-rewriting-port - (current-output-port)) - #:max-expr-width 80)))) + (pretty-print-with-comments (current-output-port) expr)))) (match (apply (resolve-importer importer) args) ((and expr (or ('package _ ...) ('let _ ...) diff --git a/guix/scripts/import/elm.scm b/guix/scripts/import/elm.scm new file mode 100644 index 0000000000..68dcbf1070 --- /dev/null +++ b/guix/scripts/import/elm.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts import elm) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import elm) + #:use-module (guix scripts import) + #: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-elm)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import elm PACKAGE-NAME + +Import and convert the Elm package PACKAGE-NAME. Optionally, a version +can be specified after the arobas (@) character.\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 elm"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-elm . args) + (define (parse-options) + ;; Return the alist of option values. + (parse-command-line args %options (list %default-options) + #:build-options? #f)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((spec) + (with-error-handling + (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)) + (elm-recursive-import name version)) + ;; Single import + (let ((sexp (elm->guix-package name #:version version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + name)) + sexp))))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 38bc021665..d3ee69840c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,9 +5,9 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,7 +63,7 @@ #:use-module (ice-9 match) #:export (compressor? compressor-name - compressor-extenstion + compressor-extension compressor-command %compressors lookup-compressor @@ -750,7 +750,7 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (match (manifest-entries manifest) ((entry) entry) - (() #f))) + (_ #f))) (define package-name (or (and=> single-entry manifest-entry-name) (manifest->friendly-name manifest))) @@ -1244,17 +1244,9 @@ last resort for relocation." (option '(#\m "manifest") #t #f (lambda (opt name arg result) (alist-cons 'manifest arg result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) (option '("entry-point") #t #f (lambda (opt name arg result) (alist-cons 'entry-point arg result))) - (option '("target") #t #f - (lambda (opt name arg result) - (alist-cons 'target arg - (alist-delete 'target result eq?)))) (option '(#\C "compression") #t #f (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) @@ -1305,13 +1297,19 @@ last resort for relocation." (append %deb-format-options %transformation-options - %standard-build-options))) + %standard-build-options + %standard-cross-build-options + %standard-native-build-options))) (define (show-help) (display (G_ "Usage: guix pack [OPTION]... PACKAGE... Create a bundle of PACKAGE.\n")) (show-build-options-help) (newline) + (show-cross-build-options-help) + (newline) + (show-native-build-options-help) + (newline) (show-transformation-options-help) (newline) (show-deb-format-options) @@ -1325,10 +1323,6 @@ Create a bundle of PACKAGE.\n")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) (display (G_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (G_ " - --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (G_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) (display (G_ " -S, --symlink=SPEC create symlinks to the profile according to SPEC")) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 9699c70c6d..99a6cfaa29 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com> +;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -203,8 +204,12 @@ non-zero relevance score." (match m2 ((package2 . score2) (if (= score1 score2) - (string>? (package-full-name package1) - (package-full-name package2)) + (if (string=? (package-name package1) + (package-name package2)) + (version>? (package-version package1) + (package-version package2)) + (string>? (package-name package1) + (package-name package2))) (> score1 score2)))))))))) (define (transaction-upgrade-entry store entry transaction) @@ -334,24 +339,8 @@ Alternately, see @command{guix package --search-paths -p ~s}.") "Search among all the versions of ENTRY's package that are available, and return the shortest unambiguous version prefix for this package. If only one version of ENTRY's package is available, return the empty string." - (let ((name (manifest-entry-name entry))) - (match (map package-version (find-packages-by-name name)) - ((_) - ;; A single version of NAME is available, so do not specify the - ;; version number, even if the available version doesn't match ENTRY. - "") - (versions - ;; If ENTRY uses the latest version, don't specify any version. - ;; Otherwise return the shortest unique version prefix. Note that - ;; this is based on the currently available packages, which could - ;; differ from the packages available in the revision that was used - ;; to build MANIFEST. - (let ((current (manifest-entry-version entry))) - (if (every (cut version>? current <>) - (delete current versions)) - "" - (version-unique-prefix (manifest-entry-version entry) - versions))))))) + (package-unique-version-prefix (manifest-entry-name entry) + (manifest-entry-version entry))) (define* (export-manifest manifest #:optional (port (current-output-port))) @@ -710,10 +699,10 @@ the resulting manifest entry." (manifest-entry-with-provenance (package->manifest-entry package output))) -(define (options->installable opts manifest transaction) - "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', -return an variant of TRANSACTION that accounts for the specified installations -and upgrades." +(define (options->installable opts manifest transform transaction) + "Given MANIFEST, the current manifest, OPTS, and TRANSFORM, the result of +'args-fold', return an variant of TRANSACTION that accounts for the specified +installations, upgrades and transformations." (define upgrade? (options->upgrade-predicate opts)) @@ -730,13 +719,14 @@ and upgrades." (('install . (? package? p)) ;; When given a package via `-e', install the first of its ;; outputs (XXX). - (package->manifest-entry* p "out")) + (package->manifest-entry* (transform p) "out")) (('install . (? string? spec)) (if (store-path? spec) (store-item->manifest-entry spec) (let-values (((package output) (specification->package+output spec))) - (package->manifest-entry* package output)))) + (package->manifest-entry* (transform package) + output)))) (('install . obj) (leave (G_ "cannot install non-package object: ~s~%") obj)) @@ -901,7 +891,8 @@ processed, #f otherwise." (regexps (map (cut make-regexp* <> regexp/icase) patterns)) (matches (find-packages-by-description regexps))) (leave-on-EPIPE - (display-search-results matches (current-output-port))) + (display-search-results matches (current-output-port) + #:regexps regexps)) #t)) (('show _) @@ -994,16 +985,6 @@ processed, #f otherwise." (define profile (or (assoc-ref opts 'profile) %current-profile)) (define transform (options->transformation opts)) - (define (transform-entry entry) - (let ((item (transform (manifest-entry-item entry)))) - (manifest-entry-with-transformations - (manifest-entry - (inherit entry) - (item item) - (version (if (package? item) - (package-version item) - (manifest-entry-version entry))))))) - (when (equal? profile %current-profile) ;; Normally the daemon created %CURRENT-PROFILE when we connected, unless ;; it's a version that lacks the fix for <https://bugs.gnu.org/37744> @@ -1036,16 +1017,12 @@ processed, #f otherwise." (map load-manifest files)))))) (step1 (options->removable opts manifest (manifest-transaction))) - (step2 (options->installable opts manifest step1)) - (step3 (manifest-transaction - (inherit step2) - (install (map transform-entry - (manifest-transaction-install step2))))) - (new (manifest-perform-transaction manifest step3)) + (step2 (options->installable opts manifest transform step1)) + (new (manifest-perform-transaction manifest step2)) (trans (if (null? files) - step3 + step2 (fold manifest-transaction-install-entry - step3 + step2 (manifest-entries manifest))))) (warn-about-old-distro) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 870dfc11e9..3bf3bd9c7c 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -25,7 +25,6 @@ #:use-module ((system repl server) #:prefix repl:) #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) - #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (ice-9 poll) #:use-module (ice-9 regex) @@ -36,11 +35,11 @@ #: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) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (web http) #:use-module (web request) #:use-module (web response) @@ -406,18 +405,15 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." (let ((store-path (hash-part->path store hash))) (if (string-null? store-path) (not-found request #:phrase "" #:ttl negative-ttl) - (values `((content-type . (application/x-nix-narinfo - (charset . "UTF-8"))) - (x-nar-path . ,nar-path) - (x-narinfo-compressions . ,compressions) + (values `((content-type . (application/x-nix-narinfo)) ,@(if ttl `((cache-control (max-age . ,ttl))) '())) - ;; Do not call narinfo-string directly here as it is an - ;; expensive call that could potentially block the main - ;; thread. Instead, create the narinfo string in the - ;; http-write procedure. - store-path)))) + (cut display + (narinfo-string store store-path + #:nar-path nar-path + #:compressions compressions) + <>))))) (define* (nar-cache-file directory item #:key (compression %no-compression)) @@ -672,38 +668,19 @@ requested using POOL." (link narinfo other))) others)))))) -(define (compression->sexp compression) - "Return the SEXP representation of COMPRESSION." - (match compression - (($ <compression> type level) - `(compression ,type ,level)))) - -(define (sexp->compression sexp) - "Turn the given SEXP into a <compression> record and return it." - (match sexp - (('compression type level) - (compression type level)))) - ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. (declare-header! "X-Nar-Compression" (lambda (str) - (sexp->compression - (call-with-input-string str read))) + (match (call-with-input-string str read) + (('compression type level) + (compression type level)))) compression? (lambda (compression port) - (write (compression->sexp compression) port))) - -;; This header is used to pass the supported compressions to http-write in -;; order to format on-the-fly narinfo responses. -(declare-header! "X-Narinfo-Compressions" - (lambda (str) - (map sexp->compression - (call-with-input-string str read))) - (cut every compression? <>) - (lambda (compressions port) - (write (map compression->sexp compressions) port))) + (match compression + (($ <compression> type level) + (write `(compression ,type ,level) port))))) (define* (render-nar store request store-item #:key (compression %no-compression)) @@ -858,8 +835,7 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." "Return RESPONSE's headers minus 'Content-Length' and our internal headers." (fold alist-delete (response-headers response) - '(content-length x-raw-file x-nar-compression - x-narinfo-compressions x-nar-path))) + '(content-length x-raw-file x-nar-compression))) (define (sans-content-length response) "Return RESPONSE without its 'content-length' header." @@ -993,38 +969,6 @@ blocking." (unless keep-alive? (close-port client))) (values)))))) - (('application/x-nix-narinfo . _) - (let ((compressions (assoc-ref (response-headers response) - 'x-narinfo-compressions)) - (nar-path (assoc-ref (response-headers response) - 'x-nar-path))) - (if nar-path - (begin - (when (keep-alive? response) - (keep-alive client)) - (call-with-new-thread - (lambda () - (set-thread-name "publish narinfo") - (let* ((narinfo - (with-store store - (narinfo-string store (utf8->string body) - #:nar-path nar-path - #:compressions compressions))) - (narinfo-bv (string->bytevector narinfo "UTF-8")) - (narinfo-length - (bytevector-length narinfo-bv)) - (response (write-response - (with-content-length response - narinfo-length) - client)) - (output (response-port response))) - (configure-socket client) - (put-bytevector output narinfo-bv) - (force-output output) - (unless (keep-alive? response) - (close-port output)) - (values))))) - (%http-write server client response body)))) (_ (match (assoc-ref (response-headers response) 'x-raw-file) ((? string? file) @@ -1190,8 +1134,7 @@ headers." ;; 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))) + (let ((response response-body (handle request body))) (values (preserve-connection-headers request response) response-body)))) @@ -1236,6 +1179,23 @@ headers." (bind sock address) sock)) +(define (systemd-socket) + "If this program is being spawned through systemd-style \"socket +activation\", whereby the listening socket is passed as file descriptor 3, +return the corresponding socket. Otherwise return #f." + (and (equal? (and=> (getenv "LISTEN_PID") string->number) + (getpid)) + (match (getenv "LISTEN_FDS") + ((= string->number 1) + (let ((sock (fdopen 3 "r+0"))) + (configure-socket sock) + sock)) + ((= string->number (? integer? n)) + (leave (G_ "~a: unexpected number of startup file descriptors") + n)) + (_ + #f)))) + (define (gather-user-privileges user) "Switch to the identity of USER, a user name." (catch 'misc-error @@ -1281,7 +1241,12 @@ headers." (make-socket-address (sockaddr:fam addr) (sockaddr:addr addr) port))) - (socket (open-server-socket address)) + (socket style (match (systemd-socket) + (#f + (values (open-server-socket address) + 'normal)) + (socket + (values socket 'systemd)))) (nar-path (assoc-ref opts 'nar-path)) (repl-port (assoc-ref opts 'repl)) (cache (assoc-ref opts 'cache)) @@ -1306,10 +1271,12 @@ consider using the '--user' option!~%"))) (cache-bypass-threshold (or (assoc-ref opts 'cache-bypass-threshold) (cache-bypass-threshold)))) - (info (G_ "publishing ~a on ~a, port ~d~%") - %store-directory - (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) - (sockaddr:port address)) + (if (eq? style 'systemd) + (info (G_ "publishing (started via socket activation)~%")) + (info (G_ "publishing ~a on ~a, port ~d~%") + %store-directory + (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) + (sockaddr:port address))) (for-each (lambda (compression) (info (G_ "using '~a' compression method, level ~a~%") diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 7402782ff3..f01764637b 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -40,8 +40,6 @@ #:use-module (guix scripts build) #:use-module (guix scripts describe) #:autoload (guix build utils) (which mkdir-p) - #:use-module ((guix build syscalls) - #:select (with-file-lock/no-wait)) #:use-module (guix git) #:use-module (git) #:autoload (gnu packages) (fold-available-packages) @@ -119,11 +117,12 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) (show-build-options-help) + (newline) + (show-native-build-options-help) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -184,10 +183,6 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) @@ -208,7 +203,8 @@ Download and deploy the latest version of Guix.\n")) (lambda args (show-version-and-exit "guix pull"))) - %standard-build-options)) + (append %standard-build-options + %standard-native-build-options))) (define (warn-about-backward-updates channel start commit relation) "Warn about non-forward updates of CHANNEL from START to COMMIT, without diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 1eab05d737..1a6df98829 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -21,7 +21,8 @@ #:use-module ((guix diagnostics) #:select (location)) #:use-module (guix scripts environment) #:autoload (guix scripts build) (show-build-options-help) - #:autoload (guix transformations) (transformation-option-key? + #:autoload (guix transformations) (options->transformation + transformation-option-key? show-transformation-options-help) #:use-module (guix scripts) #:use-module (guix packages) @@ -41,7 +42,12 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix cache) #:use-module ((ice-9 ftw) #:select (scandir)) - #:autoload (gnu packages) (cache-is-authoritative?) + #:autoload (ice-9 pretty-print) (pretty-print) + #:autoload (gnu packages) (cache-is-authoritative? + package-unique-version-prefix + specification->package + specification->package+output + specifications->manifest) #:export (guix-shell)) (define (show-help) @@ -55,10 +61,13 @@ interactive shell in that environment.\n")) -D, --development include the development inputs of the next package")) (display (G_ " -f, --file=FILE add to the environment the package FILE evaluates to")) + (display (G_ " -q inhibit loading of 'guix.scm' and 'manifest.scm'")) (display (G_ " --rebuild-cache rebuild cached environment, if any")) + (display (G_ " + --export-manifest print a manifest for the given options")) (show-environment-options-help) (newline) @@ -112,6 +121,10 @@ interactive shell in that environment.\n")) ;; 'wrapped-option'. (alist-delete 'ad-hoc? result))) + (option '("export-manifest") #f #f + (lambda (opt name arg result) + (alist-cons 'export-manifest? #t result))) + ;; For consistency with 'guix package', support '-f' rather than ;; '-l' like 'guix environment' does. (option '(#\f "file") #t #f @@ -382,6 +395,94 @@ return #f and #f." ;;; +;;; Exporting a manifest. +;;; + +(define (manifest-entry-version-prefix entry) + "Search among all the versions of ENTRY's package that are available, and +return the shortest unambiguous version prefix for this package." + (package-unique-version-prefix (manifest-entry-name entry) + (manifest-entry-version entry))) + +(define (manifest->code* manifest extra-manifests) + "Like 'manifest->code', but insert a 'concatenate-manifests' call that +concatenates MANIFESTS, a list of expressions." + (if (null? (manifest-entries manifest)) + (match extra-manifests + ((one) one) + (lst `(concatenate-manifests (list ,@extra-manifests)))) + (match (manifest->code manifest + #:entry-package-version + manifest-entry-version-prefix) + (('begin exp ... last) + `(begin + ,@exp + ,(match extra-manifests + (() last) + (_ `(concatenate-manifests + (list ,last ,@extra-manifests))))))))) + +(define (export-manifest opts port) + "Write to PORT a manifest corresponding to OPTS." + (define (manifest-lift proc) + (lambda (entry) + (match (manifest-entry-item entry) + ((? package? p) + (manifest-entry + (inherit (package->manifest-entry (proc p))) + (output (manifest-entry-output entry)))) + (_ + entry)))) + + (define (validated-spec spec) + ;; Return SPEC if it's a valid package spec. + (specification->package+output spec) + spec) + + (let* ((transform (options->transformation opts)) + (specs (reverse + (filter-map (match-lambda + (('package 'ad-hoc-package spec) + (validated-spec spec)) + (_ #f)) + opts))) + (extras (reverse + (filter-map (match-lambda + (('package 'package spec) + ;; Make sure SPEC is valid. + (specification->package spec) + + ;; XXX: This is an approximation: + ;; transformation options are not applied. + `(package->development-manifest + (specification->package ,spec))) + (_ #f)) + opts))) + (manifest (concatenate-manifests + (cons (map-manifest-entries + (manifest-lift transform) + (specifications->manifest specs)) + (filter-map (match-lambda + (('manifest . file) + (load-manifest file)) + (_ #f)) + opts))))) + (display (G_ "\ +;; What follows is a \"manifest\" equivalent to the command line you gave. +;; You can store it in a file that you may then pass to any 'guix' command +;; that accepts a '--manifest' (or '-m') option.\n") + port) + (match (manifest->code* manifest extras) + (('begin exp ...) + (for-each (lambda (exp) + (newline port) + (pretty-print exp port)) + exp)) + (exp + (pretty-print exp port))))) + + +;;; ;;; One-time hints. ;;; @@ -445,4 +546,6 @@ to make sure your shell does not clobber environment variables."))) ) cache-entries #:entry-expiration entry-expiration))) - (guix-environment* opts)) + (if (assoc-ref opts 'export-manifest?) + (export-manifest opts (current-output-port)) + (guix-environment* opts))) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index e46983382a..5bb970443c 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -235,8 +235,6 @@ Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n")) (display (G_ " --substitute-urls=URLS fetch substitute from URLS if they are authorized")) - (display (G_ " - -s, --system=SYSTEM consider packages for SYSTEM--e.g., \"i686-linux\"")) ;; TRANSLATORS: "closure" and "self" must not be translated. (display (G_ " --sort=KEY sort according to KEY--\"closure\" or \"self\"")) @@ -251,15 +249,13 @@ Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n")) (display (G_ " -V, --version display version information and exit")) (newline) + (show-native-build-options-help) + (newline) (show-bug-report-information)) (define %options ;; Specifications of the command-line options. - (list (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '("substitute-urls") #t #f + (cons* (option '("substitute-urls") #t #f (lambda (opt name arg result . rest) (apply values (alist-cons 'substitute-urls @@ -287,7 +283,8 @@ Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix size"))))) + (show-version-and-exit "guix size"))) + %standard-native-build-options)) (define %default-options `((system . ,(%current-system)) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index fb31c694f2..8123570c38 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -66,8 +66,23 @@ (define (read-with-comments port) "Like 'read', but include <comment> objects when they're encountered." ;; Note: Instead of implementing this functionality in 'read' proper, which - ;; is the best approach long-term, this code is a later on top of 'read', + ;; is the best approach long-term, this code is a layer on top of 'read', ;; such that we don't have to rely on a specific Guile version. + (define dot (list 'dot)) + (define (dot? x) (eq? x dot)) + + (define (reverse/dot lst) + ;; Reverse LST and make it an improper list if it contains DOT. + (let loop ((result '()) + (lst lst)) + (match lst + (() result) + (((? dot?) . rest) + (let ((dotted (reverse rest))) + (set-cdr! (last-pair dotted) (car result)) + dotted)) + ((x . rest) (loop (cons x result) rest))))) + (let loop ((blank-line? #t) (return (const 'unbalanced))) (match (read-char port) @@ -85,7 +100,7 @@ (((? comment?) . _) #t) (_ #f)) (lambda () - (return (reverse lst)))) + (return (reverse/dot lst)))) lst))))) ((memv chr '(#\) #\])) (return)) @@ -107,8 +122,10 @@ (not blank-line?))) (else (unread-char chr port) - (read port))))))) - + (match (read port) + ((and token '#{.}#) + (if (eq? chr #\.) dot token)) + (token token)))))))) ;;; ;;; Comment-preserving pretty-printer. diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 908a8334a8..c5f5d23b47 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -704,6 +704,14 @@ default value." (category internal) (synopsis "implement the build daemon's substituter protocol") + (match args + ((or ("-V") ("--version")) + (show-version-and-exit "guix substitute")) + ((or ("-h") ("--help") ()) + (show-help) + (exit 0)) + (_ #t)) + (define print-build-trace? (match (or (find-daemon-option "untrusted-print-extended-build-trace") (find-daemon-option "print-extended-build-trace")) @@ -775,10 +783,6 @@ default value." #:print-build-trace? print-build-trace?) (loop)))))) - ((or ("-V") ("--version")) - (show-version-and-exit "guix substitute")) - ((or ("-h") ("--help")) - (show-help)) (opts (leave (G_ "~a: unrecognized options~%") opts)))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 067bf999f1..63e3b9b934 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ (define-module (guix scripts system) #:use-module (guix config) #:use-module (guix ui) + #:autoload (guix colors) (supports-hyperlinks? file-hyperlink) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix store) #:autoload (guix base16) (bytevector->base16-string) @@ -65,7 +67,7 @@ (device-module-aliases matching-modules) #:use-module (gnu system linux-initrd) #:use-module (gnu image) - #:use-module (gnu platform) + #:use-module (guix platform) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -944,6 +946,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ "\ search search for existing service types\n")) (display (G_ "\ + edit edit the definition of an existing service type\n")) + (display (G_ "\ reconfigure switch to a new operating system configuration\n")) (display (G_ "\ roll-back switch to the previous operating system configuration\n")) @@ -1171,7 +1175,8 @@ Some ACTIONS support additional ARGS.\n")) "extension-graph" "shepherd-graph" "list-generations" "describe" "delete-generations" "roll-back" - "switch-generation" "search" "docker-image")) + "switch-generation" "search" "edit" + "docker-image")) (define (process-action action args opts) "Process ACTION, a sub-command, with the arguments are listed in ARGS. @@ -1269,7 +1274,7 @@ resulting from command-line parsing." (export-shepherd-graph os (current-output-port) #:backend (graph-backend))) (else - (unless (memq action '(build init)) + (unless (memq action '(build init reconfigure)) (warn-about-old-distro #:suggested-command "guix system reconfigure")) @@ -1339,6 +1344,8 @@ argument list and OPTS is the option alist." (display-system-generation generation)))) ((search) (apply (resolve-subcommand "search") args)) + ((edit) + (apply (resolve-subcommand "edit") args)) ;; The following commands need to use the store, but they do not need an ;; operating system configuration file. ((delete-generations) diff --git a/guix/scripts/system/edit.scm b/guix/scripts/system/edit.scm new file mode 100644 index 0000000000..d966ee0aaa --- /dev/null +++ b/guix/scripts/system/edit.scm @@ -0,0 +1,64 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts system edit) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module (guix ui) + #:autoload (guix utils) (string-closest) + #:use-module (gnu services) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:autoload (guix scripts edit) (spawn-editor) + #:export (guix-system-edit)) + +(define (service-type-not-found type) + "Report an error about @var{type} not being found and exit." + (report-error (G_ "~a: no such service type~%") type) + + (let* ((type (symbol->string type)) + (available (fold-service-types (lambda (type lst) + (cons (symbol->string + (service-type-name type)) + lst)) + '())) + (closest (string-closest type available))) + (unless (or (not closest) (string=? closest type)) + (display-hint (format #f (G_ "Did you mean @code{~a}?~%") + closest)))) + + (exit 1)) + + +(define (guix-system-edit . args) + (when (null? args) + (leave (G_ "no service types specified, nothing to edit~%"))) + + (let* ((types (append-map (lambda (type) + (let ((type (string->symbol type))) + (match (lookup-service-types type) + (() (service-type-not-found type)) + ((one) (list one)) + (lst + (warning (N_ "~a: ~a matching service type~%" + "~a: ~a matching service types~%" + (length lst)) + type (length lst)) + lst)))) + args))) + (spawn-editor (filter-map service-type-location types)))) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index bf23fb06af..9ca66687ee 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -134,6 +134,7 @@ return the <live-service> objects that are currently running on MACHINE." (map (lambda (service) (list (live-service-provision service) (live-service-requirement service) + (live-service-transient? service) (match (live-service-running service) (#f #f) (#t #t) @@ -143,8 +144,9 @@ return the <live-service> objects that are currently running on MACHINE." (mlet %store-monad ((services (eval exp))) (return (map (match-lambda - ((provision requirement running) - (live-service provision requirement running))) + ((provision requirement transient? running) + (live-service provision requirement + transient? running))) services)))) ;; XXX: Currently, this does NOT attempt to restart running services. See diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index bf49ea2341..44f00194cd 100644 --- a/guix/scripts/system/search.scm +++ b/guix/scripts/system/search.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017-2019, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; ;;; This file is part of GNU Guix. @@ -20,6 +20,8 @@ (define-module (guix scripts system search) #:use-module (guix ui) #:use-module (guix utils) + #:autoload (guix colors) (color-output? highlight supports-hyperlinks?) + #:autoload (guix diagnostics) (location->hyperlink) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (srfi srfi-1) @@ -68,10 +70,15 @@ provided TYPE has a default value." #:optional (width (%text-width)) #:key (extra-fields '()) - (hyperlinks? (supports-hyperlinks? port))) + (hyperlinks? (supports-hyperlinks? port)) + (highlighting identity)) "Write to PORT a recutils record of TYPE, arranging to fit within WIDTH columns. When HYPERLINKS? is true, emit hyperlink escape sequences when -appropriate." +appropriate. Pass the description through HIGHLIGHTING, a one-argument +procedure that may return a colorized version of its argument." + (define port* + (or (pager-wrapped-port port) port)) + (define width* ;; The available number of columns once we've taken into account space for ;; the initial "+ " prefix. @@ -85,8 +92,15 @@ appropriate." (fill-paragraph list width* (string-length "extends: "))))) + (define highlighting* + (if (color-output? port*) + highlighting + identity)) + ;; Note: Don't i18n field names so that people can post-process it. - (format port "name: ~a~%" (service-type-name type)) + (format port "name: ~a~%" + (highlight (symbol->string (service-type-name type)) + port*)) (format port "location: ~a~%" (or (and=> (service-type-location type) (if hyperlinks? location->hyperlink location->string)) @@ -107,14 +121,15 @@ appropriate." (when (service-type-description type) (format port "~a~%" - (string->recutils - (string-trim-right - (parameterize ((%text-width width*)) - (texi->plain-text - (string-append "description: " - (or (and=> (service-type-description type) P_) - "")))) - #\newline)))) + (highlighting* + (string->recutils + (string-trim-right + (parameterize ((%text-width width*)) + (texi->plain-text + (string-append "description: " + (or (and=> (service-type-description type) P_) + "")))) + #\newline))))) (for-each (match-lambda ((field . value) @@ -174,4 +189,5 @@ description matches REGEXPS sorted by relevance, and their score." (leave-on-EPIPE (display-search-results matches (current-output-port) #:print service-type->recutils + #:regexps regexps #:command "guix system search"))))) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 60a697d1ac..b7d8165262 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> @@ -31,6 +31,7 @@ #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix gexp) + #:use-module (guix colors) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module ((guix build utils) #:select (every*)) #:use-module (guix substitutes) @@ -39,6 +40,7 @@ #:use-module (guix ci) #:use-module (guix sets) #:use-module (guix graph) + #:use-module (guix scripts build) #:autoload (guix scripts graph) (%bag-node-type) #:use-module (gnu packages) #:use-module (web uri) @@ -203,7 +205,7 @@ In case ITEMS is an empty list, return 1 instead." #:make-progress-reporter (lambda* (total #:key url #:allow-other-keys) (progress-reporter/bar total))))) - (format #t "~a~%" server) + (format #t (highlight "~a~%") server) (let ((obtained (length narinfos)) (requested (length items)) (missing (lset-difference string=? @@ -215,9 +217,17 @@ In case ITEMS is an empty list, return 1 instead." (time (+ (time-second time) (/ (time-nanosecond time) 1e9)))) (when (> requested 0) - (format #t (G_ " ~,1f% substitutes available (~h out of ~h)~%") - (* 100. (/ obtained requested 1.)) - obtained requested)) + (let* ((ratio (/ obtained requested 1.)) + (colorize (cond ((> ratio 0.80) + (coloring-procedure (color BOLD GREEN))) + ((< ratio 0.50) + (coloring-procedure (color BOLD RED))) + (else + highlight)))) + (format #t + (colorize (G_ " ~,1f% substitutes available (~h out of ~h)~%")) + (* 100. ratio) + obtained requested))) (let ((total (/ (reduce + 0 sizes) MiB))) (match (length sizes) ((? zero?) @@ -330,18 +340,18 @@ Report the availability of substitutes.\n")) 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_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) (newline) + (show-native-build-options-help) + (newline) (show-bug-report-information)) (define %options - (list (option '(#\h "help") #f #f + (cons* (option '(#\h "help") #f #f (lambda args (show-help) (exit 0))) @@ -371,9 +381,7 @@ Report the availability of substitutes.\n")) (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))))) + %standard-native-build-options)) (define %default-options `((substitute-urls . ,%default-substitute-urls))) diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 002e6342bb..6b13a98946 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,8 @@ search-path-specification-file-pattern $PATH + $SSL_CERT_DIR + $SSL_CERT_FILE search-path-specification->sexp sexp->search-path-specification @@ -70,6 +73,29 @@ (variable "PATH") (files '("bin" "sbin")))) +;; Two variables for certificates (see (guix)X.509 Certificates), +;; respected by 'openssl', possibly GnuTLS in the future +;; (https://gitlab.com/gnutls/gnutls/-/merge_requests/1541) +;; and many of their dependents -- even some GnuTLS depepdents +;; like Guile. As they are not tied to a single package, define +;; them here to avoid duplication. +;; +;; Additionally, the 'native-search-paths' field is not thunked, +;; so doing (package-native-search-paths openssl) +;; could cause import cycle issues. +(define-public $SSL_CERT_DIR + (search-path-specification + (variable "SSL_CERT_DIR") + (separator #f) ;single entry + (files '("etc/ssl/certs")))) + +(define-public $SSL_CERT_FILE + (search-path-specification + (variable "SSL_CERT_FILE") + (file-type 'regular) + (separator #f) ;single entry + (files '("etc/ssl/certs/ca-certificates.crt")))) + (define (search-path-specification->sexp spec) "Return an sexp representing SPEC, a <search-path-specification>. The sexp corresponds to the arguments expected by `set-path-environment-variable'." diff --git a/guix/self.scm b/guix/self.scm index 943bb0b498..9a64051c32 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -887,7 +887,8 @@ itself." ,@(scheme-modules* source "gnu/bootloader") ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services") - ,@(scheme-modules* source "gnu/machine")) + ,@(scheme-modules* source "gnu/machine") + ,@(scheme-modules* source "guix/platforms/")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules*) #:extensions dependencies diff --git a/guix/store.scm b/guix/store.scm index 1d176fb99d..6bdd071b48 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de> @@ -33,6 +33,7 @@ #:use-module (gcrypt hash) #:use-module (guix profiling) #:autoload (guix build syscalls) (terminal-columns) + #:autoload (guix build utils) (dump-port) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module ((ice-9 control) #:select (let/ec)) @@ -682,29 +683,6 @@ automatically close the store when the dynamic extent of EXP is left." ;; The port where build output is sent. (make-parameter (current-error-port))) -(define* (dump-port in out - #:optional len - #:key (buffer-size 16384)) - "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it -to OUT, using chunks of BUFFER-SIZE bytes." - (define buffer - (make-bytevector buffer-size)) - - (let loop ((total 0) - (bytes (get-bytevector-n! in buffer 0 - (if len - (min len buffer-size) - buffer-size)))) - (or (eof-object? bytes) - (and len (= total len)) - (let ((total (+ total bytes))) - (put-bytevector out buffer 0 bytes) - (loop total - (get-bytevector-n! in buffer 0 - (if len - (min (- len total) buffer-size) - buffer-size))))))) - (define %newlines ;; Newline characters triggering a flush of 'current-build-output-port'. ;; Unlike Guile's 'line, we flush upon #\return so that progress reports @@ -1359,11 +1337,25 @@ object, only for build requests on EXPECTED-STORE." (if (and (eq? (store-connection-socket store) (store-connection-socket expected-store)) (= mode (build-mode normal))) - (unresolved things continue) + (begin + ;; Preserve caches accumulated up to this handler invocation. + (set-store-connection-caches! expected-store + (store-connection-caches store)) + + (unresolved things + (lambda (new-store value) + ;; Borrow caches from NEW-STORE. + (set-store-connection-caches! + store (store-connection-caches new-store)) + (continue value)))) (continue #t)))) +(define default-cutoff + ;; Default cutoff parameter for 'map/accumulate-builds'. + (make-parameter 32)) + (define* (map/accumulate-builds store proc lst - #:key (cutoff 30)) + #:key (cutoff (default-cutoff))) "Apply PROC over each element of LST, accumulating 'build-things' calls and coalescing them into a single call. @@ -1377,21 +1369,24 @@ CUTOFF is the threshold above which we stop accumulating unresolved nodes." (build-accumulator store)) (define-values (result rest) - (let loop ((lst lst) - (result '()) - (unresolved 0)) - (match lst - ((head . tail) - (match (with-build-handler accumulator - (proc head)) - ((? unresolved? obj) - (if (>= unresolved cutoff) - (values (reverse (cons obj result)) tail) - (loop tail (cons obj result) (+ 1 unresolved)))) - (obj - (loop tail (cons obj result) unresolved)))) - (() - (values (reverse result) lst))))) + ;; Have the default cutoff decay as we go deeper in the call stack to + ;; avoid pessimal behavior. + (parameterize ((default-cutoff (quotient cutoff 2))) + (let loop ((lst lst) + (result '()) + (unresolved 0)) + (match lst + ((head . tail) + (match (with-build-handler accumulator + (proc head)) + ((? unresolved? obj) + (if (>= unresolved cutoff) + (values (reverse (cons obj result)) tail) + (loop tail (cons obj result) (+ 1 unresolved)))) + (obj + (loop tail (cons obj result) unresolved)))) + (() + (values (reverse result) lst)))))) (match (append-map (lambda (obj) (if (unresolved? obj) @@ -1412,7 +1407,8 @@ CUTOFF is the threshold above which we stop accumulating unresolved nodes." (if (unresolved? obj) ;; Pass #f because 'build-things' is now ;; unnecessary. - ((unresolved-continuation obj) #f) + ((unresolved-continuation obj) + store #f) obj)) result #:cutoff cutoff) (map/accumulate-builds store proc rest #:cutoff cutoff))))) @@ -1793,6 +1789,14 @@ This makes sense only when the daemon was started with '--cache-failures'." ;; the 'caches' vector of <store-connection>. (define %store-connection-caches (make-atomic-box 0)) +(define %max-store-connection-caches + ;; Maximum number of caches returned by 'allocate-store-connection-cache'. + 32) + +(define %store-connection-cache-names + ;; Mapping of cache ID to symbol. + (make-vector %max-store-connection-caches)) + (define (allocate-store-connection-cache name) "Allocate a new cache for store connections and return its identifier. Said identifier can be passed as an argument to " @@ -1800,7 +1804,9 @@ identifier can be passed as an argument to " (let ((previous (atomic-box-compare-and-swap! %store-connection-caches current (+ current 1)))) (if (= previous current) - current + (begin + (vector-set! %store-connection-cache-names current name) + current) (loop current))))) (define %object-cache-id @@ -1845,8 +1851,10 @@ This is a mutating version that should be avoided. Prefer the functional (define (references/cached store item) "Like 'references', but cache results." - (let ((cache (store-connection-cache store %reference-cache-id))) - (match (vhash-assoc item cache) + (let* ((cache (store-connection-cache store %reference-cache-id)) + (value (vhash-assoc item cache))) + (record-cache-lookup! %reference-cache-id value cache) + (match value ((_ . references) references) (#f @@ -1926,16 +1934,37 @@ whether the cache lookup was a hit, and the actual cache (a vhash)." (lambda (x y) #t))) -(define record-cache-lookup! - (cache-lookup-recorder "object-cache" "Store object cache")) +(define recorder-for-cache + (let ((recorders (make-vector %max-store-connection-caches))) + (lambda (cache-id) + "Return a procedure to record lookup stats for CACHE-ID." + (match (vector-ref recorders cache-id) + ((? unspecified?) + (let* ((name (symbol->string + (vector-ref %store-connection-cache-names cache-id))) + (description + (string-titlecase + (string-map (match-lambda + (#\- #\space) + (chr chr)) + name)))) + (let ((proc (cache-lookup-recorder name description))) + (vector-set! recorders cache-id proc) + proc))) + (proc proc))))) + +(define (record-cache-lookup! cache-id value cache) + "Record the lookup of VALUE in CACHE-ID, whose current value is CACHE." + (let ((record! (recorder-for-cache cache-id))) + (record! value cache))) -(define-inlinable (lookup-cached-object object keys vhash-fold*) - "Return the cached object in the store connection corresponding to OBJECT +(define-inlinable (lookup-cached-object cache-id object keys vhash-fold*) + "Return the object in store cache CACHE-ID corresponding to OBJECT and KEYS; use VHASH-FOLD* to look for OBJECT in the cache. KEYS is a list of additional keys to match against, and which are compared with 'equal?'. Return #f on failure and the cached result otherwise." (lambda (store) - (let* ((cache (store-connection-cache store %object-cache-id)) + (let* ((cache (store-connection-cache store cache-id)) ;; Escape as soon as we find the result. This avoids traversing ;; the whole vlist chain and significantly reduces the number of @@ -1949,40 +1978,50 @@ Return #f on failure and the cached result otherwise." result)))) #f object cache)))) - (record-cache-lookup! value cache) + (record-cache-lookup! cache-id value cache) (values value store)))) (define* (%mcached mthunk object #:optional (keys '()) #:key + (cache %object-cache-id) (vhash-cons vhash-consq) (vhash-fold* vhash-foldq*)) "Bind the monadic value returned by MTHUNK, which supposedly corresponds to OBJECT/KEYS, or return its cached value. Use VHASH-CONS to insert OBJECT into the cache, and VHASH-FOLD* to look it up." - (mlet %store-monad ((cached (lookup-cached-object object keys + (mlet %store-monad ((cached (lookup-cached-object cache object keys vhash-fold*))) (if cached (return cached) (>>= (mthunk) (lambda (result) (cache-object-mapping object keys result + #:cache cache #:vhash-cons vhash-cons)))))) (define-syntax mcached - (syntax-rules (eq? equal?) + (syntax-rules (eq? equal? =>) "Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the value associated with OBJECT/KEYS in the store's object cache if there is one." - ((_ eq? mvalue object keys ...) + ((_ eq? (=> cache) mvalue object keys ...) (%mcached (lambda () mvalue) object (list keys ...) + #:cache cache #:vhash-cons vhash-consq #:vhash-fold* vhash-foldq*)) - ((_ equal? mvalue object keys ...) + ((_ equal? (=> cache) mvalue object keys ...) (%mcached (lambda () mvalue) object (list keys ...) + #:cache cache #:vhash-cons vhash-cons #:vhash-fold* vhash-fold*)) + ((_ eq? mvalue object keys ...) + (mcached eq? (=> %object-cache-id) + mvalue object keys ...)) + ((_ equal? mvalue object keys ...) + (mcached equal? (=> %object-cache-id) + mvalue object keys ...)) ((_ mvalue object keys ...) (mcached eq? mvalue object keys ...)))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 370df4a74c..ab982e3b3d 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -22,7 +22,7 @@ (define-module (guix store deduplication) #:use-module (gcrypt hash) - #:use-module ((guix build utils) #:hide (dump-port)) + #:use-module (guix build utils) #:use-module (guix build syscalls) #:use-module (guix base32) #:use-module (srfi srfi-11) @@ -38,31 +38,6 @@ dump-file/deduplicate copy-file/deduplicate)) -;; TODO: Remove once 'dump-port' in (guix build utils) has an optional 'len' -;; parameter. -(define* (dump-port in out - #:optional len - #:key (buffer-size 16384)) - "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it -to OUT, using chunks of BUFFER-SIZE bytes." - (define buffer - (make-bytevector buffer-size)) - - (let loop ((total 0) - (bytes (get-bytevector-n! in buffer 0 - (if len - (min len buffer-size) - buffer-size)))) - (or (eof-object? bytes) - (and len (= total len)) - (let ((total (+ total bytes))) - (put-bytevector out buffer 0 bytes) - (loop total - (get-bytevector-n! in buffer 0 - (if len - (min (- len total) buffer-size) - buffer-size))))))) - (define (nar-sha256 file) "Gives the sha256 hash of a file and the size of the file in nar form." (let-values (((port get-hash) (open-sha256-port))) diff --git a/guix/transformations.scm b/guix/transformations.scm index a0045e5b27..411c4014cb 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -959,7 +959,7 @@ to that transformation." . ,(map (match-lambda ((key value _) (cons key value))) - applicable)) + (reverse applicable))) ;preserve order ,@(package-properties p))))) (lambda (obj) diff --git a/guix/ui.scm b/guix/ui.scm index 6c194eb3c9..cb68a07c6c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -76,7 +76,6 @@ #:autoload (ice-9 popen) (open-pipe* close-pipe) #:autoload (system repl repl) (start-repl) #:autoload (system repl debug) (make-debug stack->vector) - #:autoload (web uri) (encode-and-join-uri-path) #:use-module (texinfo) #:use-module (texinfo plain-text) #:use-module (texinfo string-utils) @@ -119,11 +118,6 @@ package->recutils package-specification->name+version+output - supports-hyperlinks? - hyperlink - file-hyperlink - location->hyperlink - pager-wrapped-port with-paginated-output-port relevance @@ -1488,46 +1482,19 @@ followed by \"+ \", which makes for a valid multi-line field value in the '() str))) -(define (hyperlink uri text) - "Return a string that denotes a hyperlink using an OSC escape sequence as -documented at -<https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda>." - (string-append "\x1b]8;;" uri "\x1b\\" - text "\x1b]8;;\x1b\\")) - -(define* (supports-hyperlinks? #:optional (port (current-output-port))) - "Return true if PORT is a terminal that supports hyperlink escapes." - ;; Note that terminals are supposed to ignore OSC escapes they don't - ;; understand (this is the case of xterm as of version 349, for instance.) - ;; However, Emacs comint as of 26.3 does not ignore it and instead lets it - ;; through, hence the 'INSIDE_EMACS' special case below. - (and (isatty?* port) - (not (getenv "INSIDE_EMACS")))) - -(define* (file-hyperlink file #:optional (text file)) - "Return TEXT with escapes for a hyperlink to FILE." - (hyperlink (string-append "file://" (gethostname) - (encode-and-join-uri-path - (string-split file #\/))) - text)) - -(define (location->hyperlink location) - "Return a string corresponding to LOCATION, with escapes for a hyperlink." - (let ((str (location->string location)) - (file (if (string-prefix? "/" (location-file location)) - (location-file location) - (search-path %load-path (location-file location))))) - (if file - (file-hyperlink file str) - str))) - (define* (package->recutils p port #:optional (width (%text-width)) #:key (hyperlinks? (supports-hyperlinks? port)) - (extra-fields '())) + (extra-fields '()) + (highlighting identity)) "Write to PORT a `recutils' record of package P, arranging to fit within WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit. When -HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." +HYPERLINKS? is true, emit hyperlink escape sequences when appropriate. Pass +the synopsis and description through HIGHLIGHTING, a one-argument procedure +that may return a colorized version of its argument." + (define port* + (or (pager-wrapped-port port) port)) + (define width* ;; The available number of columns once we've taken into account space for ;; the initial "+ " prefix. @@ -1546,9 +1513,14 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." (define (package<? p1 p2) (string<? (package-full-name p1) (package-full-name p2))) + (define highlighting* + (if (color-output? port*) + highlighting + identity)) + ;; Note: Don't i18n field names so that people can post-process it. - (format port "name: ~a~%" (package-name p)) - (format port "version: ~a~%" (package-version p)) + (format port "name: ~a~%" (highlight (package-name p) port*)) + (format port "version: ~a~%" (highlight (package-version p) port*)) (format port "outputs: ~a~%" (string-join (package-outputs p))) (format port "systems: ~a~%" (split-lines (string-join (package-transitive-supported-systems p)) @@ -1580,22 +1552,24 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." (x (G_ "unknown")))) (format port "synopsis: ~a~%" - (string-map (match-lambda - (#\newline #\space) - (chr chr)) - (or (package-synopsis-string p) ""))) + (highlighting* + (string-map (match-lambda + (#\newline #\space) + (chr chr)) + (or (package-synopsis-string p) "")))) (format port "~a~%" - (string->recutils - (string-trim-right - (parameterize ((%text-width width*)) - ;; Call 'texi->plain-text' on the concatenated string to account - ;; for the width of "description:" in paragraph filling. - (texi->plain-text* - p - (string-append "description: " - (or (and=> (package-description p) P_) - "")))) - #\newline))) + (highlighting* + (string->recutils + (string-trim-right + (parameterize ((%text-width width*)) + ;; Call 'texi->plain-text' on the concatenated string to account + ;; for the width of "description:" in paragraph filling. + (texi->plain-text* + p + (string-append "description: " + (or (and=> (package-description p) P_) + "")))) + #\newline)))) (for-each (match-lambda ((field . value) (let ((field (symbol->string field))) @@ -1743,10 +1717,12 @@ standard output is a tty, or with PORT set to the current output port." (define* (display-search-results matches port #:key + (regexps '()) (command "guix search") (print package->recutils)) "Display MATCHES, a list of object/score pairs, by calling PRINT on each of -them. If PORT is a terminal, print at most a full screen of results." +them. If PORT is a terminal, print at most a full screen of results. REGEXPS +is a list of regexps to highlight in search results." (define first-line (port-line port)) @@ -1757,6 +1733,12 @@ them. If PORT is a terminal, print at most a full screen of results." (define (line-count str) (string-count str #\newline)) + (define highlighting + (let ((match-color (color ON-RED BOLD))) + (colorize-full-matches (map (lambda (regexp) + (cons regexp match-color)) + regexps)))) + (with-paginated-output-port paginated (let loop ((matches matches)) (match matches @@ -1764,7 +1746,8 @@ them. If PORT is a terminal, print at most a full screen of results." (let* ((links? (supports-hyperlinks? port))) (print package paginated #:hyperlinks? links? - #:extra-fields `((relevance . ,score))) + #:extra-fields `((relevance . ,score)) + #:highlighting highlighting) (loop rest))) (() #t))))) diff --git a/guix/utils.scm b/guix/utils.scm index 44c46cb4a9..37b2e29800 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -8,12 +8,11 @@ ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org> ;;; Copyright © 2020, 2021 Efraim Flashner <efraim@flashner.co.il> -;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,7 +37,6 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) #:use-module (srfi srfi-71) - #:use-module (ice-9 ftw) #:use-module (rnrs io ports) ;need 'port-position' etc. #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix memoization) @@ -49,10 +47,11 @@ #:use-module ((guix combinators) #:select (fold2)) #:use-module (guix diagnostics) ;<location>, &error-location, etc. #:use-module (ice-9 format) - #:use-module (ice-9 regex) - #:use-module (ice-9 match) - #:use-module (ice-9 format) + #:use-module (ice-9 ftw) #:use-module ((ice-9 iconv) #:prefix iconv:) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) #:use-module (ice-9 vlist) #:autoload (zlib) (make-zlib-input-port make-zlib-output-port) #:use-module (system foreign) @@ -79,6 +78,7 @@ substitute-keyword-arguments ensure-keyword-arguments + %guix-source-root-directory current-source-directory nix-system->gnu-triplet @@ -133,6 +133,7 @@ readlink* go-to-location edit-expression + delete-expression filtered-port decompressed-port @@ -433,11 +434,13 @@ TARGET must be stat buffers as returned by 'stat'." (hash-set! %source-location-map target-key `(,@target-stamp ,source-map))))))) -(define* (edit-expression source-properties proc #:key (encoding "UTF-8")) +(define* (edit-expression source-properties proc #:key (encoding "UTF-8") + include-trailing-newline?) "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should be a procedure that takes the original expression in string and returns a new -one. ENCODING will be used to interpret all port I/O, it default to UTF-8. -This procedure returns #t on success." +one. ENCODING will be used to interpret all port I/O, it defaults to UTF-8. +This procedure returns #t on success. When INCLUDE-TRAILING-NEWLINE? is true, +the trailing line is included in the edited expression." (define file (assq-ref source-properties 'filename)) (define line (assq-ref source-properties 'line)) (define column (assq-ref source-properties 'column)) @@ -446,10 +449,14 @@ This procedure returns #t on success." (call-with-input-file file (lambda (in) (let* ( ;; The start byte position of the expression. - (start (begin (go-to-location in (+ 1 line) (+ 1 column)) + (start (begin (go-to-location + in (+ 1 line) (+ 1 column)) (ftell in))) ;; The end byte position of the expression. - (end (begin (read in) (ftell in)))) + (end (begin (read in) + (when include-trailing-newline? + (read-line in)) + (ftell in)))) (seek in 0 SEEK_SET) ; read from the beginning of the file. (let* ((pre-bv (get-bytevector-n in start)) ;; The expression in string form. @@ -478,6 +485,10 @@ This procedure returns #t on success." (move-source-location-map! (stat in) (stat file) (+ 1 line)))))))))) +(define (delete-expression source-properties) + "Delete the expression specified by SOURCE-PROPERTIES." + (edit-expression source-properties (const "") #:include-trailing-newline? #t)) + ;;; ;;; Keyword arguments. @@ -1021,6 +1032,10 @@ environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like ;;; Source location. ;;; +(define (%guix-source-root-directory) + "Return the source root directory of the Guix found in %load-path." + (dirname (absolute-dirname "guix/packages.scm"))) + (define absolute-dirname ;; Memoize to avoid repeated 'stat' storms from 'search-path'. (mlambda (file) |