diff options
Diffstat (limited to 'guix')
34 files changed, 1624 insertions, 217 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/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/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/http-client.scm b/guix/http-client.scm index a367c41afa..9138a627ac 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -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/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/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/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/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 e535eb8158..375f189335 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1348,7 +1348,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 a79b36d03d..7ee65e9b6b 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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/environment.scm b/guix/scripts/environment.scm index 07b54cd89b..3216235937 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -96,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_ " @@ -145,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_ " @@ -226,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))) @@ -273,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." 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/import.scm b/guix/scripts/import.scm index 40fa6759ae..fa79f3211e 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2019 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. ;;; @@ -80,7 +81,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 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 32f0d3abb1..d3ee69840c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -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 d007005607..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) @@ -694,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)) @@ -714,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)) @@ -979,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> @@ -1021,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/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/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/system.scm b/guix/scripts/system.scm index 73e3c299c1..eaa245eb44 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -66,7 +66,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) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index adba614b8c..b7d8165262 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -40,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) @@ -339,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))) @@ -380,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/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..82fca14cd9 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 @@ -1362,8 +1340,12 @@ object, only for build requests on EXPECTED-STORE." (unresolved things continue) (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 +1359,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) @@ -1793,6 +1778,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 +1793,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 @@ -1926,16 +1921,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-inlinable (lookup-cached-object object keys vhash-fold*) - "Return the cached object in the store connection corresponding to OBJECT +(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 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 +1965,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))) |