diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/go.scm | 67 | ||||
-rw-r--r-- | guix/build/debug-link.scm | 8 | ||||
-rw-r--r-- | guix/download.scm | 17 | ||||
-rw-r--r-- | guix/gnu-maintenance.scm | 72 | ||||
-rw-r--r-- | guix/import/cran.scm | 66 | ||||
-rw-r--r-- | guix/lint.scm | 26 | ||||
-rw-r--r-- | guix/narinfo.scm | 5 | ||||
-rw-r--r-- | guix/platforms/x86.scm | 4 | ||||
-rw-r--r-- | guix/read-print.scm | 10 | ||||
-rw-r--r-- | guix/scripts/home/import.scm | 21 | ||||
-rw-r--r-- | guix/scripts/pack.scm | 46 | ||||
-rw-r--r-- | guix/scripts/weather.scm | 10 |
12 files changed, 163 insertions, 189 deletions
diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 5e0e5bbad3..4b3b67b08f 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -240,45 +240,46 @@ commit hash and its date rather than a proper release tag." (substitutable? #t)) "Cross-build NAME using GO, where TARGET is a GNU triplet and with INPUTS." (define builder - #~(begin - (use-modules #$@(sexp->gexp modules)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (define %build-host-inputs - #+(input-tuples->gexp build-inputs)) + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) - (define %build-target-inputs - (append #$(input-tuples->gexp host-inputs) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) #+(input-tuples->gexp target-inputs))) - (define %build-inputs - (append %build-host-inputs %build-target-inputs)) + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) - (define %outputs - #$(outputs->gexp outputs)) + (define %outputs + #$(outputs->gexp outputs)) - (go-build #:name #$name - #:source #+source - #:system #$system - #:phases #$phases - #:outputs %outputs - #:target #$target - #:goarch #$goarch - #:goos #$goos - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths '#$(map search-path-specification->sexp - search-paths) - #:native-search-paths '#$(map - search-path-specification->sexp - native-search-paths) - #:install-source? #$install-source? - #:import-path #$import-path - #:unpack-path #$unpack-path - #:build-flags #$build-flags - #:tests? #$tests? - #:make-dynamic-linker-cache? #f ;cross-compiling - #:allow-go-reference? #$allow-go-reference? - #:inputs %build-inputs))) + (go-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs %outputs + #:target #$target + #:goarch #$goarch + #:goos #$goos + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:native-search-paths '#$(map + search-path-specification->sexp + native-search-paths) + #:install-source? #$install-source? + #:import-path #$import-path + #:unpack-path #$unpack-path + #:build-flags #$build-flags + #:tests? #$tests? + #:make-dynamic-linker-cache? #f ;cross-compiling + #:allow-go-reference? #$allow-go-reference? + #:inputs %build-inputs)))) (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system #:graft? #f))) diff --git a/guix/build/debug-link.scm b/guix/build/debug-link.scm index 9167737fb3..f3284f74c4 100644 --- a/guix/build/debug-link.scm +++ b/guix/build/debug-link.scm @@ -38,10 +38,10 @@ ;;; create separate debug files (info "(gdb) Separate Debug Files"). ;;; ;;; The main facility of this module is 'graft-debug-links', which allows us -;;; to update the CRC that appears in '.gnu_debuglink' sections when grafting, -;;; such that separate debug files remain usable after grafting. Failing to -;;; do that, GDB would complain about CRC mismatch---see -;;; <https://bugs.gnu.org/19973>. +;;; to update the cyclic redundancy check (CRC) that appears in +;;; '.gnu_debuglink' sections when grafting, such that separate debug files +;;; remain usable after grafting. Failing to do that, GDB would complain +;;; about CRC mismatch---see <https://issues.guix.gnu.org/19973>. ;;; ;;; Code: diff --git a/guix/download.scm b/guix/download.scm index d459ba8cf1..29a8f99034 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -96,15 +96,15 @@ (hackage "http://hackage.haskell.org/") (savannah ; http://download0.savannah.gnu.org/mirmon/savannah/ - "http://download.savannah.gnu.org/releases/" - "http://nongnu.freemirror.org/nongnu/" - "http://ftp.cc.uoc.gr/mirrors/nongnu.org/" - "http://ftp.twaren.net/Unix/NonGNU/" - "http://mirror.csclub.uwaterloo.ca/nongnu/" - "http://nongnu.askapache.com/" - "http://savannah.c3sl.ufpr.br/" + "https://download.savannah.gnu.org/releases/" + "https://nongnu.freemirror.org/nongnu/" + "https://ftp.cc.uoc.gr/mirrors/nongnu.org/" + "http://ftp.twaren.net/Unix/NonGNU/" ; https appears unsupported + "https://mirror.csclub.uwaterloo.ca/nongnu/" + "https://nongnu.askapache.com/" + "https://savannah.c3sl.ufpr.br/" "http://download.savannah.gnu.org/releases-noredirect/" - "http://download-mirror.savannah.gnu.org/releases/" + "https://download-mirror.savannah.gnu.org/releases/" "ftp://ftp.twaren.net/Unix/NonGNU/" "ftp://mirror.csclub.uwaterloo.ca/nongnu/" "ftp://mirror.publicns.net/pub/nongnu/" @@ -138,6 +138,7 @@ "http://kernel.osuosl.org/pub/" "http://ftp.be.debian.org/pub/" "http://mirror.linux.org.au/" + "https://mirrors.edge.kernel.org/pub/" "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/") (apache ; from http://www.apache.org/mirrors/dist.html "http://www.eu.apache.org/dist/" diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 1ffa408666..f983debcd2 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -33,6 +33,8 @@ #:use-module (rnrs io ports) #:use-module (system foreign) #:use-module ((guix http-client) #:hide (open-socket-for-uri)) + ;; not required in many cases, so autoloaded to reduce start-up costs. + #:autoload (guix download) (%mirrors) #:use-module (guix ftp-client) #:use-module (guix utils) #:use-module (guix memoization) @@ -58,6 +60,8 @@ find-package gnu-package? + uri-mirror-rewrite + release-file? releases latest-release @@ -359,10 +363,12 @@ return the corresponding signature URL, or #f it signatures are unavailable." (upstream-source (package project) (version (tarball->version file)) - (urls (list url)) + ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp:// + ;; URLs during "guix refresh -u". + (urls (list (uri-mirror-rewrite url))) (signature-urls (match (file->signature url) (#f #f) - (sig (list sig))))))) + (sig (list (uri-mirror-rewrite sig)))))))) (let loop ((directory directory) (result #f)) @@ -532,9 +538,12 @@ are unavailable." (upstream-source (package package) (version version) - (urls (list url)) + ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp:// + ;; URLs during "guix refresh -u". + (urls (list (uri-mirror-rewrite url))) (signature-urls - (list ((or file->signature file->signature/guess) url)))))))) + (and=> ((or file->signature file->signature/guess) url) + (lambda (url) (list (uri-mirror-rewrite url)))))))))) (define candidates (filter-map url->release links)) @@ -651,21 +660,22 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) -(define (url-prefix-rewrite old new) - "Return a one-argument procedure that rewrites URL prefix OLD to NEW." - (lambda (url) - (if (and url (string-prefix? old url)) - (string-append new (string-drop url (string-length old))) - url))) - -(define (adjusted-upstream-source source rewrite-url) - "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them." - (upstream-source - (inherit source) - (urls (map rewrite-url (upstream-source-urls source))) - (signature-urls (and=> (upstream-source-signature-urls source) - (lambda (urls) - (map rewrite-url urls)))))) +(define (uri-mirror-rewrite uri) + "Rewrite URI to a mirror:// URI if possible, or return URI unmodified." + (if (string-prefix? "mirror://" uri) + uri ;nothing to do, it's already a mirror URI + (let loop ((mirrors %mirrors)) + (match mirrors + (() + uri) + (((mirror-id mirror-urls ...) rest ...) + (match (find (cut string-prefix? <> uri) mirror-urls) + (#f + (loop rest)) + (prefix + (format #f "mirror://~a/~a" + mirror-id + (string-drop uri (string-length prefix)))))))))) (define %savannah-base ;; One of the Savannah mirrors listed at @@ -680,15 +690,12 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ((? string? uri) uri) ((uri mirrors ...) uri)))) (package (package-upstream-name package)) - (directory (dirname (uri-path uri))) - (rewrite (url-prefix-rewrite %savannah-base - "mirror://savannah"))) + (directory (dirname (uri-path uri)))) ;; Note: We use the default 'file->signature', which adds ".sig", ".asc", ;; or whichever detached signature naming scheme PACKAGE uses. - (and=> (latest-html-release package - #:base-url %savannah-base - #:directory directory) - (cut adjusted-upstream-source <> rewrite)))) + (latest-html-release package + #:base-url %savannah-base + #:directory directory))) (define (latest-sourceforge-release package) "Return the latest release of PACKAGE." @@ -768,14 +775,11 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ((? string? uri) uri) ((uri mirrors ...) uri)))) (package (package-upstream-name package)) - (directory (dirname (uri-path uri))) - (rewrite (url-prefix-rewrite %kernel.org-base - "mirror://kernel.org"))) - (and=> (latest-html-release package - #:base-url %kernel.org-base - #:directory directory - #:file->signature file->signature) - (cut adjusted-upstream-source <> rewrite)))) + (directory (dirname (uri-path uri)))) + (latest-html-release package + #:base-url %kernel.org-base + #:directory directory + #:file->signature file->signature))) (define html-updatable-package? ;; Return true if the given package may be handled by the generic HTML diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 4e1ce7c010..d7f6945675 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -200,11 +200,11 @@ bioconductor package NAME, or #F if the package is unknown." ;; Little helper to download URLs only once. (define download (memoize - (lambda* (url #:key method) + (lambda* (url #:key method (ref '())) (with-store store (cond ((eq? method 'git) - (latest-repository-commit store url)) + (latest-repository-commit store url #:ref ref)) ((eq? method 'hg) (call-with-temporary-directory (lambda (dir) @@ -516,32 +516,32 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (package `(package (name ,(cran-guix-name name)) - (version ,(case repository - ((git) - `(git-version ,version revision commit)) - ((hg) - `(string-append ,version "-" revision "." changeset)) - (else version))) + (version ,(cond + (git? + `(git-version ,version revision commit)) + (hg? + `(string-append ,version "-" revision "." changeset)) + (else version))) (source (origin (method ,(cond (git? 'git-fetch) (hg? 'hg-fetch) (else 'url-fetch))) - (uri ,(case repository - ((git) - `(git-reference - (url ,(assoc-ref meta 'git)) - (commit commit))) - ((hg) - `(hg-reference - (url ,(assoc-ref meta 'hg)) - (changeset changeset))) - (else - `(,(procedure-name uri-helper) ,name version - ,@(or (and=> (assoc-ref meta 'bioconductor-type) - (lambda (type) - (list (list 'quote type)))) - '()))))) + (uri ,(cond + (git? + `(git-reference + (url ,(assoc-ref meta 'git)) + (commit commit))) + (hg? + `(hg-reference + (url ,(assoc-ref meta 'hg)) + (changeset changeset))) + (else + `(,(procedure-name uri-helper) ,name version + ,@(or (and=> (assoc-ref meta 'bioconductor-type) + (lambda (type) + (list (list 'quote type)))) + '()))))) ,@(cond (git? '((file-name (git-file-name name version)))) @@ -576,16 +576,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ""))) (license ,license)))) (values - (case repository - ((git) - `(let ((commit ,(assoc-ref meta 'git-commit)) - (revision "1")) - ,package)) - ((hg) - `(let ((changeset ,(assoc-ref meta 'hg-changeset)) - (revision "1")) - ,package)) - (else package)) + (cond + (git? + `(let ((commit ,(assoc-ref meta 'git-commit)) + (revision "1")) + ,package)) + (hg? + `(let ((changeset ,(assoc-ref meta 'hg-changeset)) + (revision "1")) + ,package)) + (else package)) propagate))) (define cran->guix-package diff --git a/guix/lint.scm b/guix/lint.scm index 7d6fd5ee7e..4ef3a46838 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -12,7 +12,7 @@ ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> -;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. @@ -1221,22 +1221,14 @@ descriptions maintained upstream." (define (check-mirror-url package) "Check whether PACKAGE uses source URLs that should be 'mirror://'." - (define (check-mirror-uri uri) ;XXX: could be optimized - (let loop ((mirrors %mirrors)) - (match mirrors - (() - #f) - (((mirror-id mirror-urls ...) rest ...) - (match (find (cut string-prefix? <> uri) mirror-urls) - (#f - (loop rest)) - (prefix - (make-warning package - (G_ "URL should be \ -'mirror://~a/~a'") - (list mirror-id - (string-drop uri (string-length prefix))) - #:field 'source))))))) + (define (check-mirror-uri uri) + (define rewritten-uri + (uri-mirror-rewrite uri)) + + (and (not (string=? uri rewritten-uri)) + (make-warning package (G_ "URL should be '~a'") + (list rewritten-uri) + #:field 'source))) (let ((origin (package-source package))) (if (and (origin? origin) diff --git a/guix/narinfo.scm b/guix/narinfo.scm index 4fc550aa6c..741c7ad406 100644 --- a/guix/narinfo.scm +++ b/guix/narinfo.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; @@ -209,7 +209,8 @@ No authentication and authorization checks are performed here!" (define* (valid-narinfo? narinfo #:optional (acl (current-acl)) #:key verbose?) - "Return #t if NARINFO's signature is not valid." + "Return #t if NARINFO's signature is valid and made by one of the keys in +ACL." (let ((hash (narinfo-sha256 narinfo)) (signature (narinfo-signature narinfo)) (uri (uri->string (first (narinfo-uris narinfo))))) diff --git a/guix/platforms/x86.scm b/guix/platforms/x86.scm index 5338049d6f..6f547dd770 100644 --- a/guix/platforms/x86.scm +++ b/guix/platforms/x86.scm @@ -23,7 +23,7 @@ x86_64-linux i686-mingw x86_64-mingw - hurd)) + i586-gnu)) (define i686-linux (platform @@ -51,7 +51,7 @@ (system #f) (glibc-dynamic-linker #f))) -(define hurd +(define i586-gnu (platform (target "i586-pc-gnu") (system "i586-gnu") diff --git a/guix/read-print.scm b/guix/read-print.scm index a5a1b708bf..65b8cce37d 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -337,7 +337,8 @@ expressions and blanks that were read." ('services '(operating-system)) ('set-xorg-configuration '()) - ('services '(home-environment)))) + ('services '(home-environment)) + ('home-bash-configuration '(service)))) (define (prefix? candidate lst) "Return true if CANDIDATE is a prefix of LST." @@ -367,10 +368,9 @@ surrounding SYMBOL." (define (newline-form? symbol context) "Return true if parenthesized expressions starting with SYMBOL must be followed by a newline." - (match (vhash-assq symbol %newline-forms) - (#f #f) - ((_ . prefix) - (prefix? prefix context)))) + (let ((matches (vhash-foldq* cons '() symbol %newline-forms))) + (find (cut prefix? <> context) + matches))) (define (escaped-string str) "Return STR with backslashes and double quotes escaped. Everything else, in diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 825ccb1e73..fd263c0699 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -26,9 +26,9 @@ #:use-module (guix utils) #:use-module (guix packages) #:autoload (guix scripts package) (manifest-entry-version-prefix) + #:use-module (guix read-print) #:use-module (gnu packages) #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 popen) @@ -170,8 +170,19 @@ user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them." (gnu services) ,@(delete-duplicates (concatenate modules))) + ,(vertical-space 1) + (home-environment - (packages (specifications->packages ,packages)) + ,(comment (G_ "\ +;; Below is the list of packages that will show up in your +;; Home profile, under ~/.guix-home/profile.\n")) + (packages + (specifications->packages ,packages)) + + ,(vertical-space 1) + ,(comment (G_ "\ +;; Below is the list of Home services. To search for available +;; services, run 'guix home search KEYWORD' in a terminal.\n")) (services (list ,@services))))))))) (define* (import-manifest @@ -187,7 +198,5 @@ user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them." ;; specifies package names. To reproduce the exact same profile, you also ;; need to capture the channels being used, as returned by \"guix describe\". ;; See the \"Replicating Guix\" section in the manual.\n")) - (for-each (lambda (exp) - (newline port) - (pretty-print exp port)) - exp)))) + (newline port) + (pretty-print-with-comments/splice port exp)))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index d3ee69840c..78b6978c92 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -48,6 +48,7 @@ #:use-module (guix scripts build) #:use-module (guix transformations) #:use-module ((guix self) #:select (make-config.scm)) + #:use-module (gnu compression) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages compression) #:hide (zip)) @@ -61,13 +62,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:export (compressor? - compressor-name - compressor-extension - compressor-command - %compressors - lookup-compressor - self-contained-tarball + #:export (self-contained-tarball debian-archive docker-image squashfs-image @@ -75,34 +70,6 @@ %formats guix-pack)) -;; Type of a compression tool. -(define-record-type <compressor> - (compressor name extension command) - compressor? - (name compressor-name) ;string (e.g., "gzip") - (extension compressor-extension) ;string (e.g., ".lz") - (command compressor-command)) ;gexp (e.g., #~(list "/gnu/store/…/gzip" - ; "-9n" )) - -(define %compressors - ;; Available compression tools. - (list (compressor "gzip" ".gz" - #~(list #+(file-append gzip "/bin/gzip") "-9n")) - (compressor "lzip" ".lz" - #~(list #+(file-append lzip "/bin/lzip") "-9")) - (compressor "xz" ".xz" - #~(append (list #+(file-append xz "/bin/xz") - "-e") - (%xz-parallel-args))) - (compressor "bzip2" ".bz2" - #~(list #+(file-append bzip2 "/bin/bzip2") "-9")) - (compressor "zstd" ".zst" - ;; The default level 3 compresses better than gzip in a - ;; fraction of the time, while the highest level 19 - ;; (de)compresses more slowly and worse than xz. - #~(list #+(file-append zstd "/bin/zstd") "-3")) - (compressor "none" "" #f))) - ;; This one is only for use in this module, so don't put it in %compressors. (define bootstrap-xz (compressor "bootstrap-xz" ".xz" @@ -110,15 +77,6 @@ "-e") (%xz-parallel-args)))) -(define (lookup-compressor name) - "Return the compressor object called NAME. Error out if it could not be -found." - (or (find (match-lambda - (($ <compressor> name*) - (string=? name* name))) - %compressors) - (leave (G_ "~a: compressor not found~%") name))) - (define not-config? ;; Select (guix …) and (gnu …) modules, except (guix config). (match-lambda diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index b7d8165262..f46c11b1a5 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -205,7 +205,6 @@ In case ITEMS is an empty list, return 1 instead." #:make-progress-reporter (lambda* (total #:key url #:allow-other-keys) (progress-reporter/bar total))))) - (format #t (highlight "~a~%") server) (let ((obtained (length narinfos)) (requested (length items)) (missing (lset-difference string=? @@ -224,6 +223,15 @@ In case ITEMS is an empty list, return 1 instead." (coloring-procedure (color BOLD RED))) (else highlight)))) + (format #t (highlight "~a ~a~%") server + ;; This requires a Unicode-capable encoding, which we + ;; restrict to UTF-8 for simplicity. + (if (string=? (port-encoding (current-output-port)) "UTF-8") + (cond ((> ratio 0.80) "☀") + ((< ratio 0.50) "⛈") + (else "⛅")) + "")) + (format #t (colorize (G_ " ~,1f% substitutes available (~h out of ~h)~%")) (* 100. ratio) |