diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/r.scm | 2 | ||||
| -rw-r--r-- | guix/channels.scm | 9 | ||||
| -rw-r--r-- | guix/git-download.scm | 123 | ||||
| -rw-r--r-- | guix/hg-download.scm | 127 | ||||
| -rw-r--r-- | guix/import/cran.scm | 6 | ||||
| -rw-r--r-- | guix/import/crate.scm | 8 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 1 | ||||
| -rw-r--r-- | guix/import/npm-binary.scm | 279 | ||||
| -rw-r--r-- | guix/import/utils.scm | 9 | ||||
| -rw-r--r-- | guix/packages.scm | 52 | ||||
| -rw-r--r-- | guix/profiles.scm | 7 | ||||
| -rw-r--r-- | guix/records.scm | 58 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/git/authenticate.scm | 199 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/npm-binary.scm | 121 | ||||
| -rw-r--r-- | guix/scripts/style.scm | 4 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 3 | ||||
| -rw-r--r-- | guix/self.scm | 19 | ||||
| -rw-r--r-- | guix/store.scm | 55 | ||||
| -rw-r--r-- | guix/store/deduplication.scm | 79 | ||||
| -rw-r--r-- | guix/svn-download.scm | 271 | ||||
| -rw-r--r-- | guix/transformations.scm | 8 |
24 files changed, 1133 insertions, 320 deletions
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 7ab4db82b6..37786f02a0 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -60,7 +60,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.18" + (string-append "https://bioconductor.org/packages/3.19" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) diff --git a/guix/channels.scm b/guix/channels.scm index 51024dcad4..0d7bc541cc 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -3,6 +3,8 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2024 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2024 Rostislav Svoboda <Rostislav.Svoboda@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -364,8 +366,11 @@ fails." (define (make-reporter start-commit end-commit commits) (format (current-error-port) - (G_ "Authenticating channel '~a', commits ~a to ~a (~h new \ -commits)...~%") + (N_ "Authenticating channel '~a', commits ~a to ~a (~h new \ +commit)...~%" + "Authenticating channel '~a', commits ~a to ~a (~h new \ +commits)...~%" + (length commits)) (channel-name channel) (commit-short-id start-commit) (commit-short-id end-commit) diff --git a/guix/git-download.scm b/guix/git-download.scm index d26a814e07..ce40701563 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -48,6 +48,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:export (git-reference git-reference? git-reference-url @@ -86,20 +87,13 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'git-lfs))) -(define* (git-fetch/in-band* ref hash-algo hash - #:optional name - #:key (system (%current-system)) - (guile (default-guile)) - (git (git-package)) - git-lfs) - "Shared implementation code for git-fetch/in-band & friends. Refer to their -respective documentation." +(define (git-fetch-builder git git-lfs git-ref-recursive? hash-algo) (define inputs `(,(or git (git-package)) ,@(if git-lfs (list git-lfs) '()) - ,@(if (git-reference-recursive? ref) + ,@(if git-ref-recursive? ;; TODO: remove (standard-packages) after ;; 48e528a26f9c019eeaccf5e3de3126aa02c98d3b is merged into master; ;; currently when doing 'git clone --recursive', we need sed, grep, @@ -132,59 +126,82 @@ respective documentation." (source-module-closure '((guix build git) (guix build utils))))) - (define build - (with-imported-modules modules - (with-extensions (list guile-json gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build git) - ((guix build utils) - #:select (set-path-environment-variable)) - (ice-9 match)) - - (define lfs? - (call-with-input-string (getenv "git lfs?") read)) - - (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. This also ensures that git extensions are - ;; found. - (set-path-environment-variable "PATH" '("bin") '#+inputs) - - (setvbuf (current-output-port) 'line) - (setvbuf (current-error-port) 'line) - - (git-fetch-with-fallback (getenv "git url") (getenv "git commit") - #$output - #:hash #$hash - #:hash-algorithm '#$hash-algo - #:lfs? lfs? - #:recursive? recursive? - #:git-command "git"))))) + (with-imported-modules modules + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build git) + ((guix build utils) + #:select (set-path-environment-variable)) + (ice-9 match) + (rnrs bytevectors)) + + (define lfs? + (call-with-input-string (getenv "git lfs?") read)) + + (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. This also ensures that git extensions are + ;; found. + (set-path-environment-variable "PATH" '("bin") '#+inputs) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (git-fetch-with-fallback (getenv "git url") (getenv "git commit") + #$output + #:hash (u8-list->bytevector + (map + string->number + (string-split (getenv "hash") #\,))) + #:hash-algorithm '#$hash-algo + #:lfs? lfs? + #:recursive? recursive? + #:git-command "git"))))) +(define* (git-fetch/in-band* ref hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + (git (git-package)) + git-lfs) + "Shared implementation code for git-fetch/in-band & friends. Refer to their +respective documentation." (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system))) - (gexp->derivation (or name "git-checkout") build - - ;; Use environment variables and a fixed script name so - ;; there's only one script in store for all the - ;; downloads. + (gexp->derivation (or name "git-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (git-fetch-builder git git-lfs + (git-reference-recursive? ref) + hash-algo) #:script-name "git-download" #:env-vars `(("git url" . ,(git-reference-url ref)) ("git commit" . ,(git-reference-commit ref)) ("git recursive?" . ,(object->string (git-reference-recursive? ref))) - ("git lfs?" . ,(if git-lfs "#t" "#f"))) + ("git lfs?" . ,(if git-lfs "#t" "#f")) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ","))) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS") diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 55d908817f..df48ed6eb7 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -30,6 +30,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) + #:use-module (rnrs bytevectors) #:export (hg-reference hg-reference? hg-reference-url @@ -58,13 +59,7 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'mercurial))) -(define* (hg-fetch ref hash-algo hash - #:optional name - #:key (system (%current-system)) (guile (default-guile)) - (hg (hg-package))) - "Return a fixed-output derivation that fetches REF, a <hg-reference> -object. The output is expected to have recursive hash HASH of type -HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." +(define (hg-fetch-builder hg hash-algo) (define inputs ;; The 'swh-download' procedure requires tar and gzip. `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression)) @@ -88,56 +83,84 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (guix build download-nar) (guix swh))))) - (define build - (with-imported-modules modules - (with-extensions (list guile-json gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build hg) - (guix build utils) ;for `set-path-environment-variable' - ((guix build download) - #:select (download-method-enabled?)) - (guix build download-nar) - (guix swh) - (ice-9 match)) - - (set-path-environment-variable "PATH" '("bin") - (match '#+inputs - (((names dirs outputs ...) ...) - dirs))) - - (setvbuf (current-output-port) 'line) - (setvbuf (current-error-port) 'line) - - (or (and (download-method-enabled? 'upstream) - (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg"))) - (and (download-method-enabled? 'nar) - (download-nar #$output)) - ;; As a last resort, attempt to download from Software Heritage. - ;; Disable X.509 certificate verification to avoid depending - ;; on nss-certs--we're authenticating the checkout anyway. - (and (download-method-enabled? 'swh) - (parameterize ((%verify-swh-certificate? #f)) - (format (current-error-port) - "Trying to download from Software Heritage...~%") - (or (swh-download-directory-by-nar-hash - #$hash '#$hash-algo #$output) - (swh-download #$(hg-reference-url ref) - #$(hg-reference-changeset ref) - #$output))))))))) + (with-imported-modules modules + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build hg) + (guix build utils) ;for `set-path-environment-variable' + ((guix build download) + #:select (download-method-enabled?)) + (guix build download-nar) + (guix swh) + (ice-9 match) + (rnrs bytevectors)) + + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs outputs ...) ...) + dirs))) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (or (and (download-method-enabled? 'upstream) + (hg-fetch (getenv "hg ref url") + (getenv "hg ref changeset") + #$output + #:hg-command (string-append #+hg "/bin/hg"))) + (and (download-method-enabled? 'nar) + (download-nar #$output)) + ;; As a last resort, attempt to download from Software Heritage. + ;; Disable X.509 certificate verification to avoid depending + ;; on nss-certs--we're authenticating the checkout anyway. + (and (download-method-enabled? 'swh) + (parameterize ((%verify-swh-certificate? #f)) + (format (current-error-port) + "Trying to download from Software Heritage...~%") + (or (swh-download-directory-by-nar-hash + (u8-list->bytevector + (map string->number + (string-split (getenv "hash") #\,))) + '#$hash-algo + #$output) + (swh-download (getenv "hg ref url") + (getenv "hg ref changeset") + #$output))))))))) +(define* (hg-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile)) + (hg (hg-package))) + "Return a fixed-output derivation that fetches REF, a <hg-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (mlet %store-monad ((guile (package->derivation guile system))) - (gexp->derivation (or name "hg-checkout") build + (gexp->derivation (or name "hg-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (hg-fetch-builder hg hash-algo) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS") - #:env-vars (match (getenv "GUIX_DOWNLOAD_METHODS") - (#f '()) - (value - `(("GUIX_DOWNLOAD_METHODS" . ,value)))) + #:env-vars + `(("hg ref url" . ,(hg-reference-url ref)) + ("hg ref changeset" . ,(hg-reference-changeset ref)) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ",")) + ,@(match (getenv "GUIX_DOWNLOAD_METHODS") + (#f '()) + (value + `(("GUIX_DOWNLOAD_METHODS" . ,value))))) #:system system #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo diff --git a/guix/import/cran.scm b/guix/import/cran.scm index c4c42836ee..6ae00cae96 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -194,13 +194,13 @@ package definition." ((package-inputs ...) `((,input-type (list ,@(format-inputs package-inputs))))))) -(define %cran-url "https://cran.r-project.org/web/packages/") +(define %cran-url "https://cloud.r-project.org/web/packages/") (define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.18. Bioconductor packages should be +;; The latest Bioconductor release is 3.19. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.18") +(define %bioconductor-version "3.19") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 7a25b2243c..c4551688f6 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -187,6 +187,7 @@ and LICENSE." (guix-name (crate-name->package-name name)) (cargo-inputs (format-inputs cargo-inputs)) (cargo-development-inputs (format-inputs cargo-development-inputs)) + (description (beautify-description description)) (pkg `(package (name ,guix-name) (version ,version) @@ -211,8 +212,11 @@ and LICENSE." (maybe-cargo-development-inputs cargo-development-inputs))) (home-page ,home-page) - (synopsis ,synopsis) - (description ,(beautify-description description)) + (synopsis ,(beautify-synopsis synopsis)) + (description ,(if (string-prefix? "This" description) + description + (string-append "This package provides " + description))) (license ,(match license (() #f) (#f #f) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index d1855b3698..46b6dc98a2 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -250,6 +250,7 @@ RECIPE." (uri (git-reference (url ,url) (commit ,commit))) + (file-name (git-file-name name version)) (sha256 (base32 ,(bytevector->nix-base32-string diff --git a/guix/import/npm-binary.scm b/guix/import/npm-binary.scm new file mode 100644 index 0000000000..6dfedc4910 --- /dev/null +++ b/guix/import/npm-binary.scm @@ -0,0 +1,279 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 Timothy Sample <samplet@ngyro.com> +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> +;;; Copyright © 2020, 2023, 2024 Jelle Licht <jlicht@fsfe.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 import npm-binary) + #:use-module ((gnu services configuration) #:select (alist?)) + #:use-module (gcrypt hash) + #:use-module (gnu packages) + #:use-module (guix base32) + #:use-module (guix http-client) + #:use-module (guix import json) + #:use-module (guix import utils) + #:use-module (guix memoization) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-41) + #:use-module (srfi srfi-9) + #:use-module (web client) + #:use-module (web response) + #:use-module (web uri) + #:export (npm-binary-recursive-import + npm-binary->guix-package + %npm-registry + make-versioned-package + name+version->symbol)) + +;; Autoload Guile-Semver so we only have a soft dependency. +(module-autoload! (current-module) + '(semver) + '(string->semver semver? semver->string semver=? semver>?)) +(module-autoload! (current-module) + '(semver ranges) + '(*semver-range-any* string->semver-range semver-range-contains?)) + +;; Dist-tags +(define-json-mapping <dist-tags> make-dist-tags dist-tags? + json->dist-tags + (latest dist-tags-latest "latest" string->semver)) + +(define-record-type <versioned-package> + (make-versioned-package name version) + versioned-package? + (name versioned-package-name) ;string + (version versioned-package-version)) ;string + +(define (dependencies->versioned-packages entries) + (match entries + (((names . versions) ...) + (map make-versioned-package names versions)) + (_ '()))) + +(define (extract-license license-string) + (if (unspecified? license-string) + 'unspecified! + (spdx-string->license license-string))) + +(define-json-mapping <dist> make-dist dist? + json->dist + (tarball dist-tarball)) + +(define (empty-or-string s) + (if (string? s) s "")) + +(define-json-mapping <package-revision> make-package-revision package-revision? + json->package-revision + (name package-revision-name) + (version package-revision-version "version" ;semver + string->semver) + (home-page package-revision-home-page "homepage") ;string + (dependencies package-revision-dependencies ;list of versioned-package + "dependencies" + dependencies->versioned-packages) + (dev-dependencies package-revision-dev-dependencies ;list of versioned-package + "devDependencies" dependencies->versioned-packages) + (peer-dependencies package-revision-peer-dependencies ;list of versioned-package + "peerDependencies" dependencies->versioned-packages) + (license package-revision-license "license" ;license | #f + (match-lambda + ((? unspecified?) #f) + ((? string? str) (spdx-string->license str)) + ((? alist? alist) + (match (assoc "type" alist) + ((_ . (? string? type)) + (spdx-string->license type)) + (_ #f))))) + (description package-revision-description ;string + "description" empty-or-string) + (dist package-revision-dist "dist" json->dist)) ;dist + +(define (versions->package-revisions versions) + (match versions + (((version . package-spec) ...) + (map json->package-revision package-spec)) + (_ '()))) + +(define (versions->package-versions versions) + (match versions + (((version . package-spec) ...) + (map string->semver versions)) + (_ '()))) + +(define-json-mapping <meta-package> make-meta-package meta-package? + json->meta-package + (name meta-package-name) ;string + (description meta-package-description) ;string + (dist-tags meta-package-dist-tags "dist-tags" json->dist-tags) ;dist-tags + (revisions meta-package-revisions "versions" versions->package-revisions)) + +(define %npm-registry + (make-parameter "https://registry.npmjs.org")) +(define %default-page "https://www.npmjs.com/package") + +(define (lookup-meta-package name) + (let ((json (json-fetch (string-append (%npm-registry) "/" (uri-encode name))))) + (and=> json json->meta-package))) + +(define lookup-meta-package* (memoize lookup-meta-package)) + +(define (meta-package-versions meta) + (map package-revision-version + (meta-package-revisions meta))) + +(define (meta-package-latest meta) + (and=> (meta-package-dist-tags meta) dist-tags-latest)) + +(define* (meta-package-package meta #:optional + (version (meta-package-latest meta))) + (match version + ((? semver?) (find (lambda (revision) + (semver=? version (package-revision-version revision))) + (meta-package-revisions meta))) + ((? string?) (meta-package-package meta (string->semver version))) + (_ #f))) + +(define* (semver-latest svs #:optional (svr *semver-range-any*)) + (find (cut semver-range-contains? svr <>) + (sort svs semver>?))) + +(define* (resolve-package name #:optional (svr *semver-range-any*)) + (let ((meta (lookup-meta-package* name))) + (and meta + (let* ((version (semver-latest (or (meta-package-versions meta) '()) svr)) + (pkg (meta-package-package meta version))) + pkg)))) + + +;;; +;;; Converting packages +;;; + +(define (hash-url url) + "Downloads the resource at URL and computes the base32 hash for it." + (bytevector->nix-base32-string (port-sha256 (http-fetch url)))) + +(define (npm-name->name npm-name) + "Return a Guix package name for the npm package with name NPM-NAME." + (define (clean name) + (string-map (lambda (chr) (if (char=? chr #\/) #\- chr)) + (string-filter (negate (cut char=? <> #\@)) name))) + (guix-name "node-" (clean npm-name))) + +(define (name+version->symbol name version) + (string->symbol (string-append name "-" version))) + +(define (package-revision->symbol package) + (let* ((npm-name (package-revision-name package)) + (version (semver->string (package-revision-version package))) + (name (npm-name->name npm-name))) + (name+version->symbol name version))) + +(define (npm-package->package-sexp npm-package) + "Return the `package' s-expression for an NPM-PACKAGE." + (define resolve-spec + (match-lambda + (($ <versioned-package> name version) + (resolve-package name (string->semver-range version))))) + + (if (package-revision? npm-package) + (let ((name (package-revision-name npm-package)) + (version (package-revision-version npm-package)) + (home-page (package-revision-home-page npm-package)) + (dependencies (package-revision-dependencies npm-package)) + (dev-dependencies (package-revision-dev-dependencies npm-package)) + (peer-dependencies (package-revision-peer-dependencies npm-package)) + (license (package-revision-license npm-package)) + (description (package-revision-description npm-package)) + (dist (package-revision-dist npm-package))) + (let* ((name (npm-name->name name)) + (url (dist-tarball dist)) + (home-page (if (string? home-page) + home-page + (string-append %default-page "/" (uri-encode name)))) + (synopsis description) + (resolved-deps (map resolve-spec + (append dependencies peer-dependencies))) + (peer-names (map versioned-package-name peer-dependencies)) + ;; lset-difference for treating peer-dependencies as dependencies, + ;; which leads to dependency cycles. lset-union for treating them as + ;; (ignored) dev-dependencies, which leads to broken packages. + (dev-names + (lset-union string= + (map versioned-package-name dev-dependencies) + peer-names)) + (extra-phases + (match dev-names + (() '()) + ((dev-names ...) + `((add-after 'patch-dependencies 'delete-dev-dependencies + (lambda _ + (delete-dependencies '(,@(reverse dev-names)))))))))) + (values + `(package + (name ,name) + (version ,(semver->string (package-revision-version npm-package))) + (source (origin + (method url-fetch) + (uri ,url) + (sha256 (base32 ,(hash-url url))))) + (build-system node-build-system) + (arguments + (list + #:tests? #f + #:phases + #~(modify-phases %standard-phases + (delete 'build) + ,@extra-phases))) + ,@(match dependencies + (() '()) + ((dependencies ...) + `((inputs + (list ,@(map package-revision->symbol resolved-deps)))))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,license)) + (map (match-lambda (($ <package-revision> name version) + (list name (semver->string version)))) + resolved-deps)))) + (values #f '()))) + + +;;; +;;; Interface +;;; + +(define npm-binary->guix-package + (lambda* (name #:key (version *semver-range-any*) #:allow-other-keys) + (let* ((svr (match version + ((? string?) (string->semver-range version)) + (_ version))) + (pkg (resolve-package name svr))) + (npm-package->package-sexp pkg)))) + +(define* (npm-binary-recursive-import package-name #:key version) + (recursive-import package-name + #:repo->guix-package (memoize npm-binary->guix-package) + #:version version + #:guix-name npm-name->name)) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 09a01cf315..45fed93134 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -370,6 +370,15 @@ LENGTH characters." (cons* "This" "package" (string-downcase first) rest)) (_ words))) + (new-words + (match new-words + ((rest ... last) + (reverse (cons (if (or (string-suffix? "." last) + (string-suffix? "!" last) + (string-suffix? "?" last)) + last + (string-append last ".")) + (reverse rest)))))) (cleaned (string-join (map fix-word new-words)))) ;; Use double spacing between sentences diff --git a/guix/packages.scm b/guix/packages.scm index bd72b284b1..abe89cdb07 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -429,15 +429,37 @@ from forcing GEXP-PROMISE." ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>. (fold delete %supported-systems '("mips64el-linux" "powerpc-linux" "riscv64-linux"))) -(define-inlinable (sanitize-inputs inputs) - "Sanitize INPUTS by turning it into a list of name/package tuples if it's -not already the case." - (cond ((null? inputs) inputs) +(define (maybe-add-input-labels inputs) + "Add labels to INPUTS unless it already has them." + (cond ((null? inputs) + inputs) ((and (pair? (car inputs)) (string? (caar inputs))) inputs) (else (map add-input-label inputs)))) +(define (add-input-labels . inputs) + "Add labels to all of INPUTS if needed (this is the rest-argument version of +'maybe-add-input-labels')." + (maybe-add-input-labels inputs)) + +(define-syntax sanitize-inputs + ;; This is written as a macro rather than as a 'define-inlinable' procedure + ;; because as of Guile 3.0.9, peval can handle (null? '()) but not + ;; (null? (list x y z)); that residual 'null?' test contributes to code + ;; bloat. + (syntax-rules (quote list) + "Sanitize INPUTS by turning it into a list of name/package tuples if it's +not already the case." + ((_ '()) '()) + ((_ (list args ...)) + ;; As of 3.0.9, (list ...) is open-coded, which can lead to a long list + ;; of instructions. To reduce code bloat in package modules where input + ;; fields may create such lists, move list allocation to the callee. + (add-input-labels args ...)) + ((_ inputs) + (maybe-add-input-labels inputs)))) + (define-syntax current-location-vector (lambda (s) "Like 'current-source-location' but expand to a literal vector with @@ -470,7 +492,8 @@ one-indexed line numbers." (define-syntax define-public* (lambda (s) "Like 'define-public' but set 'current-definition-location' for the -lexical scope of its body." +lexical scope of its body. (This also disables notification of \"module +observers\", but this is unlikely to affect anyone.)" (define location (match (syntax-source s) (#f #f) @@ -487,10 +510,21 @@ lexical scope of its body." (syntax-case s () ((_ prototype body ...) - #`(define-public prototype - (syntax-parameterize ((current-definition-location - (lambda (s) #,location))) - body ...)))))) + (with-syntax ((name (syntax-case #'prototype () + ((id _ ...) #'id) + (id #'id)))) + #`(begin + (define prototype + (syntax-parameterize ((current-definition-location + (lambda (s) #,location))) + body ...)) + + ;; Note: Use 'module-export!' directly to avoid emitting a + ;; 'call-with-deferred-observers' call for each 'define-public*' + ;; instance, which is not only pointless but also contributes to + ;; code bloat and to load-time overhead in package modules. + (eval-when (expand load eval) + (module-export! (current-module) '(name))))))))) (define-syntax validate-texinfo (let ((validate? (getenv "GUIX_UNINSTALLED"))) diff --git a/guix/profiles.scm b/guix/profiles.scm index d41802422b..864ed02b6d 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2016, 2017, 2018, 2019, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> -;;; Copyright © 2017, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2017, 2021, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org> @@ -1487,11 +1487,14 @@ This is meant to be used as a profile hook." (define guile-zlib (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define guile-zstd + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zstd)) + (define build (with-imported-modules (source-module-closure '((guix build utils) (gnu build linux-modules))) - (with-extensions (list guile-zlib) + (with-extensions (list guile-zlib guile-zstd) #~(begin (use-modules (ice-9 ftw) (ice-9 match) diff --git a/guix/records.scm b/guix/records.scm index f4d12a861d..dca1e3c2e7 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -61,6 +61,11 @@ (string-append "% " (symbol->string type-name) " abi-cookie"))))) + (define (record-abi-mismatch-error type) + (throw 'record-abi-mismatch-error 'abi-check + "~a: record ABI mismatch; recompilation needed" + (list type) '())) + (define (abi-check type cookie) "Return syntax that checks that the current \"application binary interface\" (ABI) for TYPE is equal to COOKIE." @@ -68,9 +73,7 @@ interface\" (ABI) for TYPE is equal to COOKIE." #`(unless (eq? current-abi #,cookie) ;; The source file where this exception is thrown must be ;; recompiled. - (throw 'record-abi-mismatch-error 'abi-check - "~a: record ABI mismatch; recompilation needed" - (list #,type) '())))) + (record-abi-mismatch-error #,type)))) (define* (report-invalid-field-specifier name bindings #:optional parent-form) @@ -161,16 +164,16 @@ of TYPE matches the expansion-time ABI." (record-error 'name s "extraneous field initializers ~a" unexpected))) - #`(make-struct/no-tail type - #,@(map (lambda (field index) - (or (field-inherited-value field) - (if (innate-field? field) - (wrap-field-value - field (field-default-value field)) - #`(struct-ref #,orig-record - #,index)))) - '(expected ...) - (iota (length '(expected ...)))))) + #`(ctor #,abi-cookie + #,@(map (lambda (field index) + (or (field-inherited-value field) + (if (innate-field? field) + (wrap-field-value + field (field-default-value field)) + #`(struct-ref #,orig-record + #,index)))) + '(expected ...) + (iota (length '(expected ...)))))) (define (thunked-field? f) (memq (syntax->datum f) 'thunked)) @@ -246,8 +249,8 @@ of TYPE matches the expansion-time ABI." (cond ((lset= eq? fields '(expected ...)) #`(let* #,(field-bindings #'((field value) (... ...))) - #,(abi-check #'type abi-cookie) - (ctor #,@(map field-value '(expected ...))))) + (ctor #,abi-cookie + #,@(map field-value '(expected ...))))) ((pair? (lset-difference eq? fields '(expected ...))) (record-error 'name s @@ -432,7 +435,13 @@ inherited." (sanitizers (filter-map field-sanitizer #'((field properties ...) ...))) (cookie (compute-abi-cookie field-spec))) - (with-syntax (((field-spec* ...) + (with-syntax ((ctor-procedure + (datum->syntax + #'ctor + (symbol-append (string->symbol " %") + (syntax->datum #'ctor) + '-procedure/abi-check))) + ((field-spec* ...) (map field-spec->srfi-9 field-spec)) ((field-type ...) (map (match-lambda @@ -499,7 +508,20 @@ of a record instantiation" #'id))))))) thunked-field-accessor ... delayed-field-accessor ... - (make-syntactic-constructor type syntactic-ctor ctor + + (define ctor-procedure + ;; This procedure is *not* inlined, to reduce code bloat + ;; (struct initialization takes at least one instruction per + ;; field). + (case-lambda + ((cookie field ...) + (unless (eq? cookie #,cookie) + (record-abi-mismatch-error type)) + (ctor field ...)) + (_ + (record-abi-mismatch-error type)))) + + (make-syntactic-constructor type syntactic-ctor ctor-procedure (field ...) #:abi-cookie #,cookie #:thunked #,thunked diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1d7a6e198d..a219b2ac89 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com> ;;; @@ -812,7 +812,7 @@ WHILE-LIST." (passwd:gecos pwd))) (uid uid) (gid gid) (shell bash) (directory (if (or user (not pwd)) - (string-append "/home/" user) + (string-append "/home/" name) (passwd:dir pwd)))))) (groups (list (group-entry (name "users") (gid gid)) (group-entry (gid 65534) ;the overflow GID diff --git a/guix/scripts/git/authenticate.scm b/guix/scripts/git/authenticate.scm index def4879e96..e3ecb67c89 100644 --- a/guix/scripts/git/authenticate.scm +++ b/guix/scripts/git/authenticate.scm @@ -31,6 +31,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (guix-git-authenticate)) @@ -73,8 +74,125 @@ (alist-cons 'show-stats? #t result))))) (define %default-options - '((directory . ".") - (keyring-reference . "keyring"))) + '()) + +(define (current-branch repository) + "Return the name of the checked out branch of REPOSITORY or #f if it could +not be determined." + (and (not (repository-head-detached? repository)) + (let* ((head (repository-head repository)) + (name (reference-name head))) + (and (string-prefix? "refs/heads/" name) + (string-drop name (string-length "refs/heads/")))))) + +(define (config-value repository key) + "Return the config value associated with KEY in the 'guix.authentication' or +'guix.authentication-BRANCH' name space in REPOSITORY, or #f if no such config +was found." + (let-syntax ((false-if-git-error + (syntax-rules () + ((_ exp) + (catch 'git-error (lambda () exp) (const #f)))))) + (let* ((config (repository-config repository)) + (branch (current-branch repository))) + ;; First try the BRANCH-specific value, then the generic one.` + (or (and branch + (false-if-git-error + (config-entry-value + (config-get-entry config + (string-append "guix.authentication-" + branch "." key))))) + (false-if-git-error + (config-entry-value + (config-get-entry config + (string-append "guix.authentication." + key)))))))) + +(define (configured-introduction repository) + "Return two values: the commit and signer fingerprint (strings) as +configured in REPOSITORY. Error out if one or both were missing." + (let* ((commit (config-value repository "introduction-commit")) + (signer (config-value repository "introduction-signer"))) + (unless (and commit signer) + (leave (G_ "unknown introductory commit and signer~%"))) + (values commit signer))) + +(define (configured-keyring-reference repository) + "Return the keyring reference configured in REPOSITORY or #f if missing." + (config-value repository "keyring")) + +(define (configured? repository) + "Return true if REPOSITORY already container introduction info in its +'config' file." + (and (config-value repository "introduction-commit") + (config-value repository "introduction-signer"))) + +(define* (record-configuration repository + #:key commit signer keyring-reference) + "Record COMMIT, SIGNER, and KEYRING-REFERENCE in the 'config' file of +REPOSITORY." + (define config + (repository-config repository)) + + ;; Guile-Git < 0.7.0 lacks 'set-config-string'. + (if (module-defined? (resolve-interface '(git)) 'set-config-string) + (begin + (set-config-string config "guix.authentication.introduction-commit" + commit) + (set-config-string config "guix.authentication.introduction-signer" + signer) + (set-config-string config "guix.authentication.keyring" + keyring-reference) + (info (G_ "introduction and keyring recorded \ +in repository configuration file~%"))) + (warning (G_ "could not record introduction and keyring configuration\ + (Guile-Git too old?)~%")))) + +(define (install-hooks repository) + "Attempt to install in REPOSITORY hooks that invoke 'guix git authenticate'. +Bail out if one of these already exists." + ;; Guile-Git < 0.7.0 lacks 'repository-common-directory'. + (if (module-defined? (resolve-interface '(git)) + 'repository-common-directory) + (let () + (define directory + (repository-common-directory repository)) + + (define pre-push-hook + (in-vicinity directory "hooks/pre-push")) + + (define post-merge-hook + (in-vicinity directory "hooks/post-merge")) + + (if (or (file-exists? pre-push-hook) + (file-exists? post-merge-hook)) + (begin + (warning (G_ "not overriding pre-existing hooks '~a' and '~a'~%") + pre-push-hook post-merge-hook) + (display-hint (G_ "Consider running @command{guix git authenticate} +from your pre-push and post-merge hooks so your repository is automatically +authenticated before you push and when you pull updates."))) + (begin + (call-with-output-file pre-push-hook + (lambda (port) + (format port "#!/bin/sh +# Installed by 'guix git authenticate'. +set -e +while read local_ref local_oid remote_ref remote_oid +do + guix git authenticate --end=\"$local_oid\" +done\n") + (chmod port #o755))) + (call-with-output-file post-merge-hook + (lambda (port) + (format port "#!/bin/sh +# Installed by 'guix git authenticate'. +exec guix git authenticate\n") + (chmod port #o755))) + (info (G_ "installed hooks '~a' and '~a'~%") + pre-push-hook post-merge-hook)))) + (warning (G_ "cannot determine where to install hooks\ + (Guile-Git too old?)~%")))) (define (show-stats stats) "Display STATS, an alist containing commit signing stats as returned by @@ -158,35 +276,52 @@ commits)...~%") (progress-reporter/bar (length commits)) progress-reporter/silent)) + (define (missing-arguments) + (leave (G_ "wrong number of arguments; \ +expected COMMIT and SIGNER~%"))) + (with-error-handling (with-git-error-handling - (match (command-line-arguments options) - ((commit signer) - (let* ((directory (assoc-ref options 'directory)) - (show-stats? (assoc-ref options 'show-stats?)) - (keyring (assoc-ref options 'keyring-reference)) - (repository (repository-open directory)) - (end (match (assoc-ref options 'end-commit) - (#f (reference-target - (repository-head repository))) - (oid oid))) - (history (match (assoc-ref options 'historical-authorizations) - (#f '()) - (file (call-with-input-file file - read-authorizations)))) - (cache-key (or (assoc-ref options 'cache-key) - (repository-cache-key repository)))) - (define stats - (authenticate-repository repository (string->oid commit) - (openpgp-fingerprint* signer) - #:end end - #:keyring-reference keyring - #:historical-authorizations history - #:cache-key cache-key - #:make-reporter make-reporter)) - - (when (and show-stats? (not (null? stats))) - (show-stats stats)))) - (_ - (leave (G_ "wrong number of arguments; \ -expected COMMIT and SIGNER~%"))))))) + (let* ((show-stats? (assoc-ref options 'show-stats?)) + (repository (repository-open (or (assoc-ref options 'directory) + (repository-discover ".")))) + (commit signer (match (command-line-arguments options) + ((commit signer) + (values commit signer)) + (() + (configured-introduction repository)) + (_ + (missing-arguments)))) + (keyring (or (assoc-ref options 'keyring-reference) + (configured-keyring-reference repository) + "keyring")) + (end (match (assoc-ref options 'end-commit) + (#f (reference-target + (repository-head repository))) + (oid oid))) + (history (match (assoc-ref options 'historical-authorizations) + (#f '()) + (file (call-with-input-file file + read-authorizations)))) + (cache-key (or (assoc-ref options 'cache-key) + (repository-cache-key repository)))) + (define stats + (authenticate-repository repository (string->oid commit) + (openpgp-fingerprint* signer) + #:end end + #:keyring-reference keyring + #:historical-authorizations history + #:cache-key cache-key + #:make-reporter make-reporter)) + + (unless (configured? repository) + (record-configuration repository + #:commit commit #:signer signer + #:keyring-reference keyring) + (install-hooks repository)) + + (when (and show-stats? (not (null? stats))) + (show-stats stats)) + + (info (G_ "successfully authenticated commit ~a~%") + (oid->string end)))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 1f34cab088..d724f2bca3 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -49,7 +49,7 @@ (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" "gem" "go" "cran" "crate" "texlive" "json" "opam" - "minetest" "elm" "hexpm" "composer")) + "minetest" "elm" "hexpm" "composer" "npm-binary")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/npm-binary.scm b/guix/scripts/import/npm-binary.scm new file mode 100644 index 0000000000..b2771bc539 --- /dev/null +++ b/guix/scripts/import/npm-binary.scm @@ -0,0 +1,121 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Timothy Sample <samplet@ngyro.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 npm-binary) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import npm-binary) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-npm-binary)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import npm-binary PACKAGE-NAME [VERSION] +Import and convert the npm package PACKAGE-NAME using the +`node-build-system' (but without building the package from source).")) + (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 npm-binary"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + +(define* (package-name->name+version* spec) + "Given SPEC, a package name like \"@scope/pac@^0.9.1\", return two values: +\"@scope/pac\" and \"^0.9.1\". When the version part is unavailable, SPEC and \"*\" +are returned. The first part may start with '@', the latter part must not contain +contain '@'." + (match (string-rindex spec #\@) + (#f (values spec "*")) + (0 (values spec "*")) + (idx (values (substring spec 0 idx) + (substring spec (1+ idx)))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-npm-binary . 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) + (define-values (package-name version) + (package-name->name+version* spec)) + (match (if (assoc-ref opts 'recursive) + ;; Recursive import + (npm-binary-recursive-import package-name #:version version) + ;; Single import + (npm-binary->guix-package package-name #:version version)) + ((or #f '()) + (leave (G_ "failed to download meta-data for package '~a@~a'~%") + package-name version)) + (('package etc ...) `(package ,@etc)) + ((? list? sexps) + (map (match-lambda + ((and ('package ('name name) ('version version) . rest) pkg) + `(define-public ,(name+version->symbol name version) + ,pkg)) + (_ #f)) + sexps)))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 211980dc1c..0727ac1480 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -304,7 +304,7 @@ counterpart." value)) (('unquote-splicing x) (if (= quotation 1) - `(ungexp-splicing x) + `(ungexp-splicing ,x) value)) (('quasiquote x) (list 'quasiquote (loop x (+ quotation 1)))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index a7ad56dbcd..8bcbca5e7a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -77,7 +77,7 @@ (define %narinfo-expired-cache-entry-removal-delay ;; How often we want to remove files corresponding to expired cache entries. - (* 7 24 3600)) + (* 5 24 3600)) (define (warn-about-missing-authentication) (warning (G_ "authentication and authorization of substitutes \ @@ -169,8 +169,9 @@ was found." "Return the expiration time for FILE, which is a cached narinfo." (define max-ttl ;; Upper bound on the TTL used to avoid keeping around cached narinfos for - ;; too long, which makes the cache bigger and more expensive to traverse. - (* 2 30 24 60 60)) ;2 months + ;; too long, which makes the cache bigger and more expensive to traverse + ;; when deleting old entries. + (* 2 24 60 60)) (catch 'system-error (lambda () diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 2260bcf985..99c58f3812 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -591,7 +591,8 @@ any, are available. Raise an error if they're not." (not (member (file-system-type fs) %pseudo-file-system-types)) ;; Don't try to validate network file systems. - (not (string-prefix? "nfs" (file-system-type fs))) + (not (or (string-prefix? "nfs" (file-system-type fs)) + (string-prefix? "cifs" (file-system-type fs)))) (not (memq 'bind-mount (file-system-flags fs))))) file-systems)) diff --git a/guix/self.scm b/guix/self.scm index 19c6d08e01..a94791d67b 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2024 gemmaro <gemmaro.dev@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -71,7 +72,7 @@ ("bzip2" . ,(ref 'compression 'bzip2)) ("xz" . ,(ref 'compression 'xz)) ("git-minimal" . ,(ref 'version-control 'git-minimal)) - ("po4a" . ,(ref 'gettext 'po4a)) + ("po4a-minimal" . ,(ref 'gettext 'po4a-minimal)) ("gettext-minimal" . ,(ref 'gettext 'gettext-minimal)) ("gcc-toolchain" . ,(ref 'commencement 'gcc-toolchain)) ("glibc-utf8-locales" . ,(delay @@ -291,8 +292,8 @@ DOMAIN, a gettext domain." (define (translate-texi-manuals source) "Return the translated texinfo manuals built from SOURCE." - (define po4a - (specification->package "po4a")) + (define po4a-minimal + (specification->package "po4a-minimal")) (define gettext-minimal (specification->package "gettext-minimal")) @@ -317,9 +318,15 @@ DOMAIN, a gettext domain." (define (translate-tmp-texi po source output) "Translate Texinfo file SOURCE using messages from PO, and write the result to OUTPUT." - (invoke #+(file-append po4a "/bin/po4a-translate") - "-M" "UTF-8" "-L" "UTF-8" "-k" "0" "-f" "texinfo" - "-m" source "-p" po "-l" output)) + (invoke #+(file-append po4a-minimal "/bin/po4a") + "--no-update" + "--variable" (string-append "localized=" output) + "--variable" (string-append "master=" source) + "--variable" (string-append "po=" po) + "--variable" (string-append "pot=" (string-append (tmpnam) ".pot")) + (string-append "--srcdir=" #$source) + "--destdir=." + #+(file-append documentation-po "/po4a.cfg"))) (define (canonicalize-whitespace str) ;; Change whitespace (newlines, etc.) in STR to #\space. diff --git a/guix/store.scm b/guix/store.scm index a238cb627a..58ddaa8d15 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -106,6 +106,7 @@ port->connection close-connection with-store + with-store/non-blocking set-build-options set-build-options* valid-path? @@ -462,12 +463,17 @@ (file file) (errno errno)))))))) -(define (open-unix-domain-socket file) +(define* (open-unix-domain-socket file #:key non-blocking?) "Connect to the Unix-domain socket at FILE and return it. Raise a -'&store-connection-error' upon error." +'&store-connection-error' upon error. If NON-BLOCKING?, make the socket +non-blocking." (let ((s (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. - (socket PF_UNIX (logior SOCK_STREAM SOCK_CLOEXEC) 0))) + (socket PF_UNIX + (if non-blocking? + (logior SOCK_STREAM SOCK_CLOEXEC SOCK_NONBLOCK) + (logior SOCK_STREAM SOCK_CLOEXEC)) + 0))) (a (make-socket-address PF_UNIX file))) (system-error-to-connection-error file @@ -478,9 +484,10 @@ ;; Default port when connecting to a daemon over TCP/IP. 44146) -(define (open-inet-socket host port) +(define* (open-inet-socket host port #:key non-blocking?) "Connect to the Unix-domain socket at HOST:PORT and return it. Raise a -'&store-connection-error' upon error." +'&store-connection-error' upon error. If NON-BLOCKING?, make the socket +non-blocking." (define addresses (getaddrinfo host (if (number? port) (number->string port) port) @@ -495,7 +502,10 @@ ((ai rest ...) (let ((s (socket (addrinfo:fam ai) ;; TCP/IP only - (logior SOCK_STREAM SOCK_CLOEXEC) IPPROTO_IP))) + (if non-blocking? + (logior SOCK_STREAM SOCK_CLOEXEC SOCK_NONBLOCK) + (logior SOCK_STREAM SOCK_CLOEXEC)) + IPPROTO_IP))) (catch 'system-error (lambda () @@ -514,9 +524,10 @@ (errno (system-error-errno args))))) (loop rest))))))))) -(define (connect-to-daemon uri) +(define* (connect-to-daemon uri #:key non-blocking?) "Connect to the daemon at URI, a string that may be an actual URI or a file -name, and return an input/output port. +name, and return an input/output port. If NON-BLOCKING?, use a non-blocking +socket when using the file, unix or guix URI schemes. This is a low-level procedure that does not perform the initial handshake with the daemon. Use 'open-connection' for that." @@ -533,11 +544,13 @@ the daemon. Use 'open-connection' for that." (match (uri-scheme uri) ((or #f 'file 'unix) (lambda (_) - (open-unix-domain-socket (uri-path uri)))) + (open-unix-domain-socket (uri-path uri) + #:non-blocking? non-blocking?))) ('guix (lambda (_) (open-inet-socket (uri-host uri) - (or (uri-port uri) %default-guix-port)))) + (or (uri-port uri) %default-guix-port) + #:non-blocking? non-blocking?))) ((? symbol? scheme) ;; Try to dynamically load a module for SCHEME. ;; XXX: Errors are swallowed. @@ -557,7 +570,8 @@ the daemon. Use 'open-connection' for that." (connect uri)) (define* (open-connection #:optional (uri (%daemon-socket-uri)) - #:key port (reserve-space? #t) cpu-affinity) + #:key port (reserve-space? #t) cpu-affinity + non-blocking?) "Connect to the daemon at URI (a string), or, if PORT is not #f, use it as the I/O port over which to communicate to a build daemon. @@ -565,7 +579,9 @@ When RESERVE-SPACE? is true, instruct it to reserve a little bit of extra space on the file system so that the garbage collector can still operate, should the disk become full. When CPU-AFFINITY is true, it must be an integer corresponding to an OS-level CPU number to which the daemon's worker process -for this connection will be pinned. Return a server object." +for this connection will be pinned. If NON-BLOCKING?, use a non-blocking +socket when using the file, unix or guix URI schemes. Return a server +object." (define (handshake-error) (raise (condition (&store-connection-error (file (or port uri)) @@ -577,7 +593,8 @@ for this connection will be pinned. Return a server object." ;; really a connection error. (handshake-error))) (let*-values (((port) - (or port (connect-to-daemon uri))) + (or port (connect-to-daemon + uri #:non-blocking? non-blocking?))) ((output flush) (buffering-output-port port (make-bytevector 8192)))) @@ -657,9 +674,10 @@ connection. Use with care." "Close the connection to SERVER." (close (store-connection-socket server))) -(define (call-with-store proc) - "Call PROC with an open store connection." - (let ((store (open-connection))) +(define* (call-with-store proc #:key non-blocking?) + "Call PROC with an open store connection. Pass NON-BLOCKING? to +open-connection." + (let ((store (open-connection #:non-blocking? non-blocking?))) (define (thunk) (parameterize ((current-store-protocol-version (store-connection-version store))) @@ -678,6 +696,11 @@ connection. Use with care." automatically close the store when the dynamic extent of EXP is left." (call-with-store (lambda (store) exp ...))) +(define-syntax-rule (with-store/non-blocking store exp ...) + "Bind STORE to an non-blocking open connection to the store and evaluate +EXPs; automatically close the store when the dynamic extent of EXP is left." + (call-with-store (lambda (store) exp ...) #:non-blocking? #t)) + (define current-store-protocol-version ;; Protocol version of the store currently used. XXX: This is a hack to ;; communicate the protocol version to the build output port. It's a hack diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 129574c073..2005653c95 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> -;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2022, 2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +28,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (guix serialization) @@ -206,6 +207,48 @@ under STORE." #f) (else (apply throw args))))))))))) +(define (hole-size bv start size) + "Return a lower bound of the number of leading zeros in the first SIZE bytes +of BV, starting at offset START." + (let ((end (+ start size))) + (let loop ((offset start)) + (if (> offset (- end 4)) + (- offset start) + (if (zero? (bytevector-u32-native-ref bv offset)) + (loop (+ offset 4)) + (- offset start)))))) + +(define (find-holes bv start size) + "Return the list of offset/size pairs representing \"holes\" (sequences of +zeros) in the SIZE bytes starting at START in BV." + (define granularity + ;; Disk block size is traditionally 512 bytes; focus on larger holes to + ;; reduce the computational effort. + 1024) + + (define (align offset) + (match (modulo offset granularity) + (0 offset) + (mod (+ offset (- granularity mod))))) + + (define end + (+ start size)) + + (let loop ((offset start) + (size size) + (holes '())) + (if (>= offset end) + (reverse! holes) + (let ((hole (hole-size bv offset size))) + (if (and hole (>= hole granularity)) + (let ((next (align (+ offset hole)))) + (loop next + (- size (- next offset)) + (cons (cons offset hole) holes))) + (loop (+ offset granularity) + (- size granularity) + holes)))))) + (define (tee input len output) "Return a port that reads up to LEN bytes from INPUT and writes them to OUTPUT as it goes." @@ -217,6 +260,10 @@ OUTPUT as it goes." (&nar-error (port input) (file (port-filename output)))))) + (define seekable? + ;; Whether OUTPUT can be a sparse file. + (file-port? output)) + (define (read! bv start count) ;; Read at most LEN bytes in total. (let ((count (min count (- len bytes-read)))) @@ -229,7 +276,35 @@ OUTPUT as it goes." ;; Do not return zero since zero means EOF, so try again. (loop (get-bytevector-n! input bv start count))) (else - (put-bytevector output bv start ret) + (if seekable? + ;; Render long-enough sequences of zeros as "holes". + (match (find-holes bv start ret) + (() + (put-bytevector output bv start ret)) + (holes + (let loop ((offset start) + (size ret) + (holes holes)) + (match holes + (() + (if (> size 0) + (put-bytevector output bv offset size) + (when (= len (+ bytes-read ret)) + ;; We created a hole in OUTPUT by seeking + ;; forward but that hole only comes into + ;; existence if we write something after it. + ;; Make the hole one byte smaller and write a + ;; final zero. + (seek output -1 SEEK_CUR) + (put-u8 output 0)))) + (((hole-start . hole-size) . rest) + (let ((prefix-len (- hole-start offset))) + (put-bytevector output bv offset prefix-len) + (seek output hole-size SEEK_CUR) + (loop (+ hole-start hole-size) + (- size prefix-len hole-size) + rest))))))) + (put-bytevector output bv start ret)) (set! bytes-read (+ bytes-read ret)) ret))))) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 17a7f4f957..62649e4374 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -30,6 +30,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (rnrs bytevectors) #:export (svn-reference svn-reference? svn-reference-url @@ -73,14 +74,7 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'subversion))) -(define* (svn-fetch ref hash-algo hash - #:optional name - #:key (system (%current-system)) (guile (default-guile)) - (svn (subversion-package))) - "Return a fixed-output derivation that fetches REF, a <svn-reference> -object. The output is expected to have recursive hash HASH of type -HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." - +(define (svn-fetch-builder svn hash-algo) (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) @@ -90,46 +84,70 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define guile-gnutls (module-ref (resolve-interface '(gnu packages tls)) 'guile-gnutls)) - (define build - (with-imported-modules - (source-module-closure '((guix build svn) - (guix build download) - (guix build download-nar) - (guix build utils) - (guix swh))) - (with-extensions (list guile-json guile-gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build svn) - ((guix build download) - #:select (download-method-enabled?)) - (guix build download-nar) - (guix swh) - (ice-9 match)) + (define tar+gzip ;for (guix swh) + (list (module-ref (resolve-interface '(gnu packages compression)) + 'gzip) + (module-ref (resolve-interface '(gnu packages base)) + 'tar))) - (or (and (download-method-enabled? 'upstream) - (svn-fetch (getenv "svn url") - (string->number (getenv "svn revision")) - #$output - #:svn-command #+(file-append svn "/bin/svn") - #:recursive? (match (getenv "svn recursive?") - ("yes" #t) - (_ #f)) - #:user-name (getenv "svn user name") - #:password (getenv "svn password"))) - (and (download-method-enabled? 'nar) - (download-nar #$output)) - (and (download-method-enabled? 'swh) - (parameterize ((%verify-swh-certificate? #f)) - (swh-download-directory-by-nar-hash #$hash '#$hash-algo - #$output)))))))) + (with-imported-modules + (source-module-closure '((guix build svn) + (guix build download) + (guix build download-nar) + (guix build utils) + (guix swh))) + (with-extensions (list guile-json guile-gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build svn) + ((guix build download) + #:select (download-method-enabled?)) + (guix build download-nar) + (guix build utils) + (guix swh) + (ice-9 match)) - (mlet %store-monad ((guile (package->derivation guile system))) - (gexp->derivation (or name "svn-checkout") build + ;; Add tar and gzip to $PATH so + ;; 'swh-download-directory-by-nar-hash' can invoke them. + (set-path-environment-variable "PATH" '("bin") '(#+@tar+gzip)) - ;; Use environment variables and a fixed script name so - ;; there's only one script in store for all the - ;; downloads. + (or (and (download-method-enabled? 'upstream) + (svn-fetch (getenv "svn url") + (string->number (getenv "svn revision")) + #$output + #:svn-command #+(file-append svn "/bin/svn") + #:recursive? (match (getenv "svn recursive?") + ("yes" #t) + (_ #f)) + #:user-name (getenv "svn user name") + #:password (getenv "svn password"))) + (and (download-method-enabled? 'nar) + (download-nar #$output)) + (and (download-method-enabled? 'swh) + (parameterize ((%verify-swh-certificate? #f)) + (swh-download-directory-by-nar-hash + (u8-list->bytevector + (map string->number + (string-split (getenv "hash") #\,))) + '#$hash-algo + #$output)))))))) + +(define* (svn-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile)) + (svn (subversion-package))) + "Return a fixed-output derivation that fetches REF, a <svn-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation (or name "svn-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (svn-fetch-builder svn hash-algo) #:script-name "svn-download" #:env-vars `(("svn url" . ,(svn-reference-url ref)) @@ -149,7 +167,14 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ,@(match (getenv "GUIX_DOWNLOAD_METHODS") (#f '()) (value - `(("GUIX_DOWNLOAD_METHODS" . ,value))))) + `(("GUIX_DOWNLOAD_METHODS" . ,value)))) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ","))) #:system system #:hash-algo hash-algo @@ -168,14 +193,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (user-name svn-multi-reference-user-name (default #f)) (password svn-multi-reference-password (default #f))) -(define* (svn-multi-fetch ref hash-algo hash - #:optional name - #:key (system (%current-system)) (guile (default-guile)) - (svn (subversion-package))) - "Return a fixed-output derivation that fetches REF, a <svn-multi-reference> -object. The output is expected to have recursive hash HASH of type -HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." - +(define (svn-multi-fetch-builder svn hash-algo) (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) @@ -185,65 +203,89 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define guile-gnutls (module-ref (resolve-interface '(gnu packages tls)) 'guile-gnutls)) - (define build - (with-imported-modules - (source-module-closure '((guix build svn) - (guix build download) - (guix build download-nar) - (guix build utils) - (guix swh))) - (with-extensions (list guile-json guile-gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build svn) - (guix build utils) - ((guix build download) - #:select (download-method-enabled?)) - (guix build download-nar) - (guix swh) - (srfi srfi-1) - (ice-9 match)) + (define tar+gzip ;for (guix swh) + (list (module-ref (resolve-interface '(gnu packages compression)) + 'gzip) + (module-ref (resolve-interface '(gnu packages base)) + 'tar))) - (or (every - (lambda (location) - ;; The directory must exist if we are to fetch only a - ;; single file. - (unless (string-suffix? "/" location) - (mkdir-p (string-append #$output "/" (dirname location)))) - (and (download-method-enabled? 'upstream) - (svn-fetch (string-append (getenv "svn url") "/" location) - (string->number (getenv "svn revision")) - (if (string-suffix? "/" location) - (string-append #$output "/" location) - (string-append #$output "/" (dirname location))) - #:svn-command #+(file-append svn "/bin/svn") - #:recursive? (match (getenv "svn recursive?") - ("yes" #t) - (_ #f)) - #:user-name (getenv "svn user name") - #:password (getenv "svn password")))) - (call-with-input-string (getenv "svn locations") - read)) - (begin - (when (file-exists? #$output) - (delete-file-recursively #$output)) - (or (and (download-method-enabled? 'nar) - (download-nar #$output)) - (and (download-method-enabled? 'swh) - ;; SWH keeps HASH as an ExtID for the combination - ;; of files/directories, which allows us to - ;; retrieve the entire combination at once: - ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>. - (parameterize ((%verify-swh-certificate? #f)) - (swh-download-directory-by-nar-hash - #$hash '#$hash-algo #$output)))))))))) + (with-imported-modules + (source-module-closure '((guix build svn) + (guix build download) + (guix build download-nar) + (guix build utils) + (guix swh))) + (with-extensions (list guile-json guile-gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build svn) + (guix build utils) + ((guix build download) + #:select (download-method-enabled?)) + (guix build download-nar) + (guix swh) + (srfi srfi-1) + (ice-9 match) + (rnrs bytevectors)) - (mlet %store-monad ((guile (package->derivation guile system))) - (gexp->derivation (or name "svn-checkout") build + ;; Add tar and gzip to $PATH so + ;; 'swh-download-directory-by-nar-hash' can invoke them. + (set-path-environment-variable "PATH" '("bin") '(#+@tar+gzip)) - ;; Use environment variables and a fixed script name so - ;; there's only one script in store for all the - ;; downloads. + (or (every + (lambda (location) + ;; The directory must exist if we are to fetch only a + ;; single file. + (unless (string-suffix? "/" location) + (mkdir-p (string-append #$output "/" (dirname location)))) + (and (download-method-enabled? 'upstream) + (svn-fetch (string-append (getenv "svn url") "/" location) + (string->number (getenv "svn revision")) + (if (string-suffix? "/" location) + (string-append #$output "/" location) + (string-append #$output "/" (dirname location))) + #:svn-command #+(file-append svn "/bin/svn") + #:recursive? (match (getenv "svn recursive?") + ("yes" #t) + (_ #f)) + #:user-name (getenv "svn user name") + #:password (getenv "svn password")))) + (call-with-input-string (getenv "svn locations") + read)) + (begin + (when (file-exists? #$output) + (delete-file-recursively #$output)) + (or (and (download-method-enabled? 'nar) + (download-nar #$output)) + (and (download-method-enabled? 'swh) + ;; SWH keeps HASH as an ExtID for the combination + ;; of files/directories, which allows us to + ;; retrieve the entire combination at once: + ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>. + (parameterize ((%verify-swh-certificate? #f)) + (swh-download-directory-by-nar-hash + (u8-list->bytevector + (map string->number + (string-split (getenv "hash") #\,))) + '#$hash-algo + #$output)))))))))) + +(define* (svn-multi-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile)) + (svn (subversion-package))) + "Return a fixed-output derivation that fetches REF, a <svn-multi-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation (or name "svn-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (svn-multi-fetch-builder svn hash-algo) #:script-name "svn-multi-download" #:env-vars `(("svn url" . ,(svn-multi-reference-url ref)) @@ -265,7 +307,14 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ,@(match (getenv "GUIX_DOWNLOAD_METHODS") (#f '()) (value - `(("GUIX_DOWNLOAD_METHODS" . ,value))))) + `(("GUIX_DOWNLOAD_METHODS" . ,value)))) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ","))) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" diff --git a/guix/transformations.scm b/guix/transformations.scm index f02b9f94d6..582f8a2729 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -504,8 +504,12 @@ actual compiler." (list "-C" (string-append "target_cpu=" #$micro-architecture))) (else - (list (string-append "-march=" - #$micro-architecture)))))))))))) + (list + ;; Some architectures take '-mcpu' and not '-march'. + (if (string-prefix? "power" #$micro-architecture) + (string-append "-mcpu=" #$micro-architecture) + (string-append "-march=" + #$micro-architecture))))))))))))) (define program (program-file (string-append "tuning-compiler-wrapper-" micro-architecture) |