diff options
| author | Maxim Cournoyer <maxim.cournoyer@gmail.com> | 2022-03-21 23:39:43 -0400 |
|---|---|---|
| committer | Maxim Cournoyer <maxim.cournoyer@gmail.com> | 2022-03-21 23:39:43 -0400 |
| commit | a9429c8f2207841c649438187d6e19046d323a16 (patch) | |
| tree | a06e4b8a87b6a42742cf6750276746a10b6c2139 /guix | |
| parent | f0136b36ae8c1e9c174043bd50e0e24413c0f345 (diff) | |
| parent | 49b350fafc2c3ea1db66461b73d4e304cd13ec92 (diff) | |
| download | guix-a9429c8f2207841c649438187d6e19046d323a16.tar guix-a9429c8f2207841c649438187d6e19046d323a16.tar.gz | |
Merge branch 'staging' into core-updates.
Diffstat (limited to 'guix')
47 files changed, 1722 insertions, 663 deletions
diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index 6261f8a55a..66e7711bcd 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -2,7 +2,8 @@ ;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me> -;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021, 2022 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -88,6 +89,7 @@ (guile #f) (julia-package-name #f) (julia-package-uuid #f) + (julia-package-dependencies ''()) (imported-modules %julia-build-system-modules) (modules '((guix build julia-build-system) (guix build utils)))) @@ -108,7 +110,8 @@ search-paths)) #:inputs #$(input-tuples->gexp inputs) #:julia-package-name #$julia-package-name - #:julia-package-uuid #$julia-package-uuid)))) + #:julia-package-uuid #$julia-package-uuid + #:julia-package-dependencies #$julia-package-dependencies)))) (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system #:graft? #f))) diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index ad604f8871..9fee6c4570 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018, 2019 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -58,6 +59,7 @@ for TRIPLET." (if (target-64bit? triplet) "ppc64" "ppc")) + ((target-riscv64? triplet) "riscv64") (#t (error "meson: unknown architecture")))) (cpu . ,(cond ((target-x86-32? triplet) ; i386, ..., i686 (substring triplet 0 4)) @@ -78,6 +80,8 @@ for TRIPLET." ;; At least in Guix. Aarch64 and 32-bit arm ;; have a big-endian mode as well. ((target-arm? triplet) "little") + ((target-ppc32? triplet) "big") + ((target-riscv64? triplet) "little") (#t (error "meson: unknown architecture")))))) (define (make-binaries-alist triplet) diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index e7d6d96f0e..5ced9d243b 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com> -;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -216,13 +216,13 @@ pre-defined variants." (host-inputs `(,@(if source `(("source" ,source)) '()) - ,@inputs - - ;; Keep the standard inputs of 'gnu-build-system'. - ,@(standard-packages))) + ,@inputs)) (build-inputs `(("ocaml" ,ocaml) ("findlib" ,findlib) - ,@native-inputs)) + ,@native-inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) (outputs outputs) (build ocaml-build) (arguments (strip-keyword-arguments private-keywords arguments))))) diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index 09907c67d8..dbb72cd24a 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Thiago Jung Bauermann <bauermann@kolabnow.com> ;;; ;;; This file is part of GNU Guix. @@ -177,10 +177,13 @@ level package ID." (map search-path-specification->sexp search-paths))))))) - (gexp->derivation name builder - #:system system - #:target #f - #:substitutable? substitutable?)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target #f + #:substitutable? substitutable? + #:guile-for-build guile))) (define texlive-build-system (build-system diff --git a/guix/build/download.scm b/guix/build/download.scm index 7c310e94f1..41583e8143 100644 --- a/guix/build/download.scm +++ b/guix/build/download.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 © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com> @@ -28,6 +28,7 @@ #:use-module (guix ftp-client) #:use-module (guix build utils) #:use-module (guix progress) + #:use-module (guix memoization) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -177,27 +178,30 @@ name decoding bug described at (let ((data (call-with-input-file file get-bytevector-all))) (set-certificate-credentials-x509-trust-data! cred data format))) -(define (make-credendials-with-ca-trust-files directory) - "Return certificate credentials with X.509 authority certificates read from +(define make-credentials-with-ca-trust-files + (mlambda (directory) + "Return certificate credentials with X.509 authority certificates read from DIRECTORY. Those authority certificates are checked when 'peer-certificate-status' is later called." - (let ((cred (make-certificate-credentials)) - (files (match (scandir directory (cut string-suffix? ".pem" <>)) - ((or #f ()) - ;; Some distros provide nothing but bundles (*.crt) under - ;; /etc/ssl/certs, so look for them. - (or (scandir directory (cut string-suffix? ".crt" <>)) - '())) - (pem pem)))) - (for-each (lambda (file) - (let ((file (string-append directory "/" file))) - ;; Protect against dangling symlinks. - (when (file-exists? file) - (set-certificate-credentials-x509-trust-file!* - cred file - x509-certificate-format/pem)))) - files) - cred)) + ;; Memoize the result to avoid scanning all the certificates every time a + ;; connection is made. + (let ((cred (make-certificate-credentials)) + (files (match (scandir directory (cut string-suffix? ".pem" <>)) + ((or #f ()) + ;; Some distros provide nothing but bundles (*.crt) under + ;; /etc/ssl/certs, so look for them. + (or (scandir directory (cut string-suffix? ".crt" <>)) + '())) + (pem pem)))) + (for-each (lambda (file) + (let ((file (string-append directory "/" file))) + ;; Protect against dangling symlinks. + (when (file-exists? file) + (set-certificate-credentials-x509-trust-file!* + cred file + x509-certificate-format/pem)))) + files) + cred))) (define (peer-certificate session) "Return the certificate of the remote peer in SESSION." @@ -273,7 +277,7 @@ host name without trailing dot." (set-session-credentials! session (if (and verify-certificate? ca-certs) - (make-credendials-with-ca-trust-files + (make-credentials-with-ca-trust-files ca-certs) (make-certificate-credentials))) @@ -431,8 +435,7 @@ ETIMEDOUT error is raised." #:key timeout (verify-certificate? #t)) - "Like 'open-socket-for-uri', but also handle HTTPS connections. The -resulting port must be closed with 'close-connection'. When + "Like 'open-socket-for-uri', but also handle HTTPS connections. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually ;; undefined. See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047. diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index ab77e57f33..6a6918bfdd 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -140,6 +140,79 @@ store in '.el' files." (substitute-program-names)))) #t)) +(define (find-root-library-file name) + (let loop ((parts (string-split + (package-name-version->elpa-name-version name) #\-)) + (candidate "")) + (cond + ;; at least one version part is given, so we don't terminate "early" + ((null? parts) #f) + ((string-null? candidate) (loop (cdr parts) (car parts))) + ((file-exists? (string-append candidate ".el")) candidate) + (else + (loop (cdr parts) (string-append candidate "-" (car parts))))))) + +(define* (ensure-package-description #:key outputs #:allow-other-keys) + (define (write-pkg-file name) + (define summary-regexp + "^;;; [^ ]*\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$") + (define %write-pkg-file-form + `(progn + (require 'lisp-mnt) + (require 'package) + + (defun build-package-desc-from-library (name) + (package-desc-from-define + name + ;; Workaround for malformed version string (for example "24 (beta)" + ;; in paredit.el), try to parse version obtained by lm-version, + ;; before trying to create package-desc. Otherwise the whole process + ;; of generation -pkg.el will fail. + (condition-case + nil + (let ((version (lm-version))) + ;; raises an error if version is invalid + (and (version-to-list version) version)) + (error "0.0.0")) + (or (save-excursion + (goto-char (point-min)) + (and (re-search-forward ,summary-regexp nil t) + (match-string-no-properties 1))) + package--default-summary) + (let ((require-lines (lm-header-multiline "package-requires"))) + (and require-lines + (package--prepare-dependencies + (package-read-from-string + (mapconcat 'identity require-lines " "))))) + :kind 'single + :url (lm-homepage) + :keywords (lm-keywords-list) + :maintainer (lm-maintainer) + :authors (lm-authors))) + + (defun generate-package-description-file (name) + (package-generate-description-file + (build-package-desc-from-library name) + (concat name "-pkg.el"))) + + (condition-case + err + (let ((name (file-name-base (buffer-file-name)))) + (generate-package-description-file name) + (message (concat name "-pkg.el file generated."))) + (error + (message "There are some errors during generation of -pkg.el file:") + (message "%s" (error-message-string err)))))) + + (unless (file-exists? (string-append name "-pkg.el")) + (emacs-batch-edit-file (string-append name ".el") + %write-pkg-file-form))) + + (let* ((out (assoc-ref outputs "out")) + (elpa-name-ver (store-directory->elpa-name-version out))) + (with-directory-excursion (elpa-directory out) + (and=> (find-root-library-file elpa-name-ver) write-pkg-file)))) + (define* (check #:key tests? (test-command '("make" "check")) (parallel-tests? #t) #:allow-other-keys) "Run the tests by invoking TEST-COMMAND. @@ -279,8 +352,10 @@ for libraries following the ELPA convention." (add-after 'make-autoloads 'enable-autoloads-compilation enable-autoloads-compilation) (add-after 'enable-autoloads-compilation 'patch-el-files patch-el-files) + (add-after 'patch-el-files 'ensure-package-description + ensure-package-description) ;; The .el files are byte compiled directly in the store. - (add-after 'patch-el-files 'build build) + (add-after 'ensure-package-description 'build build) (add-after 'build 'validate-compiled-autoloads validate-compiled-autoloads) (add-after 'validate-compiled-autoloads 'move-doc move-doc))) diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm index 03d669be64..b0dac154e9 100644 --- a/guix/build/julia-build-system.scm +++ b/guix/build/julia-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2019, 2020 Nicolò Balzarotti <nicolo@nixo.xyz> ;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me> ;;; Copyright © 2021, 2022 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -111,9 +112,9 @@ Project.toml)." (job-count (if parallel-tests? (parallel-job-count) 1)) - ;; The --proc argument of Julia *adds* extra processors rather than - ;; specify the exact count to use, so zero must be specified to - ;; disable parallel processing... + ;; The --procs argument of Julia *adds* extra processors rather + ;; than specify the exact count to use, so zero must be specified + ;; to disable parallel processing... (additional-procs (max 0 (1- job-count)))) ;; With a patch, SOURCE_DATE_EPOCH is honored (setenv "SOURCE_DATE_EPOCH" "1") @@ -126,7 +127,7 @@ Project.toml)." (setenv "HOME" "/tmp") (apply invoke "julia" `("--depwarn=yes" - ,@(if parallel-tests? + ,@(if (and parallel-tests? (< 0 additional-procs)) ;; XXX: ... but '--procs' doesn't accept 0 as a valid ;; value, so just omit the argument entirely. (list (string-append "--procs=" @@ -136,7 +137,8 @@ Project.toml)." package "/test/runtests.jl")))))) (define* (link-depot #:key source inputs outputs - julia-package-name julia-package-uuid #:allow-other-keys) + julia-package-name julia-package-uuid + julia-package-dependencies #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (name+version (strip-store-file-name out)) (version (last (string-split name+version #\-))) @@ -156,6 +158,7 @@ println(Base.version_slug(Base.UUID(\"~a\"), (julia-create-package-toml (getcwd) julia-package-name julia-package-uuid version + julia-package-dependencies #:file "Project.toml")) ;; When installing a package, julia looks first at in the JULIA_DEPOT_PATH @@ -186,9 +189,10 @@ version = \"" version "\" ") f) (when (not (null? deps)) (display "[deps]\n" f) - (for-each (lambda dep - (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n") - f)) + (for-each (match-lambda + ((name . uuid) + (display (string-append name " = \"" uuid "\"\n") + f))) deps)) (close-port f))) @@ -207,6 +211,7 @@ version = \"" version "\" (delete 'build))) (define* (julia-build #:key inputs julia-package-name julia-package-uuid + julia-package-dependencies (phases %standard-phases) #:allow-other-keys #:rest args) "Build the given Julia package, applying all of PHASES in order." @@ -214,4 +219,5 @@ version = \"" version "\" #:inputs inputs #:phases phases #:julia-package-name julia-package-name #:julia-package-uuid julia-package-uuid + #:julia-package-dependencies julia-package-dependencies args)) diff --git a/guix/build/maven/java.scm b/guix/build/maven/java.scm index daa4c88045..f8c8e5745d 100644 --- a/guix/build/maven/java.scm +++ b/guix/build/maven/java.scm @@ -31,11 +31,14 @@ (? (and (ignore "static") (* WS))) package-name (* WS) (ignore ";"))) -(define-peg-pattern comment all (and (? (and annotation-pat (* WS))) (ignore "/*") - comment-part)) +(define-peg-pattern comment all (or + (and (? (and annotation-pat (* WS))) (ignore "/*") + comment-part) + (and (ignore "//") (* (or "\t" (range #\ #\xffff))) + (or (ignore "\n") (ignore "\r")) (* WS)))) (define-peg-pattern comment-part body (or (ignore (and (* "*") "/")) (and (* "*") (+ comment-chr) comment-part))) -(define-peg-pattern comment-chr body (or "\t" "\n" (range #\ #\)) (range #\+ #\xffff))) +(define-peg-pattern comment-chr body (or "\t" "\n" "\r" (range #\ #\)) (range #\+ #\xffff))) (define-peg-pattern inline-comment none (and (ignore "//") (* inline-comment-chr) (ignore "\n"))) (define-peg-pattern inline-comment-chr body (range #\ #\xffff)) diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 01e1f41870..657a91f324 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -140,7 +140,7 @@ It is meant as an internal format." refs))))))) (define (file-size file) - "Return the size of bytes of FILE, entering it if FILE is a directory." + "Return the size in bytes of FILE, entering it if FILE is a directory." (file-system-fold (const #t) (lambda (file stat result) ;leaf (+ (stat:size stat) result)) diff --git a/guix/colors.scm b/guix/colors.scm index 3031f54799..ae0a583d94 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2013, 2014 Free Software Foundation, Inc. ;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +31,7 @@ colorize-string highlight + highlight/warn dim color-rules @@ -143,6 +144,7 @@ that subsequent output will not have any colors in effect." str))) (define highlight (coloring-procedure (color BOLD))) +(define highlight/warn (coloring-procedure (color BOLD MAGENTA))) (define dim (coloring-procedure (color DARK))) (define (colorize-matches rules) diff --git a/guix/cpu.scm b/guix/cpu.scm index e1911f52a8..a44cd082f1 100644 --- a/guix/cpu.scm +++ b/guix/cpu.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:export (current-cpu cpu? cpu-architecture + cpu-vendor cpu-family cpu-model cpu-flags @@ -41,9 +43,10 @@ ;; CPU description. (define-record-type <cpu> - (cpu architecture family model flags) + (cpu architecture vendor family model flags) cpu? (architecture cpu-architecture) ;string, from 'uname' + (vendor cpu-vendor) ;string (family cpu-family) ;integer (model cpu-model) ;integer (flags cpu-flags)) ;set of strings @@ -57,28 +60,33 @@ (call-with-input-file "/proc/cpuinfo" (lambda (port) - (let loop ((family #f) + (let loop ((vendor #f) + (family #f) (model #f)) (match (read-line port) ((? eof-object?) #f) + ((? (prefix? "vendor_id") str) + (match (string-tokenize str) + (("vendor_id" ":" vendor) + (loop vendor family model)))) ((? (prefix? "cpu family") str) (match (string-tokenize str) (("cpu" "family" ":" family) - (loop (string->number family) model)))) + (loop vendor (string->number family) model)))) ((? (prefix? "model") str) (match (string-tokenize str) (("model" ":" model) - (loop family (string->number model))) + (loop vendor family (string->number model))) (_ - (loop family model)))) + (loop vendor family model)))) ((? (prefix? "flags") str) (match (string-tokenize str) (("flags" ":" flags ...) (cpu (utsname:machine (uname)) - family model (list->set flags))))) + vendor family model (list->set flags))))) (_ - (loop family model)))))))) + (loop vendor family model)))))))) (define (cpu->gcc-architecture cpu) "Return the architecture name, suitable for GCC's '-march' flag, that @@ -86,29 +94,74 @@ corresponds to CPU, a record as returned by 'current-cpu'." (match (cpu-architecture cpu) ("x86_64" ;; Transcribed from GCC's 'host_detect_local_cpu' in driver-i386.c. - (or (and (= 6 (cpu-family cpu)) ;the "Pentium Pro" family - (letrec-syntax ((model (syntax-rules (=>) - ((_) #f) - ((_ (candidate => integers ...) rest - ...) - (or (and (= (cpu-model cpu) integers) - candidate) - ... - (model rest ...)))))) - (model ("bonnel" => #x1c #x26) - ("silvermont" => #x37 #x4a #x4d #x5a #x5d) - ("core2" => #x0f #x17 #x1d) - ("nehalem" => #x1a #x1e #x1f #x2e) - ("westmere" => #x25 #x2c #x2f) - ("sandybridge" => #x2a #x2d) - ("ivybridge" => #x3a #x3e) - ("haswell" => #x3c #x3f #x45 #x46) - ("broadwell" => #x3d #x47 #x4f #x56) - ("skylake" => #x4e #x5e #x8e #x9e) - ("skylake-avx512" => #x55) ;TODO: cascadelake - ("knl" => #x57) - ("cannonlake" => #x66) - ("knm" => #x85)))) + (or (and (equal? "GenuineIntel" (cpu-vendor cpu)) + (= 6 (cpu-family cpu)) ;the "Pentium Pro" family + (letrec-syntax ((if-flags (syntax-rules (=>) + ((_) + #f) + ((_ (flags ... => name) rest ...) + (if (every (lambda (flag) + (set-contains? (cpu-flags cpu) + flag)) + '(flags ...)) + name + (if-flags rest ...)))))) + + (if-flags ("avx" "avx512vp2intersect" "tsxldtrk" => "sapphirerapids") + ("avx" "avx512vp2intersect" => "tigerlake") + ("avx" "avx512bf16" => "cooperlake") + ("avx" "wbnoinvd" => "icelake-server") + ("avx" "avx512bitalg" => "icelake-client") + ("avx" "avx512vbmi" => "cannonlake") + ("avx" "avx5124vnniw" => "knm") + ("avx" "avx512er" => "knl") + ("avx" "avx512f" => "skylake-avx512") + ("avx" "serialize" => "alderlake") + ("avx" "clflushopt" => "skylake") + ("avx" "adx" => "broadwell") + ("avx" "avx2" => "haswell") + ("avx" => "sandybridge") + ("sse4_2" "gfni" => "tremont") + ("sse4_2" "sgx" => "goldmont-plus") + ("sse4_2" "xsave" => "goldmont") + ("sse4_2" "movbe" => "silvermont") + ("sse4_2" => "nehalem") + ("ssse3" "movbe" => "bonnell") + ("ssse3" => "core2") + ("longmode" => "x86-64")))) + + (and (equal? "AuthenticAMD" (cpu-vendor cpu)) + (letrec-syntax ((if-flags (syntax-rules (=>) + ((_) + #f) + ((_ (flags ... => name) rest ...) + (if (every (lambda (flag) + (set-contains? (cpu-flags cpu) + flag)) + '(flags ...)) + name + (if-flags rest ...)))))) + + (or (and (= 22 (cpu-family cpu)) + (if-flags ("movbe" => "btver2"))) + (and (= 6 (cpu-family cpu)) + (if-flags ("3dnowp" => "athalon"))) + (if-flags ("vaes" => "znver3") + ("clwb" => "znver2") + ("clzero" => "znver1") + ("avx2" => "bdver4") + ("xsaveopt" => "bdver3") + ("bmi" => "bdver2") + ("xop" => "bdver1") + ("sse4a" "has_ssse3" => "btver1") + ("sse4a" => "amdfam10") + ("sse2" "sse3" => "k8-sse3") + ("longmode" "sse3" => "k8-sse3") + ("sse2" => "k8") + ("longmode" => "k8") + ("mmx" "3dnow" => "k6-3") + ("mmx" => "k6") + (_ => "pentium"))))) ;; Fallback case for non-Intel processors or for Intel processors not ;; recognized above. @@ -135,7 +188,7 @@ corresponds to CPU, a record as returned by 'current-cpu'." ("ssse3" "movbe" => "bonnell") ("ssse3" => "core2"))) - ;; TODO: Recognize AMD models (bdver*, znver*, etc.)? + ;; TODO: Recognize CENTAUR/CYRIX/NSC? "x86_64")) (architecture diff --git a/guix/deprecation.scm b/guix/deprecation.scm index c66c9367f6..09a27789c9 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,8 @@ define-deprecated/public define-deprecated/alias + + warn-about-old-daemon warn-about-deprecation)) ;;; Commentary: @@ -32,6 +35,11 @@ ;;; ;;; Code: +(define (warn-about-old-daemon) + (warning (G_ "Your Guix daemon is severely outdated, and will soon cease to +be able to download binary substitutes. To upgrade it, refer to the +'Upgrading Guix' section in the manual.~%"))) + (define* (warn-about-deprecation variable properties #:key replacement) (let ((location (and properties (source-properties->location properties)))) diff --git a/guix/derivations.scm b/guix/derivations.scm index f77ea179f4..354ec20e3f 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -245,11 +245,19 @@ Nix itself keeps only one of them." (make-hash-table 25)) (for-each (lambda (input) - (let* ((drv (derivation-input-path input)) + ;; If DRV1 and DRV2 are fixed-output derivations with the same + ;; output path, they must be coalesced. Thus, TABLE is keyed by + ;; output paths. + (let* ((drv (derivation-input-derivation input)) + (key (string-join + (map (match-lambda + ((_ . output) + (derivation-output-path output))) + (derivation-outputs drv)))) (sub-drvs (derivation-input-sub-derivations input))) - (match (hash-get-handle table drv) + (match (hash-get-handle table key) (#f - (hash-set! table drv input)) + (hash-set! table key input)) ((and handle (key . ($ <derivation-input> drv sub-drvs2))) ;; Merge DUP with INPUT. (let* ((sub-drvs (delete-duplicates diff --git a/guix/gexp.scm b/guix/gexp.scm index 01dca902f7..9fdb7a30be 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1,10 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> -;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -174,12 +174,15 @@ As a result, the S-expression will be approximate if GEXP has references." (map (lambda (reference) (match reference (($ <gexp-input> thing output native) - (if (gexp-like? thing) - (gexp->approximate-sexp thing) - ;; Simply returning 'thing' won't work in some - ;; situations; see 'write-gexp' below. - '(*approximate*))) - (_ '(*approximate*)))) + (cond ((gexp-like? thing) + (gexp->approximate-sexp thing)) + ((not (record? thing)) ; a S-exp + thing) + (#true + ;; Simply returning 'thing' won't work in some + ;; situations; see 'write-gexp' below. + '(*approximate*)))) + (($ <gexp-output>) '(*approximate*)))) (gexp-references gexp)))) (define (write-gexp gexp port) @@ -597,13 +600,10 @@ This is the declarative counterpart of 'gexp->derivation'." ;; gexp. (match file (($ <computed-file> name gexp guile options) - (if guile - (mlet %store-monad ((guile (lower-object guile system - #:target target))) - (apply gexp->derivation name gexp #:guile-for-build guile - #:system system #:target target options)) - (apply gexp->derivation name gexp - #:system system #:target target options))))) + (mlet %store-monad ((guile (lower-object (or guile (default-guile)) + system #:target #f))) + (apply gexp->derivation name gexp #:guile-for-build guile + #:system system #:target target options))))) (define-record-type <program-file> (%program-file name gexp guile path) @@ -2071,7 +2071,7 @@ resulting store file holds references to all these." #:local-build? #t #:substitutable? #f)) -(define* (mixed-text-file name #:rest text) +(define* (mixed-text-file name #:key guile #:rest text) "Return an object representing store file NAME containing TEXT. TEXT is a sequence of strings and file-like objects, as in: @@ -2080,14 +2080,15 @@ sequence of strings and file-like objects, as in: This is the declarative counterpart of 'text-file*'." (define build - (gexp (call-with-output-file (ungexp output "out") - (lambda (port) - (set-port-encoding! port "UTF-8") - (display (string-append (ungexp-splicing text)) port))))) + (let ((text (if guile (drop text 2) text))) + (gexp (call-with-output-file (ungexp output "out") + (lambda (port) + (set-port-encoding! port "UTF-8") + (display (string-append (ungexp-splicing text)) port)))))) - (computed-file name build)) + (computed-file name build #:guile guile)) -(define (file-union name files) +(define* (file-union name files #:key guile) "Return a <computed-file> that builds a directory containing all of FILES. Each item in FILES must be a two-element list where the first element is the file name to use in the new directory, and the second element is a gexp @@ -2121,7 +2122,8 @@ This yields an 'etc' directory containing these two files." (mkdir-p (dirname (ungexp target))) (symlink (ungexp source) (ungexp target)))))) - files))))))) + files))))) + #:guile guile)) (define* (directory-union name things #:key (copy? #f) (quiet? #f) @@ -2177,6 +2179,29 @@ is true, the derivation will not print anything." ;;; (eval-when (expand load eval) + (define-once read-syntax-redefined? + ;; Have we already redefined 'read-syntax'? This needs to be done on + ;; 3.0.8 only to work around <https://issues.guix.gnu.org/54003>. + (or (not (module-variable the-scm-module 'read-syntax)) + (not (guile-version>? "3.0.7")))) + + (define read-procedure + ;; The current read procedure being called: either 'read' or + ;; 'read-syntax'. + (make-parameter read)) + + (define read-syntax* + ;; Replacement for 'read-syntax'. + (let ((read-syntax (and=> (module-variable the-scm-module 'read-syntax) + variable-ref))) + (lambda (port . rest) + (parameterize ((read-procedure read-syntax)) + (apply read-syntax port rest))))) + + (unless read-syntax-redefined? + (set! (@ (guile) read-syntax) read-syntax*) + (set! read-syntax-redefined? #t)) + (define* (read-ungexp chr port #:optional native?) "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is true, use 'ungexp-native' and 'ungexp-native-splicing' instead." @@ -2192,22 +2217,39 @@ true, use 'ungexp-native' and 'ungexp-native-splicing' instead." 'ungexp-native 'ungexp)))) - (match (read port) - ((? symbol? symbol) - (let ((str (symbol->string symbol))) + (define symbolic? + ;; Depending on whether (read-procedure) is 'read' or 'read-syntax', we + ;; might get either sexps or syntax objects. Adjust accordingly. + (if (eq? (read-procedure) read) + symbol? + (compose symbol? syntax->datum))) + + (define symbolic->string + (if (eq? (read-procedure) read) + symbol->string + (compose symbol->string syntax->datum))) + + (define wrapped-symbol + (if (eq? (read-procedure) read) + (lambda (_ symbol) symbol) + datum->syntax)) + + (match ((read-procedure) port) + ((? symbolic? symbol) + (let ((str (symbolic->string symbol))) (match (string-index-right str #\:) (#f `(,unquote-symbol ,symbol)) (colon (let ((name (string->symbol (substring str 0 colon))) (output (substring str (+ colon 1)))) - `(,unquote-symbol ,name ,output)))))) + `(,unquote-symbol ,(wrapped-symbol symbol name) ,output)))))) (x `(,unquote-symbol ,x)))) (define (read-gexp chr port) "Read a 'gexp' form from PORT." - `(gexp ,(read port))) + `(gexp ,((read-procedure) port))) ;; Extend the reader (read-hash-extend #\~ read-gexp) diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm index ab3fcd8b2f..419cb85afc 100644 --- a/guix/git-authenticate.scm +++ b/guix/git-authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2021, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +22,9 @@ #:use-module (guix base16) #:autoload (guix base64) (base64-encode) #:use-module ((guix git) - #:select (commit-difference false-if-git-not-found)) + #:select (commit-difference + commit-descendant? + false-if-git-not-found)) #:use-module (guix i18n) #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (guix openpgp) @@ -426,6 +428,17 @@ denoting the authorized keys for commits whose parent lack the (verify-introductory-commit repository keyring start-commit signer)) + ;; Make sure END-COMMIT is a descendant of START-COMMIT or of one of + ;; AUTHENTICATED-COMMITS, which are known to be descendants of + ;; START-COMMIT. + (unless (commit-descendant? end-commit + (cons start-commit + authenticated-commits)) + (raise (formatted-message + (G_ "commit ~a is not a descendant of introductory commit ~a") + (oid->string (commit-id end-commit)) + (oid->string (commit-id start-commit))))) + (let ((stats (call-with-progress-reporter reporter (lambda (report) (authenticate-commits repository commits diff --git a/guix/git.scm b/guix/git.scm index 43e85a5026..53e7219c8c 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> @@ -46,6 +46,7 @@ #:use-module (ice-9 ftw) #: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) #:export (%repository-cache-directory @@ -60,6 +61,7 @@ latest-repository-commit commit-difference commit-relation + commit-descendant? remote-refs @@ -623,6 +625,26 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or (if (set-contains? oldest new) 'descendant 'unrelated)))))) + +(define (commit-descendant? new old) + "Return true if NEW is the descendant of one of OLD, a list of commits. + +When the expected result is likely #t, this is faster than using +'commit-relation' since fewer commits need to be traversed." + (let ((old (list->setq old))) + (let loop ((commits (list new)) + (visited (setq))) + (match commits + (() + #f) + (_ + ;; Perform a breadth-first search as this is likely going to + ;; terminate more quickly than a depth-first search. + (let ((commits (remove (cut set-contains? visited <>) commits))) + (or (any (cut set-contains? old <>) commits) + (loop (append-map commit-parents commits) + (fold set-insert visited commits))))))))) + ;; ;;; Remote operations. diff --git a/guix/graph.scm b/guix/graph.scm index 3a1cab244b..41219ab67d 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2016, 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -22,10 +22,13 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix sets) + #:autoload (guix diagnostics) (formatted-message) + #:autoload (guix i18n) (G_) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:export (node-type @@ -47,6 +50,8 @@ %graph-backends %d3js-backend %graphviz-backend + lookup-backend + graph-backend? graph-backend graph-backend-name @@ -335,6 +340,13 @@ nodeArray.push(nodes[\"~a\"]);~%" %d3js-backend %cypher-backend)) +(define (lookup-backend name) + "Return the graph backend called NAME. Raise an error if it is not found." + (or (find (lambda (backend) + (string=? (graph-backend-name backend) name)) + %graph-backends) + (raise (formatted-message (G_ "~a: unknown graph backend") name)))) + (define* (export-graph sinks port #:key reverse-edges? node-type (max-depth +inf.0) diff --git a/guix/http-client.scm b/guix/http-client.scm index 10bc278023..143ed6de31 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2018, 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> @@ -52,6 +52,7 @@ http-get-error-uri http-get-error-code http-get-error-reason + http-get-error-headers http-fetch http-multiple-get @@ -69,9 +70,10 @@ ;; HTTP GET error. (define-condition-type &http-get-error &error http-get-error? - (uri http-get-error-uri) ; URI - (code http-get-error-code) ; integer - (reason http-get-error-reason)) ; string + (uri http-get-error-uri) ;URI + (code http-get-error-code) ;integer + (reason http-get-error-reason) ;string + (headers http-get-error-headers)) ;alist (define* (http-fetch uri #:key port (text? #f) (buffered? #t) @@ -98,14 +100,15 @@ TIMEOUT is #f, connection establishment never times out. Write information about redirects to LOG-PORT. Raise an '&http-get-error' condition if downloading fails." - (let loop ((uri (if (string? uri) - (string->uri uri) - uri))) - (let ((port (or port (open-connection uri - #:verify-certificate? - verify-certificate? - #:timeout timeout))) - (headers (match (uri-userinfo uri) + (define uri* + (if (string? uri) (string->uri uri) uri)) + + (let loop ((uri uri*) + (port (or port (open-connection uri* + #:verify-certificate? + verify-certificate? + #:timeout timeout)))) + (let ((headers (match (uri-userinfo uri) ((? string? str) (cons (cons 'Authorization (string-append "Basic " @@ -129,16 +132,29 @@ Raise an '&http-get-error' condition if downloading fails." 303 ; see other 307 ; temporary redirection 308) ; permanent redirection - (let ((uri (resolve-uri-reference (response-location resp) uri))) - (close-port port) + (let ((host (uri-host uri)) + (uri (resolve-uri-reference (response-location resp) uri))) + (if keep-alive? + (dump-port data (%make-void-port "w0") + (response-content-length resp)) + (close-port port)) (format log-port (G_ "following redirection to `~a'...~%") (uri->string uri)) - (loop uri))) + (loop uri + (or (and keep-alive? + (or (not (uri-host uri)) + (string=? host (uri-host uri))) + port) + (open-connection uri* + #:verify-certificate? + verify-certificate? + #:timeout timeout))))) (else (raise (condition (&http-get-error (uri uri) (code code) - (reason (response-reason-phrase resp))) + (reason (response-reason-phrase resp)) + (headers (response-headers resp))) (&message (message (format diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 7a73c11382..e848ebc789 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -606,9 +607,7 @@ s-expression corresponding to that package, or #f on failure." ;; Retry import from CRAN (cran->guix-package package-name #:repo 'cran)) (else - (raise (condition - (&message - (message "couldn't find meta-data for R package"))))))))))) + (values #f '())))))))) (define* (cran-recursive-import package-name #:key (repo 'cran) version) (recursive-import package-name diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index ea77a7c244..9399f45ebc 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -379,11 +380,7 @@ type '<elpa-package>'." "Fetch the package NAME from REPO and produce a Guix package S-expression." (match (fetch-elpa-package name repo) (#false - (raise (condition - (&message - (message (format #false - "couldn't find meta-data for ELPA package `~a'." - name)))))) + (values #f '())) (package ;; ELPA is known to contain only GPLv3+ code. Other repos may contain ;; code under other license but there's no license metadata. diff --git a/guix/import/github.scm b/guix/import/github.scm index 8c1898c0c5..51118d1d39 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> -;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> @@ -30,15 +30,17 @@ #:use-module (guix utils) #:use-module (guix i18n) #:use-module (guix diagnostics) + #:use-module ((guix ui) #:select (display-hint)) #:use-module ((guix download) #:prefix download:) #:use-module ((guix git-download) #:prefix download:) + #:autoload (guix build download) (open-connection-for-uri) #:use-module (guix import utils) - #:use-module (guix import json) #:use-module (json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix http-client) #:use-module (web uri) + #:use-module (web response) #:export (%github-api %github-updater)) ;; For tests. @@ -140,6 +142,33 @@ repository separated by a forward slash, from a string URL of the form ;; limit, or #f. (make-parameter (getenv "GUIX_GITHUB_TOKEN"))) +(define %rate-limit-reset-time + ;; Time (seconds since the Epoch, UTC) when the rate limit for GitHub + ;; requests will be reset, or #f if the rate limit hasn't been reached. + #f) + +(define (update-rate-limit-reset-time! headers) + "Update the rate limit reset time based on HEADERS, the HTTP response +headers." + (match (assq-ref headers 'x-ratelimit-reset) + ((= string->number (? number? reset)) + (set! %rate-limit-reset-time reset) + reset) + (_ + ;; This shouldn't happen. + (warning + (G_ "GitHub HTTP response lacks 'X-RateLimit-Reset' header~%")) + 0))) + +(define (request-rate-limit-reached?) + "Return true if the rate limit has been reached." + (and %rate-limit-reset-time + (match (< (car (gettimeofday)) %rate-limit-reset-time) + (#t #t) + (#f + (set! %rate-limit-reset-time #f) + #f)))) + (define (fetch-releases-or-tags url) "Fetch the list of \"releases\" or, if it's empty, the list of tags for the repository at URL. Return the corresponding JSON dictionaries (alists), @@ -170,20 +199,54 @@ empty list." `((Authorization . ,(string-append "token " (%github-token)))) '()))) - (guard (c ((and (http-get-error? c) - (= 404 (http-get-error-code c))) - (warning (G_ "~a is unreachable (~a)~%") - release-url (http-get-error-code c)) - '#())) ;return an empty release set - (let* ((port (http-fetch release-url #:headers headers)) - (result (json->scm port))) - (close-port port) - (match result - (#() - ;; We got the empty list, presumably because the user didn't use GitHub's - ;; "release" mechanism, but hopefully they did use Git tags. - (json-fetch tag-url #:headers headers)) - (x x))))) + (and (not (request-rate-limit-reached?)) + (guard (c ((and (http-get-error? c) + (= 404 (http-get-error-code c))) + (warning (G_ "~a is unreachable (~a)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c)) + '#()) ;return an empty release set + ((and (http-get-error? c) + (= 403 (http-get-error-code c))) + ;; See + ;; <https://docs.github.com/en/rest/overview/resources-in-the-rest-api#rate-limiting>. + (match (assq-ref (http-get-error-headers c) + 'x-ratelimit-remaining) + (#f + (raise c)) + ((? (compose zero? string->number)) + (let ((reset (update-rate-limit-reset-time! + (http-get-error-headers c)))) + (warning (G_ "GitHub rate limit exceeded; \ +disallowing requests for ~a seconds~%") + (- reset (car (gettimeofday)))) + (display-hint (G_ "You can raise the rate limit by +setting the @env{GUIX_GITHUB_TOKEN} environment variable to a token obtained +from @url{https://github.com/settings/tokens} with your GitHub account. + +Alternatively, you can wait until your rate limit is reset, or use the +@code{generic-git} updater instead.")) + #f)) ;bail out + (_ + (raise c))))) + + (let ((release-uri (string->uri release-url))) + (call-with-port (open-connection-for-uri release-uri) + (lambda (connection) + (let* ((result (json->scm + (http-fetch release-uri + #:port connection + #:keep-alive? #t + #:headers headers)))) + (match result + (#() + ;; We got the empty list, presumably because the user didn't use GitHub's + ;; "release" mechanism, but hopefully they did use Git tags. + (json->scm (http-fetch tag-url + #:port connection + #:keep-alive? #t + #:headers headers))) + (x x))))))))) (define (latest-released-version url package-name) "Return the newest released version and its tag given a string URL like @@ -223,23 +286,16 @@ releases." (cons tag tag)) (else #f)))) - (let* ((json (and=> (fetch-releases-or-tags url) - vector->list))) - (if (eq? json #f) - (if (%github-token) - (error "Error downloading release information through the GitHub -API when using a GitHub token") - (error "Error downloading release information through the GitHub -API. This may be fixed by using an access token and setting the environment -variable GUIX_GITHUB_TOKEN, for instance one procured from -https://github.com/settings/tokens")) - (match (sort (filter-map release->version - (match (remove pre-release? json) - (() json) ; keep everything - (releases releases))) - (lambda (x y) (version>? (car x) (car y)))) - (((latest-version . tag) . _) (values latest-version tag)) - (() (values #f #f)))))) + (match (and=> (fetch-releases-or-tags url) vector->list) + (#f (values #f #f)) + (json + (match (sort (filter-map release->version + (match (remove pre-release? json) + (() json) ; keep everything + (releases releases))) + (lambda (x y) (version>? (car x) (car y)))) + (((latest-version . tag) . _) (values latest-version tag)) + (() (values #f #f)))))) (define (latest-release pkg) "Return an <upstream-source> for the latest release of PKG." diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index b94f4169d4..0d6c77e399 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,9 +26,9 @@ (define-module (guix import hackage) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (srfi srfi-71) #:use-module (srfi srfi-34) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-1) #:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module ((guix utils) #:select (package-name->name+version @@ -136,7 +137,7 @@ version is returned." (define (read-cabal-and-hash port) "Read a Cabal file from PORT and return it and its hash in nix-base32 format as two values." - (let-values (((port get-hash) (open-sha256-input-port port))) + (let ((port get-hash (open-sha256-input-port port))) (values (read-cabal (canonical-newline-port port)) (bytevector->nix-base32-string (get-hash))))) @@ -148,10 +149,10 @@ version. On failure, both return values will be #f." (guard (c ((and (http-get-error? c) (= 404 (http-get-error-code c))) (values #f #f))) ;"expected" if package is unknown - (let*-values (((name version) (package-name->name+version name-version)) - ((url) (hackage-cabal-url name version)) - ((port _) (http-fetch url)) - ((cabal hash) (read-cabal-and-hash port))) + (let* ((name version (package-name->name+version name-version)) + (url (hackage-cabal-url name version)) + (port _ (http-fetch url)) + (cabal hash (read-cabal-and-hash port))) (close-port port) (values cabal hash)))) @@ -159,7 +160,7 @@ version. On failure, both return values will be #f." "Return the Cabal file for the package NAME-VERSION, or #f on failure. If the version part is omitted from the package name, then return the latest version." - (let-values (((cabal hash) (hackage-fetch-and-hash name-version))) + (let ((cabal hash (hackage-fetch-and-hash name-version))) cabal)) (define string->license @@ -248,23 +249,18 @@ the hash of the Cabal file." (hackage-source-url name version)) (define hackage-dependencies - ((compose (cut filter-dependencies <> - (cabal-package-name cabal)) - (cut cabal-dependencies->names <>)) - cabal)) + (filter-dependencies (cabal-dependencies->names cabal) + (cabal-package-name cabal))) (define hackage-native-dependencies (lset-difference equal? - ((compose (cut filter-dependencies <> - (cabal-package-name cabal)) - ;; FIXME: Check include-test-dependencies? - (lambda (cabal) - (append (if include-test-dependencies? - (cabal-test-dependencies->names cabal) - '()) - (cabal-custom-setup-dependencies->names cabal)))) - cabal) + (filter-dependencies + (append (if include-test-dependencies? + (cabal-test-dependencies->names cabal) + '()) + (cabal-custom-setup-dependencies->names cabal)) + (cabal-package-name cabal)) hackage-dependencies)) (define dependencies @@ -333,14 +329,16 @@ symbol 'true' or 'false'. The value associated with other keys has to conform to the Cabal file format definition. The default value associated with the keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\" respectively." - (let-values (((cabal-meta cabal-hash) - (if port - (read-cabal-and-hash port) - (hackage-fetch-and-hash package-name)))) - (and=> cabal-meta (compose (cut hackage-module->sexp <> cabal-hash - #:include-test-dependencies? - include-test-dependencies?) - (cut eval-cabal <> cabal-environment))))) + (let ((cabal-meta cabal-hash + (if port + (read-cabal-and-hash port) + (hackage-fetch-and-hash package-name)))) + (if cabal-meta + (hackage-module->sexp (eval-cabal cabal-meta cabal-environment) + cabal-hash + #:include-test-dependencies? + include-test-dependencies?) + (values #f '())))) (define hackage->guix-package/m ;memoized variant (memoize hackage->guix-package)) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index a6f6fe8c9f..f569c921b1 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> -;;; Copyright © 2021 Alice Brenon <alice.brenon@ens-lyon.fr> +;;; Copyright © 2021, 2022 Alice Brenon <alice.brenon@ens-lyon.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,7 +42,11 @@ #:use-module ((guix utils) #:select (cache-directory version>? call-with-temporary-output-file)) - #:use-module (guix import utils) + #:use-module ((guix import utils) #:select (beautify-description + guix-hash-url + recursive-import + spdx-string->license + url-fetch)) #:use-module ((guix licenses) #:prefix license:) #:export (opam->guix-package opam-recursive-import diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index b4284f5c33..77b5f12f72 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> -;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> @@ -11,6 +11,8 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> +;;; Copyright © 2022 Vivien Kraus <vivien@planete-kraus.eu> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,6 +43,7 @@ #: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) @@ -59,6 +62,7 @@ specification->requirement-name guix-package->pypi-name pypi-recursive-import + find-project-url pypi->guix-package %pypi-updater)) @@ -418,6 +422,24 @@ return the unaltered list of upstream dependency names." (values (map process-requirements dependencies) (concatenate dependencies)))) +(define (find-project-url name pypi-url) + "Try different project name substitution until the result is found in +pypi-uri. Downcase is required for \"uWSGI\", and +underscores are required for flake8-array-spacing." + (or (find (cut string-contains pypi-url <>) + (list name + (string-downcase name) + (string-replace-substring name "-" "_"))) + (begin + (warning + (G_ "project name ~a does not appear verbatim in the PyPI URI~%") + name) + (display-hint + (format #f (G_ "The PyPI URI is: @url{~a}. You should review the +pypi-uri declaration in the generated package. You may need to replace ~s with +a substring of the PyPI URI that identifies the package.") pypi-url name)) +name))) + (define (make-pypi-sexp name version source-url wheel-url home-page synopsis description license) "Return the `package' s-expression for a python package with the given NAME, @@ -446,15 +468,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (origin (method url-fetch) (uri (pypi-uri - ;; PyPI URL are case sensitive, but sometimes - ;; a project named using mixed case has a URL - ;; using lower case, so we must work around this - ;; inconsistency. For actual examples, compare - ;; the URLs of the "Deprecated" and "uWSGI" PyPI - ;; packages. - ,(if (string-contains source-url name) - name - (string-downcase name)) + ,(find-project-url name source-url) version ;; Some packages have been released as `.zip` ;; instead of the more common `.tar.gz`. For @@ -483,21 +497,37 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (let* ((project (pypi-fetch package-name)) (info (and=> project pypi-project-info)) (version (or version (and=> project latest-version)))) - (and project - (guard (c ((missing-source-error? c) - (let ((package (missing-source-error-package c))) - (leave (G_ "no source release for pypi package ~a ~a~%") - (project-info-name info) version)))) - (make-pypi-sexp (project-info-name info) version - (and=> (source-release project version) - distribution-url) - (and=> (wheel-release project version) - distribution-url) - (project-info-home-page info) - (project-info-summary info) - (project-info-summary info) - (string->license - (project-info-license info))))))))) + (if project + (guard (c ((missing-source-error? c) + (let ((package (missing-source-error-package c))) + (raise + (apply + make-compound-condition + (formatted-message + (G_ "no source release for pypi package ~a ~a~%") + (project-info-name info) version) + (match (project-info-home-page info) + ((or #f "") '()) + (url + (list + (condition + (&fix-hint + (hint (format #f (G_ "This indicates that the +package is available on PyPI, but only as a \"wheel\" containing binaries, not +source. To build it from source, refer to the upstream repository at +@uref{~a}.") + url)))))))))))) + (make-pypi-sexp (project-info-name info) version + (and=> (source-release project version) + distribution-url) + (and=> (wheel-release project version) + distribution-url) + (project-info-home-page info) + (project-info-summary info) + (project-info-summary info) + (string->license + (project-info-license info)))) + (values #f '())))))) (define* (pypi-recursive-import package-name #:optional version) (recursive-import package-name diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 1c3cfa3e0b..9cadbb3d5f 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2022 Alice Brenon <alice.brenon@ens-lyon.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,10 +38,11 @@ #:use-module (guix discovery) #:use-module (guix build-system) #:use-module (guix gexp) + #:use-module ((guix i18n) #:select (G_)) #:use-module (guix store) #:use-module (guix download) #:use-module (guix sets) - #:use-module (guix ui) + #:use-module ((guix ui) #:select (fill-paragraph)) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -241,6 +243,9 @@ with dashes." a proper sentence and by using two spaces between sentences, and wrap lines at LENGTH characters." (let ((cleaned (cond + ((not (string? description)) + (G_ "This package lacks a description. Run \ +\"info '(guix) Synopses and Descriptions'\" for more information.")) ((string-prefix? "A " description) (string-append "This package provides a" (substring description 1))) diff --git a/guix/inferior.scm b/guix/inferior.scm index 572114f626..6949bb3687 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -55,7 +55,6 @@ #:use-module (srfi srfi-71) #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) - #:use-module (ice-9 popen) #:use-module (ice-9 vlist) #:use-module (ice-9 binary-ports) #:use-module ((rnrs bytevectors) #:select (string->utf8)) @@ -112,14 +111,19 @@ ;; Inferior Guix process. (define-record-type <inferior> - (inferior pid socket close version packages table) + (inferior pid socket close version packages table + bridge-socket) inferior? (pid inferior-pid) (socket inferior-socket) (close inferior-close-socket) ;procedure (version inferior-version) ;REPL protocol version (packages inferior-package-promise) ;promise of inferior packages - (table inferior-package-table)) ;promise of vhash + (table inferior-package-table) ;promise of vhash + + ;; Bridging with a store. + (bridge-socket inferior-bridge-socket ;#f | port + set-inferior-bridge-socket!)) (define (write-inferior inferior port) (match inferior @@ -130,37 +134,69 @@ (set-record-type-printer! <inferior> write-inferior) +(define (open-bidirectional-pipe command . args) + "Open a bidirectional pipe to COMMAND invoked with ARGS and return it, as a +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) + ((parent . child) + (match (primitive-fork) + (0 + (dynamic-wind + (lambda () + #t) + (lambda () + (close-port parent) + (close-fdes 0) + (close-fdes 1) + (dup2 (fileno child) 0) + (dup2 (fileno child) 1) + ;; Mimic 'open-pipe*'. + (unless (file-port? (current-error-port)) + (close-fdes 2) + (dup2 (open-fdes "/dev/null" O_WRONLY) 2)) + (apply execlp command command args)) + (lambda () + (primitive-_exit 127)))) + (pid + (close-port child) + (values parent pid)))))) + (define* (inferior-pipe directory command error-port) - "Return an input/output pipe on the Guix instance in DIRECTORY. This runs -'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if -it's an old Guix." - (let ((pipe (with-error-to-port error-port - (lambda () - (open-pipe* OPEN_BOTH - (string-append directory "/" command) - "repl" "-t" "machine"))))) + "Return two values: an input/output pipe on the Guix instance in DIRECTORY +and its PID. This runs 'DIRECTORY/COMMAND repl' if it exists, or falls back +to some other method if it's an old Guix." + (let ((pipe pid (with-error-to-port error-port + (lambda () + (open-bidirectional-pipe + (string-append directory "/" command) + "repl" "-t" "machine"))))) (if (eof-object? (peek-char pipe)) (begin - (close-pipe pipe) + (close-port pipe) ;; Older versions of Guix didn't have a 'guix repl' command, so ;; emulate it. (with-error-to-port error-port (lambda () - (open-pipe* OPEN_BOTH "guile" - "-L" (string-append directory "/share/guile/site/" - (effective-version)) - "-C" (string-append directory "/share/guile/site/" - (effective-version)) - "-C" (string-append directory "/lib/guile/" - (effective-version) "/site-ccache") - "-c" - (object->string - `(begin - (primitive-load ,(search-path %load-path - "guix/repl.scm")) - ((@ (guix repl) machine-repl)))))))) - pipe))) + (open-bidirectional-pipe + "guile" + "-L" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/lib/guile/" + (effective-version) "/site-ccache") + "-c" + (object->string + `(begin + (primitive-load ,(search-path %load-path + "guix/repl.scm")) + ((@ (guix repl) machine-repl)))))))) + (values pipe pid)))) (define* (port->inferior pipe #:optional (close close-port)) "Given PIPE, an input/output port, return an inferior that talks over PIPE. @@ -172,7 +208,8 @@ inferior." (('repl-version 0 rest ...) (letrec ((result (inferior 'pipe pipe close (cons 0 rest) (delay (%inferior-packages result)) - (delay (%inferior-package-table result))))) + (delay (%inferior-package-table result)) + #f))) ;; For protocol (0 1) and later, send the protocol version we support. (match rest @@ -188,6 +225,40 @@ inferior." (inferior-eval '(use-modules (srfi srfi-34)) result) (inferior-eval '(define %package-table (make-hash-table)) result) + (inferior-eval '(begin + (define %store-table (make-hash-table)) + (define (cached-store-connection store-id version) + ;; Cache connections to store ID. This ensures that + ;; the caches within <store-connection> (in + ;; particular the object cache) are reused across + ;; calls to 'inferior-eval-with-store', which makes a + ;; significant difference when it is called + ;; repeatedly. + (or (hashv-ref %store-table store-id) + + ;; 'port->connection' appeared in June 2018 and + ;; we can hardly emulate it on older versions. + ;; Thus fall back to 'open-connection', at the + ;; risk of talking to the wrong daemon or having + ;; our build result reclaimed (XXX). + (let ((store (if (defined? 'port->connection) + (port->connection %bridge-socket + #:version + version) + (open-connection)))) + (hashv-set! %store-table store-id store) + store)))) + result) + (inferior-eval '(begin + (define store-protocol-error? + (if (defined? 'store-protocol-error?) + store-protocol-error? + nix-protocol-error?)) + (define store-protocol-error-message + (if (defined? 'store-protocol-error-message) + store-protocol-error-message + nix-protocol-error-message))) + result) result)) (_ #f))) @@ -197,15 +268,20 @@ inferior." (error-port (%make-void-port "w"))) "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or equivalent. Return #f if the inferior could not be launched." - (define pipe - (inferior-pipe directory command error-port)) - - (port->inferior pipe close-pipe)) + (let ((pipe pid (inferior-pipe directory command error-port))) + (port->inferior pipe + (lambda (port) + (close-port port) + (waitpid pid))))) (define (close-inferior inferior) "Close INFERIOR." (let ((close (inferior-close-socket inferior))) - (close (inferior-socket inferior)))) + (close (inferior-socket inferior)) + + ;; Close and delete the store bridge, if any. + (when (inferior-bridge-socket inferior) + (close-port (inferior-bridge-socket inferior))))) ;; Non-self-quoting object of the inferior. (define-record-type <inferior-object> @@ -497,22 +573,32 @@ is similar to the sexp returned by 'package-provenance' for regular packages." 'package-provenance)))) (or provenance (const #f))))) -(define (proxy client backend) ;adapted from (guix ssh) - "Proxy communication between CLIENT and BACKEND until CLIENT closes the -connection, at which point CLIENT is closed (both CLIENT and BACKEND must be -input/output ports.)" +(define (proxy inferior store) ;adapted from (guix ssh) + "Proxy communication between INFERIOR and STORE, until the connection to +STORE is closed or INFERIOR has data available for input (a REPL response)." + (define client + (inferior-bridge-socket inferior)) + (define backend + (store-connection-socket store)) + (define response-port + (inferior-socket inferior)) + ;; Use buffered ports so that 'get-bytevector-some' returns up to the ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. (setvbuf client 'block 65536) (setvbuf backend 'block 65536) + ;; RESPONSE-PORT may typically contain a leftover newline that 'read' didn't + ;; consume. Drain it so that 'select' doesn't immediately stop. + (drain-input response-port) + (let loop () - (match (select (list client backend) '() '()) + (match (select (list client backend response-port) '() '()) ((reads () ()) (when (memq client reads) (match (get-bytevector-some client) ((? eof-object?) - (close-port client)) + #t) (bv (put-bytevector backend bv) (force-output backend)))) @@ -521,70 +607,77 @@ input/output ports.)" (bv (put-bytevector client bv) (force-output client)))) - (unless (port-closed? client) + (unless (or (port-closed? client) + (memq response-port reads)) (loop)))))) -(define (inferior-eval-with-store inferior store code) - "Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must -thus be the code of a one-argument procedure that accepts a store." - ;; Create a named socket in /tmp and let INFERIOR connect to it and use it - ;; as its store. This ensures the inferior uses the same store, with the - ;; same options, the same per-session GC roots, etc. +(define (open-store-bridge! inferior) + "Open a \"store bridge\" for INFERIOR--a named socket in /tmp that will be +used to proxy store RPCs from the inferior to the store of the calling +process." + ;; Create a named socket in /tmp to let INFERIOR connect to it and use it as + ;; its store. This ensures the inferior uses the same store, with the same + ;; options, the same per-session GC roots, etc. ;; FIXME: This strategy doesn't work for remote inferiors (SSH). (call-with-temporary-directory (lambda (directory) (chmod directory #o700) - (let* ((name (string-append directory "/inferior")) - (socket (socket AF_UNIX SOCK_STREAM 0)) - (major (store-connection-major-version store)) - (minor (store-connection-minor-version store)) - (proto (logior major minor))) + (let ((name (string-append directory "/inferior")) + (socket (socket AF_UNIX SOCK_STREAM 0))) (bind socket AF_UNIX name) - (listen socket 1024) + (listen socket 2) + (send-inferior-request - `(let ((proc ,code) - (socket (socket AF_UNIX SOCK_STREAM 0)) - (error? (if (defined? 'store-protocol-error?) - store-protocol-error? - nix-protocol-error?)) - (error-message (if (defined? 'store-protocol-error-message) - store-protocol-error-message - nix-protocol-error-message))) - (connect socket AF_UNIX ,name) - - ;; 'port->connection' appeared in June 2018 and we can hardly - ;; emulate it on older versions. Thus fall back to - ;; 'open-connection', at the risk of talking to the wrong daemon or - ;; having our build result reclaimed (XXX). - (let ((store (if (defined? 'port->connection) - (port->connection socket #:version ,proto) - (open-connection)))) - (dynamic-wind - (const #t) - (lambda () - ;; Serialize '&store-protocol-error' conditions. The - ;; exception serialization mechanism that - ;; 'read-repl-response' expects is unsuitable for SRFI-35 - ;; error conditions, hence this special case. - (guard (c ((error? c) - `(store-protocol-error ,(error-message c)))) - `(result ,(proc store)))) - (lambda () - (close-connection store) - (close-port socket))))) + `(define %bridge-socket + (let ((socket (socket AF_UNIX SOCK_STREAM 0))) + (connect socket AF_UNIX ,name) + socket)) inferior) (match (accept socket) ((client . address) - (proxy client (store-connection-socket store)))) - (close-port socket) - - (match (read-inferior-response inferior) - (('store-protocol-error message) - (raise (condition - (&store-protocol-error (message message) - (status 1))))) - (('result result) - result)))))) + (close-port socket) + (set-inferior-bridge-socket! inferior client))) + (read-inferior-response inferior))))) + +(define (ensure-store-bridge! inferior) + "Ensure INFERIOR has a connected bridge." + (or (inferior-bridge-socket inferior) + (begin + (open-store-bridge! inferior) + (inferior-bridge-socket inferior)))) + +(define (inferior-eval-with-store inferior store code) + "Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must +thus be the code of a one-argument procedure that accepts a store." + (let* ((major (store-connection-major-version store)) + (minor (store-connection-minor-version store)) + (proto (logior major minor)) + + ;; The address of STORE itself is not a good identifier because it + ;; keeps changing through the use of "functional caches". The + ;; address of its socket port makes more sense. + (store-id (object-address (store-connection-socket store)))) + (ensure-store-bridge! inferior) + (send-inferior-request + `(let ((proc ,code) + (store (cached-store-connection ,store-id ,proto))) + ;; Serialize '&store-protocol-error' conditions. The exception + ;; serialization mechanism that 'read-repl-response' expects is + ;; unsuitable for SRFI-35 error conditions, hence this special case. + (guard (c ((store-protocol-error? c) + `(store-protocol-error + ,(store-protocol-error-message c)))) + `(result ,(proc store)))) + inferior) + (proxy inferior store) + + (match (read-inferior-response inferior) + (('store-protocol-error message) + (raise (condition + (&store-protocol-error (message message) + (status 1))))) + (('result result) + result)))) (define* (inferior-package-derivation store package #:optional diff --git a/guix/lint.scm b/guix/lint.scm index 8615bb916c..767083a0ff 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -34,6 +34,7 @@ #:use-module (guix store) #:autoload (guix base16) (bytevector->base16-string) #:use-module (guix base32) + #:use-module (guix build-system) #:use-module (guix diagnostics) #:use-module (guix download) #:use-module (guix ftp-client) @@ -279,6 +280,16 @@ superfluous when building natively and incorrect when cross-compiling." (eq? tests? #t)) (package-arguments package))) (if (and (tests-explicitly-enabled?) + ;; emacs-build-system sets #:tests? #f by default, therefore + ;; writing #:tests? #t in package definitions using + ;; emacs-build-system is reasonable. Likewise for + ;; texlive-build-system. + ;; + ;; Compare the name of the build system instead of the build system + ;; itself to avoid loading unnecessary modules when only a few + ;; modules are linted. + (not (memq (build-system-name (package-build-system package)) + '(emacs texlive))) ;; Some packages, e.g. gnutls, set #:tests? ;; differently depending on whether it is being ;; cross-compiled. diff --git a/guix/man-db.scm b/guix/man-db.scm index a6528e4431..7d9707a592 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -110,7 +110,12 @@ ;; Write ENTRIES in sorted order so we get deterministic output. (for-each (lambda (entry) (gdbm-set! db - (string-append (mandb-entry-file-name entry) + ;; For the 'whatis' tool to find anything, the key + ;; should match the name of the software, + ;; e.g. 'cat'. Derive it from the file name, as + ;; the name could technically be #f. + (string-append (abbreviate-file-name + (mandb-entry-file-name entry)) "\x00") (entry->string entry))) (sort entries mandb-entry<?)) diff --git a/guix/packages.scm b/guix/packages.scm index 9d5b23eb8a..1c63eb2d3e 100644 --- a/guix/packages.scm +++ b/guix/packages.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 © 2014, 2015, 2017, 2018, 2019 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> @@ -7,6 +7,7 @@ ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -182,8 +183,16 @@ ;; The 'source-module-closure' procedure ca. 1.2.0 did not recognize ;; #:re-export-and-replace: <https://issues.guix.gnu.org/52694>. -;; Work around it. -(module-re-export! (current-module) '(delete) #:replace? #t) +;; Work around it. The #:replace? argument is only supported by +;; Guile 2.2.7 and later, work-around it if necessary to allow +;; time-travel from 1.1.0, see <https://issues.guix.gnu.org/53765>. +(let ((major (string->number (major-version)))) + (if (or (>= major 3) + (and (= major 2) + (= (string->number (minor-version)) 2) ; there is no Guile 2.3.X + (>= (string->number (micro-version)) 7))) + (module-re-export! (current-module) '(delete) #:replace? #t) + (module-re-export! (current-module) '(delete)))) ;;; Commentary: ;;; @@ -1091,11 +1100,11 @@ otherwise." "Replace input NAME by REPLACEMENT within INPUTS." (map (lambda (input) (match input - (((? string? label) . _) + (((? string? label) _ . outputs) (if (string=? label name) (match replacement ;does REPLACEMENT specify an output? ((_ _) (cons label replacement)) - (_ (list label replacement))) + (_ (cons* label replacement outputs))) input)))) inputs)) @@ -1235,7 +1244,7 @@ in INPUTS and their transitive propagated inputs." (_ systems))) (package-supported-systems package) - (bag-direct-inputs (package->bag package)))))) + (bag-direct-inputs (package->bag package system #f)))))) supported-systems) diff --git a/guix/profiles.scm b/guix/profiles.scm index 1d354ecb78..bad9b95519 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,10 +1,10 @@ ;;; 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 © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> -;;; Copyright © 2016, 2018, 2019, 2021 Ricardo Wurmus <rekado@elephly.net> +;;; 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> @@ -33,7 +33,7 @@ #:use-module ((guix utils) #:hide (package-name->name+version)) #:use-module ((guix build utils) #:select (package-name->name+version mkdir-p)) - #:use-module ((guix diagnostics) #:select (&fix-hint)) + #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message)) #:use-module (guix i18n) #:use-module (guix records) #:use-module (guix packages) @@ -1738,8 +1738,8 @@ MANIFEST contains the \"man-db\" package. Otherwise, return #f." (manual-database manifest) (return #f)))) -(define (texlive-configuration manifest) - "Return a derivation that builds a TeXlive configuration for the entries in +(define (texlive-font-maps manifest) + "Return a derivation that builds the TeX Live font maps for the entries in MANIFEST." (define entry->texlive-input (match-lambda @@ -1752,6 +1752,8 @@ MANIFEST." (module-ref (resolve-interface '(gnu packages tex)) 'texlive-bin)) (define coreutils (module-ref (resolve-interface '(gnu packages base)) 'coreutils)) + (define grep + (module-ref (resolve-interface '(gnu packages base)) 'grep)) (define sed (module-ref (resolve-interface '(gnu packages base)) 'sed)) (define updmap.cfg @@ -1768,72 +1770,72 @@ MANIFEST." ;; Build a modifiable union of all texlive inputs. We do this so ;; that TeX live can resolve the parent and grandparent directories ;; correctly. There might be a more elegant way to accomplish this. - (union-build #$output + (union-build "/tmp/texlive" '#$(append-map entry->texlive-input (manifest-entries manifest)) #:create-all-directories? #t #:log-port (%make-void-port "w")) - (let ((texmf.cnf (string-append - #$output - "/share/texmf-dist/web2c/texmf.cnf"))) - (when (file-exists? texmf.cnf) - (substitute* texmf.cnf - (("^TEXMFROOT = .*") - (string-append "TEXMFROOT = " #$output "/share\n")) - (("^TEXMF = .*") - "TEXMF = $TEXMFROOT/share/texmf-dist\n")) - - ;; XXX: This is annoying, but it's necessary because texlive-bin - ;; does not provide wrapped executables. - (setenv "PATH" - (string-append #$(file-append coreutils "/bin") - ":" - #$(file-append sed "/bin"))) - (setenv "PERL5LIB" #$(file-append texlive-bin "/share/tlpkg")) - (setenv "TEXMF" (string-append #$output "/share/texmf-dist")) - - ;; Remove invalid maps from config file. - (let* ((web2c (string-append #$output "/share/texmf-config/web2c/")) - (maproot (string-append #$output "/share/texmf-dist/fonts/map/")) - (updmap.cfg (string-append web2c "updmap.cfg"))) - (mkdir-p web2c) - - ;; Some profiles may already have this file, which prevents us - ;; from copying it. Since we need to generate it from scratch - ;; anyway, we delete it here. - (when (file-exists? updmap.cfg) - (delete-file updmap.cfg)) - (copy-file #$updmap.cfg updmap.cfg) - (make-file-writable updmap.cfg) - (let* ((port (open-pipe* OPEN_WRITE - #$(file-append texlive-bin "/bin/updmap-sys") - "--syncwithtrees" - "--nohash" - "--force" - (string-append "--cnffile=" web2c "updmap.cfg")))) - (display "Y\n" port) - (when (not (zero? (status:exit-val (close-pipe port)))) - (error "failed to filter updmap.cfg"))) - - ;; Generate font maps. - (invoke #$(file-append texlive-bin "/bin/updmap-sys") - (string-append "--cnffile=" web2c "updmap.cfg") - (string-append "--dvipdfmxoutputdir=" - maproot "updmap/dvipdfmx/") - (string-append "--dvipsoutputdir=" - maproot "updmap/dvips/") - (string-append "--pdftexoutputdir=" - maproot "updmap/pdftex/"))))) - #t))) + + ;; XXX: This is annoying, but it's necessary because texlive-bin + ;; does not provide wrapped executables. + (setenv "PATH" + (string-append #$(file-append coreutils "/bin") + ":" + #$(file-append grep "/bin") + ":" + #$(file-append sed "/bin"))) + (setenv "PERL5LIB" #$(file-append texlive-bin "/share/tlpkg")) + (setenv "GUIX_TEXMF" "/tmp/texlive/share/texmf-dist") + + ;; Remove invalid maps from config file. + (let* ((web2c (string-append #$output "/share/texmf-dist/web2c/")) + (maproot (string-append #$output "/share/texmf-dist/fonts/map/")) + (updmap.cfg (string-append web2c "updmap.cfg"))) + (mkdir-p web2c) + (copy-file #$updmap.cfg updmap.cfg) + (make-file-writable updmap.cfg) + (let* ((port (open-pipe* OPEN_WRITE + #$(file-append texlive-bin "/bin/updmap-sys") + "--syncwithtrees" + "--nohash" + "--force" + (string-append "--cnffile=" updmap.cfg)))) + (display "Y\n" port) + (when (not (zero? (status:exit-val (close-pipe port)))) + (error "failed to filter updmap.cfg"))) + + ;; Generate font maps. + (invoke #$(file-append texlive-bin "/bin/updmap-sys") + (string-append "--cnffile=" updmap.cfg) + (string-append "--dvipdfmxoutputdir=" + maproot "dvipdfmx/updmap") + (string-append "--dvipsoutputdir=" + maproot "dvips/updmap") + (string-append "--pdftexoutputdir=" + maproot "pdftex/updmap")) + + ;; Create ls-R file. I know, that's not *just* for font maps, but + ;; we've generated new files, so there's no point in running it + ;; any earlier. The ls-R file must act on a full TeX Live tree, + ;; but we have two: the one in /tmp containing all packages and + ;; the one in #$output containing the generated font maps. To + ;; avoid having to merge ls-R files, we copy the generated stuff + ;; to /tmp and run mktexlsr only once. + (let ((a (string-append #$output "/share/texmf-dist")) + (b "/tmp/texlive/share/texmf-dist") + (mktexlsr #$(file-append texlive-bin "/bin/mktexlsr"))) + (copy-recursively a b) + (invoke mktexlsr b) + (install-file (string-append b "/ls-R") a)))))) (mlet %store-monad ((texlive-base (manifest-lookup-package manifest "texlive-base"))) (if texlive-base - (gexp->derivation "texlive-configuration" build + (gexp->derivation "texlive-font-maps" build #:substitutable? #f #:local-build? #t #:properties `((type . profile-hook) - (hook . texlive-configuration))) + (hook . texlive-font-maps))) (return #f)))) (define %default-profile-hooks @@ -1849,6 +1851,7 @@ MANIFEST." glib-schemas gtk-icon-themes gtk-im-modules + texlive-font-maps xdg-desktop-database xdg-mime-database)) @@ -1857,6 +1860,7 @@ MANIFEST." (name "profile") (hooks %default-profile-hooks) (locales? #t) + (allow-unsupported-packages? #f) (allow-collisions? #f) (relative-symlinks? #f) system target) @@ -1865,7 +1869,9 @@ the given MANIFEST. The profile includes additional derivations returned by the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc. Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if entries in MANIFEST collide (for instance if there are two same-name packages -with a different version number.) +with a different version number.) Unless ALLOW-UNSUPPORTED-PACKAGES? is true +or TARGET is set, raise an error if MANIFEST contains a package that does not +support SYSTEM. When LOCALES? is true, the build is performed under a UTF-8 locale; this adds a dependency on the 'glibc-utf8-locales' package. @@ -1875,12 +1881,27 @@ This is one of the things to do for the result to be relocatable. When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST are cross-built for TARGET." + (define (check-supported-packages system) + ;; Raise an error if a package in MANIFEST does not support SYSTEM. + (map-manifest-entries + (lambda (entry) + + (match (manifest-entry-item entry) + ((? package? package) + (unless (supported-package? package system) + (raise (formatted-message (G_ "package ~a does not support ~a") + (package-full-name package) system)))) + (_ #t))) + manifest)) + (mlet* %store-monad ((system (if system (return system) (current-system))) (target (if target (return target) (current-target-system))) + (ok? -> (or allow-unsupported-packages? target + (check-supported-packages system))) (ok? (if allow-collisions? (return #t) (check-for-collisions manifest system @@ -2037,9 +2058,14 @@ paths." (make-regexp (string-append "^" (regexp-quote (basename profile)) "-([0-9]+)"))) -(define (generation-number profile) - "Return PROFILE's number or 0. An absolute file name must be used." - (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) +(define* (generation-number profile + #:optional (base-profile profile)) + "Return PROFILE's number or 0. An absolute file name must be used. + +Optionally, if BASE-PROFILE is provided, use it instead of PROFILE to +construct the regexp matching generations. This is useful in special cases +like: (generation-number \"/run/current-system\" %system-profile)." + (or (and=> (false-if-exception (regexp-exec (profile-regexp base-profile) (basename (readlink profile)))) (compose string->number (cut match:substring <> 1))) 0)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 97e2f5a167..d9cdb6e5e0 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> @@ -559,11 +559,29 @@ build." (define things-to-build (map transform (options->things-to-build opts))) + (define warn-if-unsupported + (let ((target (assoc-ref opts 'target))) + (if target + (lambda (package system) + ;; We cannot tell whether PACKAGE supports TARGET. + package) + (lambda (package system) + (match package + ((? package? package) + (unless (supported-package? package system) + (warning (package-location package) + (G_ "package ~a does not support ~a~%") + (package-full-name package) system)) + package) + (x x)))))) + (define (compute-derivation obj system) ;; Compute the derivation of OBJ for SYSTEM. (match obj ((? package? p) - (let ((p (or (and graft? (package-replacement p)) p))) + (let ((p (warn-if-unsupported + (or (and graft? (package-replacement p)) p) + system))) (match src (#f (list (package->derivation store p system))) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 1707622c4f..27478eabc0 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 David Thompson <davet@gnu.org> ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> -;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,18 +24,21 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix grafts) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix diagnostics) #:use-module (guix i18n) #:use-module (ice-9 format) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:export (guix-deploy)) ;;; Commentary: @@ -58,6 +61,9 @@ Perform the deployment specified by FILE.\n")) -V, --version display version information and exit")) (newline) (display (G_ " + -x, --execute execute the following command on all the machines")) + (newline) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (show-bug-report-information)) @@ -70,6 +76,9 @@ Perform the deployment specified by FILE.\n")) (lambda args (show-version-and-exit "guix deploy"))) + (option '(#\x "execute") #f #f + (lambda (opt name arg result) + (alist-cons 'execute-command? #t result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -152,6 +161,74 @@ Perform the deployment specified by FILE.\n")) (info (G_ "successfully deployed ~a~%") (machine-display-name machine)))) +(define (invoke-command store machine command) + "Invoke COMMAND, a list of strings, on MACHINE. Display its output (if any) +and its error code if it's non-zero. Return true if COMMAND succeeded, false +otherwise." + (define invocation + #~(begin + (use-modules (ice-9 match) + (ice-9 rdelim) + (srfi srfi-11)) + + (define (spawn . command) + ;; Spawn COMMAND; return its PID and an input port to read its + ;; standard output and standard error. + (match (pipe) + ((input . output) + (match (pipe) + ((input . output) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port input) + (dup2 (fileno output) 1) + (dup2 (fileno output) 2) + (apply execlp (car command) command)) + (lambda () + (primitive-exit 127)))) + (pid + (close-port output) + (values pid input)))))))) + + ;; XXX: 'open-pipe*' is unsuitable here because it does not capture + ;; stderr, so roll our own. + (let-values (((pid pipe) (spawn #$@command))) + (let loop ((lines '())) + (match (read-line pipe 'concat) + ((? eof-object?) + (list (cdr (waitpid pid)) + (string-concatenate-reverse lines))) + (line + (loop (cons line lines)))))))) + + (match (run-with-store store + (machine-remote-eval machine invocation)) + ((code output) + (match code + ((? zero?) + (info (G_ "~a: command succeeded~%") + (machine-display-name machine))) + ((= status:exit-val code) + (report-error (G_ "~a: command exited with code ~a~%") + (machine-display-name machine) code)) + ((= status:stop-sig signal) + (report-error (G_ "~a: command stopped with signal ~a~%") + signal)) + ((= status:term-sig signal) + (report-error (G_ "~a: command terminated with signal ~a~%") + signal))) + + (unless (string-null? output) + (info (G_ "command output on ~a:~%") + (machine-display-name machine)) + (display output) + (newline)) + + (zero? code)))) + (define-command (guix-deploy . args) (synopsis "deploy operating systems on a set of machines") @@ -159,14 +236,17 @@ Perform the deployment specified by FILE.\n")) (alist-cons 'file arg result)) (with-error-handling - (let* ((opts (parse-command-line args %options (list %default-options) + (let* ((args command (break (cut string=? "--" <>) args)) + (opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) (file (assq-ref opts 'file)) - (machines (and file (load-source-file file)))) + (machines (and file (load-source-file file))) + (execute-command? (assoc-ref opts 'execute-command?))) (unless file (leave (G_ "missing deployment file argument~%"))) - (show-what-to-deploy machines) + (when (and (pair? command) (not execute-command?)) + (leave (G_ "'--' was used by '-x' was not specified~%"))) (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store @@ -176,6 +256,21 @@ Perform the deployment specified by FILE.\n")) #:verbosity (assoc-ref opts 'verbosity)) (parameterize ((%graft? (assq-ref opts 'graft?))) - (map/accumulate-builds store - (cut deploy-machine* store <>) - machines)))))))) + (if execute-command? + (match command + (("--" command ..1) + ;; Exit with zero unless COMMAND failed on one or more + ;; machines. + (exit + (fold (lambda (machine result) + (and (invoke-command store machine command) + result)) + #t + machines))) + (_ + (leave (G_ "'-x' specified but no command given~%")))) + (begin + (show-what-to-deploy machines) + (map/accumulate-builds store + (cut deploy-machine* store <>) + machines)))))))))) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 8943e87099..535875c858 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -429,13 +429,6 @@ package modules, while attempting to retain user package modules." %node-types) (leave (G_ "~a: unknown node type~%") name))) -(define (lookup-backend name) - "Return the graph backend called NAME. Raise an error if it is not found." - (or (find (lambda (backend) - (string=? (graph-backend-name backend) name)) - %graph-backends) - (leave (G_ "~a: unknown backend~%") name))) - (define (list-node-types) "Print the available node types along with their synopsis." (display (G_ "The available node types are:\n")) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index 2312e4d313..af2643014d 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,8 +24,24 @@ #:use-module (gnu packages admin) #:use-module ((gnu services) #:hide (delete)) #:use-module (gnu packages) + #:autoload (gnu packages base) (coreutils) + #:autoload (gnu packages bash) (bash) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:autoload (gnu packages shells) (fish gash zsh) #:use-module (gnu home) #:use-module (gnu home services) + #:autoload (gnu home services shepherd) (home-shepherd-service-type + home-shepherd-configuration-services + shepherd-service-requirement) + #:autoload (guix modules) (source-module-closure) + #:autoload (gnu build linux-container) (call-with-container %namespaces) + #:autoload (gnu system linux-container) (eval/container) + #:autoload (gnu system file-systems) (file-system-mapping + file-system-mapping-source + file-system-mapping->bind-mount + specification->file-system-mapping + %network-file-mappings) + #:autoload (guix self) (make-config.scm) #:use-module (guix channels) #:use-module (guix derivations) #:use-module (guix ui) @@ -33,12 +50,16 @@ #:use-module (guix profiles) #:use-module (guix store) #:use-module (guix utils) + #:autoload (guix graph) (lookup-backend export-graph) #:use-module (guix scripts) #:use-module (guix scripts package) #:use-module (guix scripts build) - #:use-module (guix scripts system search) + #:autoload (guix scripts system search) (service-type->recutils) + #:use-module (guix scripts system reconfigure) #:autoload (guix scripts pull) (channel-commit-hyperlink) - #:use-module (guix scripts home import) + #:autoload (guix scripts system) (service-node-type + shepherd-service-node-type) + #:autoload (guix scripts home import) (import-manifest) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix gexp) @@ -47,6 +68,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:export (guix-home)) @@ -70,6 +92,8 @@ Some ACTIONS support additional ARGS.\n")) (newline) (display (G_ "\ search search for existing service types\n")) + (display (G_ " + container run the home environment configuration in a container\n")) (display (G_ "\ reconfigure switch to a new home environment configuration\n")) (display (G_ "\ @@ -86,13 +110,33 @@ Some ACTIONS support additional ARGS.\n")) build build the home environment without installing anything\n")) (display (G_ "\ import generates a home environment definition from dotfiles\n")) + (display (G_ "\ + extension-graph emit the service extension graph\n")) + (display (G_ "\ + shepherd-graph emit the graph of shepherd services\n")) (show-build-options-help) (display (G_ " -e, --expression=EXPR consider the home-environment EXPR evaluates to instead of reading FILE, when applicable")) (display (G_ " + --allow-downgrades for 'reconfigure', allow downgrades to earlier + channel revisions")) + (newline) + (display (G_ " + -N, --network allow containers to access the network")) + (display (G_ " + --share=SPEC for containers, share writable host file system + according to SPEC")) + (display (G_ " + --expose=SPEC for containers, expose read-only host file system + according to SPEC")) + (newline) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " + --graph-backend=BACKEND + use BACKEND for 'extension-graph' and 'shepherd-graph'")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -127,63 +171,289 @@ Some ACTIONS support additional ARGS.\n")) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '("allow-downgrades") #f #f + (lambda (opt name arg result) + (alist-cons 'validate-reconfigure + warn-about-backward-reconfigure + result))) + (option '("graph-backend") #t #f + (lambda (opt name arg result) + (alist-cons 'graph-backend arg result))) + + ;; Container options. + (option '(#\N "network") #f #f + (lambda (opt name arg result) + (alist-cons 'network? #t result))) + (option '("share") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-mapping + (specification->file-system-mapping arg #t) + result))) + (option '("expose") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-mapping + (specification->file-system-mapping arg #f) + result))) + %standard-build-options)) (define %default-options - `((build-mode . ,(build-mode normal)) - (graft? . #t) + `((graft? . #t) (substitutes? . #t) (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (verbosity . #f) ;default - (debug . 0))) + (debug . 0) + (validate-reconfigure . ,ensure-forward-reconfigure) + (graph-backend . "graphviz"))) + + +;;; +;;; Container. +;;; + +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) + +(define (user-shell) + (match (and=> (or (getenv "SHELL") + (passwd:shell (getpwuid (getuid)))) + basename) + ("zsh" (file-append zsh "/bin/zsh")) + ("fish" (file-append fish "/bin/fish")) + ("gash" (file-append gash "/bin/gash")) + (_ (file-append bash "/bin/bash")))) + +(define %default-system-profile + ;; The "system" profile available when running 'guix home container'. The + ;; activation script currently expects to run "env -0" (XXX), so provide + ;; Coreutils by default. + (delay (profile + (name "home-system-profile") + (content (packages->manifest (list coreutils)))))) + +(define* (spawn-home-container home + #:key + network? + (command '()) + (mappings '()) + (system-profile + (force %default-system-profile))) + "Spawn a login shell within a container running HOME, a home environment. +When COMMAND is a non-empty list, execute it in the container and exit +immediately. Return the exit status of the process in the container." + (define passwd (getpwuid (getuid))) + (define home-directory (or (getenv "HOME") (passwd:dir passwd))) + (define host (gethostname)) + (define uid 1000) + (define gid 1000) + (define user-name (passwd:name passwd)) + (define user-real-name (passwd:gecos passwd)) + + (define (optional-mapping mapping) + (and (file-exists? (file-system-mapping-source mapping)) + mapping)) + + (define network-mappings + (if network? + (filter-map optional-mapping %network-file-mappings) + '())) + + (eval/container + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + '((gnu build accounts) + (guix profiles) + (guix build utils) + (guix build syscalls)) + #:select? not-config?)) + #~(begin + (use-modules (guix build utils) + (gnu build accounts) + ((guix build syscalls) + #:select (set-network-interface-up))) + + (define shell + #$(user-shell)) + + (define term + #$(getenv "TERM")) + + (define passwd + (password-entry + (name #$user-name) + (real-name #$user-real-name) + (uid #$uid) (gid #$gid) (shell shell) + (directory #$home-directory))) + + (define groups + (list (group-entry (name "users") (gid #$gid)) + (group-entry (gid 65534) ;the overflow GID + (name "overflow")))) + + ;; (guix profiles) loads (guix utils), which calls 'getpw' from the + ;; top level. Thus, arrange so that it's loaded after /etc/passwd + ;; has been created. + (module-autoload! (current-module) + '(guix profiles) '(load-profile)) + + ;; Create /etc/passwd for applications that need it, such as mcron. + (mkdir-p "/etc") + (write-passwd (list passwd)) + (write-group groups) + + (unless #$network? + ;; When isolated from the network, provide a minimal /etc/hosts + ;; to resolve "localhost". + (call-with-output-file "/etc/hosts" + (lambda (port) + (display "127.0.0.1 localhost\n" port) + (chmod port #o444)))) + + ;; Set PATH for things that the activation script might expect, such + ;; as "env". + (load-profile #$system-profile) + + (mkdir-p #$home-directory) + (setenv "HOME" #$home-directory) + (setenv "GUIX_NEW_HOME" #$home) + (primitive-load (string-append #$home "/activate")) + (setenv "GUIX_NEW_HOME" #f) + + (when term + ;; Preserve TERM for proper interactive use. + (setenv "TERM" term)) + + (chdir #$home-directory) + + ;; Invoke SHELL with argv[0] starting with "-": that's how shells + ;; figure out that they are login shells! + (execl shell (string-append "-" (basename shell)) + #$@(match command + (() #~()) + ((_ ...) + #~("-c" #$(string-join command)))))))) + + #:namespaces (if network? + (delq 'net %namespaces) ; share host network + %namespaces) + #:mappings (append network-mappings mappings) + #:guest-uid uid + #:guest-gid gid)) ;;; ;;; Actions. ;;; +(define* (export-extension-graph home port + #:key (backend (lookup-backend "graphviz"))) + "Export the service extension graph of HOME to PORT using BACKEND." + (let* ((services (home-environment-services home)) + (home (find (lambda (service) + (eq? (service-kind service) home-service-type)) + services))) + (export-graph (list home) port + #:backend backend + #:node-type (service-node-type services) + #:reverse-edges? #t))) + +(define* (export-shepherd-graph home port + #:key (backend (lookup-backend "graphviz"))) + "Export the graph of shepherd services of HOME to PORT using BACKEND." + (let* ((services (home-environment-services home)) + (root (fold-services services + #:target-type home-shepherd-service-type)) + ;; Get the list of <shepherd-service>. + (shepherds (home-shepherd-configuration-services + (service-value root))) + (sinks (filter (lambda (service) + (null? (shepherd-service-requirement service))) + shepherds))) + (export-graph sinks port + #:backend backend + #:node-type (shepherd-service-node-type shepherds) + #:reverse-edges? #t))) + (define* (perform-action action he #:key dry-run? derivations-only? - use-substitutes?) + use-substitutes? + (graph-backend "graphviz") + (validate-reconfigure ensure-forward-reconfigure) + + ;; Container options. + (file-system-mappings '()) + (container-command '()) + network?) "Perform ACTION for home environment. " (define println (cut format #t "~a~%" <>)) - (mlet* %store-monad - ((he-drv (home-environment-derivation he)) - (drvs (mapm/accumulate-builds lower-object (list he-drv))) - (% (if derivations-only? - (return - (for-each (compose println derivation-file-name) drvs)) - (built-derivations drvs))) - - (he-out-path -> (derivation->output-path he-drv))) - (if (or dry-run? derivations-only?) - (return #f) - (begin - (for-each (compose println derivation->output-path) drvs) - - (case action - ((reconfigure) - (let* ((number (generation-number %guix-home)) - (generation (generation-file-name - %guix-home (+ 1 number)))) - - (switch-symlinks generation he-out-path) - (switch-symlinks %guix-home generation) - (setenv "GUIX_NEW_HOME" he-out-path) - (primitive-load (string-append he-out-path "/activate")) - (setenv "GUIX_NEW_HOME" #f) - (return he-out-path))) - (else - (newline) - (return he-out-path))))))) + (when (eq? action 'reconfigure) + (check-forward-update validate-reconfigure + #:current-channels (home-provenance %guix-home))) + + (case action + ((extension-graph) + (export-extension-graph he (current-output-port) + #:backend (lookup-backend graph-backend))) + ((shepherd-graph) + (export-shepherd-graph he (current-output-port) + #:backend (lookup-backend graph-backend))) + (else + (mlet* %store-monad + ((he-drv (home-environment-derivation he)) + (drvs (mapm/accumulate-builds lower-object (list he-drv))) + (% (if derivations-only? + (return + (for-each (compose println derivation-file-name) drvs)) + (built-derivations drvs))) + + (he-out-path -> (derivation->output-path he-drv))) + (if (or dry-run? derivations-only?) + (return #f) + (case action + ((reconfigure) + (let* ((number (generation-number %guix-home)) + (generation (generation-file-name + %guix-home (+ 1 number)))) + + (switch-symlinks generation he-out-path) + (switch-symlinks %guix-home generation) + (setenv "GUIX_NEW_HOME" he-out-path) + (primitive-load (string-append he-out-path "/activate")) + (setenv "GUIX_NEW_HOME" #f) + (return he-out-path))) + ((container) + (mlet %store-monad ((status (spawn-home-container + he + #:network? network? + #:mappings file-system-mappings + #:command + container-command))) + (match (status:exit-val status) + (0 (return #t)) + ((? integer? n) (return (exit n))) + (#f + (if (status:term-sig status) + (leave (G_ "process terminated with signal ~a~%") + (status:term-sig status)) + (leave (G_ "process stopped with signal ~a~%") + (status:stop-sig status))))))) + (else + (for-each (compose println derivation->output-path) drvs) + (return he-out-path)))))))) (define (process-action action args opts) "Process ACTION, a sub-command, with the arguments are listed in ARGS. @@ -222,6 +492,10 @@ resulting from command-line parsing." (else (leave (G_ "no configuration specified~%"))))))) + (mappings (filter-map (match-lambda + (('file-system-mapping . mapping) mapping) + (_ #f)) + opts)) (dry? (assoc-ref opts 'dry-run?))) (with-store store @@ -237,13 +511,18 @@ resulting from command-line parsing." (mbegin %store-monad (set-guile-for-build (default-guile)) - (case action - (else - (perform-action action home-environment - #:dry-run? dry? - #:derivations-only? (assoc-ref opts 'derivations-only?) - #:use-substitutes? (assoc-ref opts 'substitutes?)) - )))))) + (perform-action action home-environment + #:dry-run? dry? + #:derivations-only? (assoc-ref opts 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:validate-reconfigure + (assoc-ref opts 'validate-reconfigure) + #:graph-backend + (assoc-ref opts 'graph-backend) + #:network? (assoc-ref opts 'network?) + #:file-system-mappings mappings + #:container-command + (or (assoc-ref opts 'container-command) '())))))) (warn-about-disk-space))) @@ -332,7 +611,7 @@ deploy the home environment described by these files.\n") list-generations describe delete-generations roll-back switch-generation search - import) + import container) (alist-cons 'action action result)) (else (leave (G_ "~a: unknown action~%") action)))))) @@ -370,11 +649,28 @@ deploy the home environment described by these files.\n") (fail)))) args)) + (define (parse-args args) + ;; Parse the list of command line arguments ARGS. + + ;; The '--' token is used to separate the command to run from the rest of + ;; the operands. + (let* ((args rest (break (cut string=? "--" <>) args)) + (opts (parse-command-line args %options (list %default-options) + #:argument-handler + parse-sub-command))) + (match rest + (() opts) + (("--") opts) + (("--" command ...) + (match (assoc-ref opts 'action) + ('container + (alist-cons 'container-command command opts)) + (_ + (leave (G_ "~a: extraneous command~%") + (string-join command)))))))) + (with-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options) - #:argument-handler - parse-sub-command)) + (let* ((opts (parse-args args)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 15bd3140ed..575fe8f688 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> -;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Arjan Adriaanse <arjan@adriaan.se> ;;; ;;; This file is part of GNU Guix. @@ -60,19 +60,24 @@ FILE-NAME with \"-\", and return the basename of it." (define (destination-append path) (string-append destination-directory "/" path)) + (define alias-rx + (make-regexp "^alias ([^=]+)=[\"'](.+)[\"']$")) + (define (bash-alias->pair line) - (if (string-prefix? "alias" line) - (let ((matched (string-match "alias (.+)=\"?'?([^\"']+)\"?'?" line))) - `(,(match:substring matched 1) . ,(match:substring matched 2))) - '())) - + (match (regexp-exec alias-rx line) + (#f #f) + (matched + `(,(match:substring matched 1) . ,(match:substring matched 2))))) + (define (parse-aliases input) - (let loop ((line (read-line input)) - (result '())) - (if (eof-object? line) - (reverse result) - (loop (read-line input) - (cons (bash-alias->pair line) result))))) + (let loop ((result '())) + (match (read-line input) + ((? eof-object?) + (reverse result)) + (line + (match (bash-alias->pair line) + (#f (loop result)) + (alias (loop (cons alias result)))))))) (let ((rc (destination-append ".bashrc")) (profile (destination-append ".bash_profile")) @@ -82,9 +87,9 @@ FILE-NAME with \"-\", and return the basename of it." ,@(if (file-exists? rc) `((aliases ',(let* ((port (open-pipe* OPEN_READ "bash" "-i" "-c" "alias")) - (alist (parse-aliases port))) + (alist (parse-aliases port))) (close-port port) - (filter (negate null?) alist)))) + alist))) '()) ,@(if (file-exists? rc) `((bashrc diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm index 328d20b946..82deac16ad 100644 --- a/guix/scripts/import/gem.scm +++ b/guix/scripts/import/gem.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -80,24 +81,26 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n")) (let* ((opts (parse-options)) (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) + (('argument . value) + value) + (_ #f)) (reverse opts)))) (match args ((package-name) - (if (assoc-ref opts 'recursive) - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) - (gem-recursive-import package-name 'rubygems)) - (let ((sexp (gem->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp))) + (let ((code (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (gem-recursive-import package-name 'rubygems)) + (let ((sexp (gem->guix-package package-name))) + (if sexp sexp #f))))) + (match code + ((or #f '(#f)) + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + (_ code)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index a52cd95c93..b9b12ee43a 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -79,27 +79,28 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (let* ((opts (parse-options)) (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) + (('argument . value) + value) + (_ #f)) (reverse opts)))) (match args ((spec) - (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)) - (pypi-recursive-import name version)) - ;; Single import - (let ((sexp (pypi->guix-package name #:version version))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - name)) - sexp)))) + (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)) + (pypi-recursive-import name version)) + ;; Single import + (let ((sexp (pypi->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 ...) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 6e2b4368da..870dfc11e9 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org> -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org> @@ -345,20 +345,10 @@ much needs to be downloaded." (base-info (format #f "\ StorePath: ~a -~{~a~}\ NarHash: sha256:~a NarSize: ~d References: ~a~%" store-path - (map (lambda (compression) - (let ((size (assoc-ref file-sizes - compression))) - (store-item->recutils store-path - #:file-size size - #:nar-path nar-path - #:compression - compression))) - compressions) hash size references)) ;; Do not render a "Deriver" line if we are rendering info for a ;; derivation. Also do not render a "System" line that would be @@ -369,7 +359,22 @@ References: ~a~%" base-info (basename deriver)))) (signature (base64-encode-string (canonical-sexp->string (signed-string info))))) - (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature))) + (format #f "~aSignature: 1;~a;~a~%~{~a~}" + info (gethostname) signature + + ;; Move information about the actual nars + ;; (URL/Compression/FileSize) *after* the normative part that is + ;; signed. That makes it possible to alter these bits of the + ;; narinfo without having to resign them. + (map (lambda (compression) + (let ((size (assoc-ref file-sizes + compression))) + (store-item->recutils store-path + #:file-size size + #:nar-path nar-path + #:compression + compression))) + compressions)))) (define* (not-found request #:key (phrase "Resource not found") diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index fb8ce50fa7..7402782ff3 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2015, 2017-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; @@ -105,6 +105,8 @@ Download and deploy the latest version of Guix.\n")) -l, --list-generations[=PATTERN] list generations matching PATTERN")) (display (G_ " + --details show details when listing generations")) + (display (G_ " --roll-back roll back to the previous generation")) (display (G_ " -d, --delete-generations[=PATTERN] @@ -138,6 +140,13 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (cons `(query list-generations ,arg) result))) + (option '("details") #f #f + (lambda (opt name arg result) + (alist-cons 'details? #t + (if (assoc-ref result 'query) + result + (cons `(query list-generations #f) + result))))) (option '("roll-back") #f #f (lambda (opt name arg result) (cons '(generation roll-back) @@ -152,7 +161,8 @@ Download and deploy the latest version of Guix.\n")) result))) (option '(#\N "news") #f #f (lambda (opt name arg result) - (cons '(query display-news) result))) + (cons '(query display-news) + (alist-delete 'query result)))) (option '("url") #t #f (lambda (opt name arg result) (alist-cons 'repository-url arg @@ -274,7 +284,8 @@ purposes." (texi->plain-text title)) ;; When Texinfo markup is invalid, display it as-is. - (const title))))))) + (const title))) + (or (pager-wrapped-port port) port))))) (define (display-news-entry entry channel language port) "Display ENTRY, a <channel-news-entry> from CHANNEL, in LANGUAGE, a language @@ -286,7 +297,8 @@ code, to PORT." (channel-news-entry-commit entry)) (display-news-entry-title entry language port) - (format port (dim (G_ " commit ~a~%")) + (format port (dim (G_ " commit ~a~%") + (or (pager-wrapped-port port) port)) (if (supports-hyperlinks?) (channel-commit-hyperlink channel commit) commit)) @@ -337,45 +349,48 @@ to display." (previous (and=> (relative-generation profile -1) (cut generation-file-name profile <>)))) - "Display news about the channels of PROFILE compared to PREVIOUS." - (when previous - (let ((old-channels (profile-channels previous)) - (new-channels (profile-channels profile))) - (and (pair? old-channels) (pair? new-channels) - (begin - (match (lset-difference channel=? new-channels old-channels) - (() - #t) - (new - (let ((count (length new))) - (format (current-error-port) - (N_ " ~a new channel:~%" - " ~a new channels:~%" count) - count) - (for-each display-channel new)))) - (match (lset-difference channel=? old-channels new-channels) - (() - #t) - (removed - (let ((count (length removed))) - (format (current-error-port) - (N_ " ~a channel removed:~%" - " ~a channels removed:~%" count) - count) - (for-each display-channel removed)))) - - ;; Display channel-specific news for those channels that were - ;; here before and are still around afterwards. - (for-each (match-lambda - ((new old) - (display-channel-specific-news new old))) - (filter-map (lambda (new) - (define old - (find (cut channel=? new <>) - old-channels)) - - (and old (list new old))) - new-channels))))))) + "Display news about the channels of PROFILE compared to PREVIOUS. Return +true if news were displayed, false otherwise." + (and previous + (let ((old-channels (profile-channels previous)) + (new-channels (profile-channels profile))) + (and (pair? old-channels) (pair? new-channels) + (begin + (match (lset-difference channel=? new-channels old-channels) + (() + #t) + (new + (let ((count (length new))) + (format (current-error-port) + (N_ " ~a new channel:~%" + " ~a new channels:~%" count) + count) + (for-each display-channel new)))) + (match (lset-difference channel=? old-channels new-channels) + (() + #t) + (removed + (let ((count (length removed))) + (format (current-error-port) + (N_ " ~a channel removed:~%" + " ~a channels removed:~%" count) + count) + (for-each display-channel removed)))) + + ;; Display channel-specific news for those channels that were + ;; here before and are still around afterwards. + (fold (match-lambda* + (((new old) news?) + (or (display-channel-specific-news new old) + news?))) + #f + (filter-map (lambda (new) + (define old + (find (cut channel=? new <>) + old-channels)) + + (and old (list new old))) + new-channels))))))) (define* (display-channel-news-headlines profile) "Display the titles of news about the channels of PROFILE compared to its @@ -406,13 +421,26 @@ previous generation. Return true if there are news to display." (any ->bool more?)))))) -(define (display-news profile) - ;; Display profile news, with the understanding that this process represents - ;; the newest generation. - (display-profile-news profile - #:current-is-newer? #t) - - (display-channel-news profile)) +(define* (display-news profile #:key (profile-news? #f)) + "Display channel news for PROFILE compared to its previous generation. When +PROFILE-NEWS? is true, display the list of added/upgraded packages since the +previous generation." + (define previous + (relative-generation profile -1)) + + (if previous + (begin + (when profile-news? + (display-profile-news profile + #:current-is-newer? #t)) + + (unless (display-channel-news profile + (generation-file-name profile previous)) + (info (G_ "no channel news since generation ~a~%") previous) + (display-hint (G_ "Run @command{guix pull -l} to view the +news for earlier generations.")))) + (leave (G_ "profile ~a does not have a previous generation~%") + profile))) (define* (build-and-install instances profile) "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is @@ -430,10 +458,9 @@ true, display what would be built without actually building it." #:hooks %channel-profile-hooks) (return - (let ((more? (list (display-profile-news profile #:concise? #t) - (display-channel-news-headlines profile)))) + (let ((more? (display-channel-news-headlines profile))) (newline) - (when (any ->bool more?) + (when more? (display-hint (G_ "Run @command{guix pull --news} to read all the news."))))) (if guix-command @@ -640,17 +667,23 @@ Return true when there is more package info to display." (define (process-query opts profile) "Process any query on PROFILE specified by OPTS." + (define details? + (assoc-ref opts 'details?)) + (match (assoc-ref opts 'query) (('list-generations pattern) (define (list-generations profile numbers) (match numbers ((first rest ...) (display-profile-content profile first) + (let loop ((numbers numbers)) (match numbers ((first second rest ...) - (display-profile-content-diff profile - first second) + (if details? + (display-profile-content-diff profile + first second) + (display-profile-content profile second)) (display-channel-news (generation-file-name profile second) (generation-file-name profile first)) (loop (cons second rest))) @@ -662,16 +695,23 @@ Return true when there is more package info to display." (raise (condition (&profile-not-found-error (profile profile))))) ((not pattern) - (list-generations profile (profile-generations profile))) + (with-paginated-output-port port + (with-output-to-port port + (lambda () + (list-generations profile (profile-generations profile)))))) ((matching-generations pattern profile) => (match-lambda (() (exit 1)) ((numbers ...) - (list-generations profile numbers))))))) + (with-paginated-output-port port + (with-output-to-port port + (lambda () + (list-generations profile numbers)))))))))) (('display-news) - (display-news profile)))) + (display-news profile + #:profile-news? (assoc-ref opts 'details?))))) (define (process-generation-change opts profile) "Process a request to change the current generation (roll-back, switch, delete)." @@ -754,7 +794,7 @@ Use '~/.config/guix/channels.scm' instead.")) (define-command (guix-pull . args) (synopsis "pull the latest revision of Guix") - (define (no-arguments arg _) + (define (no-arguments arg _) (leave (G_ "~A: extraneous argument~%") arg)) (with-error-handling diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index a92932cbc9..1eab05d737 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -372,6 +372,10 @@ return #f and #f." ;; least depending on external state (with-source, with-commit, etc.), ;; so do not cache anything when they're used. (values #f #f)) + ((('profile . _) . _) + ;; If the user already specified a profile, there's nothing more to + ;; cache. + (values #f #f)) ((('system . system) . rest) (loop rest system file specs)) ((_ . rest) (loop rest system file specs))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 414e931c8a..067bf999f1 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> @@ -51,7 +51,7 @@ delete-matching-generations) #:autoload (guix scripts pull) (channel-commit-hyperlink) #:autoload (guix graph) (export-graph node-type - graph-backend-name %graph-backends) + graph-backend-name lookup-backend) #:use-module (guix scripts graph) #:use-module (guix scripts system reconfigure) #:use-module (guix build utils) @@ -88,7 +88,10 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:export (guix-system - read-operating-system)) + read-operating-system + + service-node-type + shepherd-service-node-type)) ;;; @@ -887,13 +890,6 @@ Run 'herd status' to view the list of services on your system.\n")))))) (register-root* (list output) gc-root)) (return output))))))))) -(define (lookup-backend name) ;TODO: factorize - "Return the graph backend called NAME. Raise an error if it is not found." - (or (find (lambda (backend) - (string=? (graph-backend-name backend) name)) - %graph-backends) - (leave (G_ "~a: unknown backend~%") name))) - (define* (export-extension-graph os port #:key (backend (lookup-backend "graphviz"))) "Export the service extension graph of OS to PORT using BACKEND." @@ -901,7 +897,7 @@ Run 'herd status' to view the list of services on your system.\n")))))) (system (find (lambda (service) (eq? (service-kind service) system-service-type)) services))) - (export-graph (list system) (current-output-port) + (export-graph (list system) port #:backend backend #:node-type (service-node-type services) #:reverse-edges? #t))) @@ -917,7 +913,7 @@ Run 'herd status' to view the list of services on your system.\n")))))) (sinks (filter (lambda (service) (null? (shepherd-service-requirement service))) shepherds))) - (export-graph sinks (current-output-port) + (export-graph sinks port #:backend backend #:node-type (shepherd-service-node-type shepherds) #:reverse-edges? #t))) @@ -1328,9 +1324,17 @@ argument list and OPTS is the option alist." (x (leave (G_ "wrong number of arguments~%")))))) (list-generations pattern))) ((describe) - (match (generation-number %system-profile) + ;; Describe the running system, which is not necessarily the current + ;; generation. /run/current-system might point to + ;; /var/guix/profiles/system-N-link, or it might point directly to + ;; /gnu/store/…-system. Try both. + (match (generation-number "/run/current-system" %system-profile) (0 - (leave (G_ "no system generation, nothing to describe~%"))) + (match (generation-number %system-profile) + (0 + (leave (G_ "no system generation, nothing to describe~%"))) + (generation + (display-system-generation generation)))) (generation (display-system-generation generation)))) ((search) diff --git a/guix/status.scm b/guix/status.scm index eefe18365f..b8905c9542 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -395,8 +395,8 @@ the current build phase." (G_ "building XDG MIME database...")) ('fonts-dir (G_ "building fonts directory...")) - ('texlive-configuration - (G_ "building TeX Live configuration...")) + ('texlive-font-maps + (G_ "building TeX Live font maps...")) ('manual-database (G_ "building database for manual pages...")) ('package-cache ;package cache generated by 'guix pull' @@ -414,6 +414,11 @@ produce colorful output. When PRINT-LOG? is true, display the build log in addition to build events. When PRINT-URLS? is true, display the URL of substitutes being downloaded." (define info + (if (and colorize? (or print-urls? print-log?)) + (cute colorize-string <> (color BOLD)) + identity)) + + (define emph (if colorize? (cute colorize-string <> (color BOLD)) identity)) @@ -483,7 +488,9 @@ substitutes being downloaded." (format port (info (N_ "applying ~a graft for ~a ..." "applying ~a grafts for ~a ..." count)) - count drv))) + count + (string-drop-right (store-path-package-name drv) + (string-length ".drv"))))) ('profile (let ((count (match (assq-ref properties 'profile) (#f 0) @@ -496,7 +503,7 @@ substitutes being downloaded." (let ((hook-type (assq-ref properties 'hook))) (or (and=> (hook-message hook-type) (lambda (msg) - (format port (info msg)))) + (display (info msg) port))) (format port (info (G_ "running profile hook of type '~a'...")) hook-type)))) (_ @@ -524,7 +531,7 @@ substitutes being downloaded." (format port (failure (G_ "Could not find build log for '~a'.")) drv)) (log - (format port (info (G_ "View build log at '~a'.")) log))) + (format port (emph (G_ "View build log at '~a'.")) log))) (newline port)) (('substituter-started item _ ...) (erase-current-line*) @@ -575,12 +582,12 @@ substitutes being downloaded." ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm. (format port (failure (G_ "~a hash mismatch for ~a:")) algo item) (newline port) - (format port (info (G_ "\ + (format port (emph (G_ "\ expected hash: ~a actual hash: ~a~%")) expected actual)) (('build-remote drv host _ ...) - (format port (info (G_ "offloading build of ~a to '~a'")) drv host) + (format port (emph (G_ "offloading build of ~a to '~a'")) drv host) (newline port)) (('build-log pid line) (if (multiplexed-output-supported?) diff --git a/guix/store.scm b/guix/store.scm index a93e9596d9..1d176fb99d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1442,6 +1442,12 @@ When a handler is installed with 'with-build-handler', it is called any time things))) (parameterize ((current-store-protocol-version (store-connection-version store))) + (when (< (current-store-protocol-version) #x163) + ;; This corresponds to the first version bump of the daemon + ;; since the introduction of lzip compression support. The + ;; version change happened with commit 6ef61cc4c30 on the + ;; 2018/10/15). + (warn-about-old-daemon)) (if (>= (store-connection-minor-version store) 15) (build store things mode) (if (= mode (build-mode normal)) diff --git a/guix/tests.scm b/guix/tests.scm index 4cd1ad6cf9..8f6d040f1f 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -85,10 +85,12 @@ "warning: build daemon error: ~s~%" c) #f)) (let ((store (open-connection uri))) - ;; Make sure we build everything by ourselves. + ;; Make sure we build everything by ourselves. When we build something, + ;; it should take at most 5 minutes. (set-build-options store #:use-substitutes? #f - #:substitute-urls (%test-substitute-urls)) + #:substitute-urls (%test-substitute-urls) + #:timeout (* 5 60)) ;; Use the bootstrap Guile when running tests, so we don't end up ;; building everything in the temporary test store. @@ -147,6 +149,9 @@ no external store to talk to." ;; further. (unsetenv "NIX_STORE_DIR")) (lambda () + (when store + ;; Make sure we don't end up rebuilding the world for those tests. + (set-build-options store #:timeout (* 10 60))) (proc store)) (lambda () (when store-variable @@ -472,7 +477,8 @@ to its file name extension. Return both its file name and its hash." (format #t #+content))) (when #+command (invoke #+command #+name-sans-ext)) - (copy-file #+name #$output))))) + (copy-file #+name #$output)) + #:guile %bootstrap-guile))) (file-drv (run-with-store store (lower-object f))) (file (derivation->output-path file-drv)) (file-drv-outputs (derivation-outputs file-drv)) diff --git a/guix/transformations.scm b/guix/transformations.scm index 0976f0d824..a0045e5b27 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -46,6 +46,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -526,10 +527,29 @@ system that builds code for MICRO-ARCHITECTURE; otherwise raise an error." micro-architecture))) (unless (member micro-architecture (or (assoc-ref lst architecture) '())) - (raise (formatted-message - (G_ "compiler ~a does not support micro-architecture ~a") - (package-full-name compiler) - micro-architecture)))) + (raise + (make-compound-condition + (formatted-message + (G_ "compiler ~a does not support micro-architecture ~a") + (package-full-name compiler) + micro-architecture) + (condition + (&fix-hint + (hint (match (assoc-ref lst architecture) + (#f (format #f (G_ "Compiler ~a does not support +micro-architectures of ~a.") + (package-full-name compiler "@@") + architecture)) + (lst + (format #f (G_ "Compiler ~a supports the following ~a +micro-architectures: + +@quotation +~a +@end quotation") + (package-full-name compiler "@@") + architecture + (string-join lst ", "))))))))))) (bag (inherit lowered) diff --git a/guix/ui.scm b/guix/ui.scm index 093de1b4ab..6c194eb3c9 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -124,6 +124,7 @@ file-hyperlink location->hyperlink + pager-wrapped-port with-paginated-output-port relevance package-relevance @@ -1030,29 +1031,38 @@ summary, and level 0 shows nothing." ;; Unfortunately, this is hardly avoidable for proper i18n. (if dry-run? (begin - (unless (zero? verbosity) + (unless (or (zero? verbosity) (null? build)) (format (current-error-port) - (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[The following derivations would be built:~%~{ ~a~%~}~;~]" - (length build)) - (null? build) (map colorized-store-item build))) + (highlight/warn + (N_ "The following derivation would be built:~%" + "The following derivations would be built:~%" + (length build)))) + (format (current-error-port) "~{ ~a~%~}" + (map colorized-store-item build))) (cond ((>= verbosity 2) (if display-download-size? - (format (current-error-port) - ;; TRANSLATORS: "MB" is for "megabyte"; it should be - ;; translated to the corresponding abbreviation. - (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]") - (null? download) - download-size - (map (compose colorized-store-item substitutable-path) - download)) - (format (current-error-port) - (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" - "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" - (length download)) - (null? download) - (map (compose colorized-store-item substitutable-path) - download))) + (begin + (format (current-error-port) + (highlight + ;; TRANSLATORS: "MB" is for "megabyte"; it + ;; should be translated to the corresponding + ;; abbreviation. + (G_ "~:[~,1h MB would be downloaded:~%~;~]")) + (null? download) + download-size) + (format (current-error-port) "~{ ~a~%~}" + (map (compose colorized-store-item substitutable-path) + download))) + (begin + (format (current-error-port) + (highlight + (N_ "~:[The following file would be downloaded:~%~;~]" + "~:[The following files would be downloaded:~%~;~]" + (length download))) + (null? download)) + (format (current-error-port) "~{ ~a~%~}" + (map (compose colorized-store-item substitutable-path) + download)))) (format (current-error-port) (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" @@ -1081,29 +1091,38 @@ summary, and level 0 shows nothing." (null? download) (length download)))))) (begin - (unless (zero? verbosity) + (unless (or (zero? verbosity) (null? build)) (format (current-error-port) - (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[The following derivations will be built:~%~{ ~a~%~}~;~]" - (length build)) - (null? build) (map colorized-store-item build))) + (highlight/warn + (N_ "The following derivation will be built:~%" + "The following derivations will be built:~%" + (length build)))) + (format (current-error-port) "~{ ~a~%~}" + (map colorized-store-item build))) (cond ((>= verbosity 2) (if display-download-size? - (format (current-error-port) - ;; TRANSLATORS: "MB" is for "megabyte"; it should be - ;; translated to the corresponding abbreviation. - (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]") - (null? download) - download-size - (map (compose colorized-store-item substitutable-path) - download)) - (format (current-error-port) - (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" - "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" - (length download)) - (null? download) - (map (compose colorized-store-item substitutable-path) - download))) + (begin + (format (current-error-port) + (highlight + ;; TRANSLATORS: "MB" is for "megabyte"; it + ;; should be translated to the corresponding + ;; abbreviation. + (G_ "~:[~,1h MB will be downloaded:~%~;~]")) + (null? download) + download-size) + (format (current-error-port) "~{ ~a~%~}" + (map (compose colorized-store-item substitutable-path) + download))) + (begin + (format (current-error-port) + (highlight + (N_ "~:[The following file will be downloaded:~%~;~]" + "~:[The following files will be downloaded:~%~;~]" + (length download))) + (null? download)) + (format (current-error-port) "~{ ~a~%~}" + (map (compose colorized-store-item substitutable-path) + download)))) (format (current-error-port) (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" @@ -1665,6 +1684,20 @@ score, the more relevant OBJ is to REGEXPS." zero means that PACKAGE does not match any of REGEXPS." (relevance package regexps %package-metrics)) +(define pager-port-mapping + ;; If a pager is being used, via 'with-paginated-output-port', this maps the + ;; pager port (pipe) to the underlying output port. + (make-parameter #f)) + +(define* (pager-wrapped-port #:optional (port (current-output-port))) + "If PORT is a pipe to a pager created by 'with-paginated-output-port', +return the underlying port. Otherwise return #f." + (match (pager-port-mapping) + ((pager . wrapped) + (and (eq? pager port) wrapped)) + (_ + #f))) + (define* (call-with-paginated-output-port proc #:key (less-options "FrX")) (let ((pager-command-line (or (getenv "GUIX_PAGER") @@ -1691,7 +1724,10 @@ zero means that PACKAGE does not match any of REGEXPS." char-set:whitespace)))))) (dynamic-wind (const #t) - (lambda () (proc pager)) + (lambda () + (parameterize ((pager-port-mapping + (cons pager (current-output-port)))) + (proc pager))) (lambda () (close-pipe pager)))) (proc (current-output-port))))) @@ -1882,7 +1918,9 @@ DURATION-RELATION with the current time." (link (if (supports-hyperlinks?) (cut file-hyperlink file <>) identity)) - (header (format #f (link (highlight (G_ "Generation ~a\t~a"))) + (header (format #f (link (highlight (G_ "Generation ~a\t~a") + (or (pager-wrapped-port) + (current-output-port)))) number (date->string (time-utc->date diff --git a/guix/utils.scm b/guix/utils.scm index cba6464523..44c46cb4a9 100644 --- a/guix/utils.scm +++ b/guix/utils.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 © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> @@ -99,8 +99,10 @@ target-powerpc? target-riscv64? target-64bit? + ar-for-target cc-for-target cxx-for-target + ld-for-target pkg-config-for-target version-compare @@ -454,27 +456,27 @@ This procedure returns #t on success." (str (iconv:bytevector->string (get-bytevector-n in (- end start)) (port-encoding in))) - (post-bv (get-bytevector-all in)) (str* (proc str))) ;; Modify FILE only if there are changes. (unless (string=? str* str) ;; Verify the edited expression is still a scheme expression. (call-with-input-string str* read) - ;; Update the file with edited expression. - (with-atomic-file-output file - (lambda (out) - (put-bytevector out pre-bv) - (display str* out) - ;; post-bv maybe the end-of-file object. - (when (not (eof-object? post-bv)) - (put-bytevector out post-bv)) - #t)) - - ;; Due to 'with-atomic-file-output', IN and FILE no longer share - ;; the same inode, but we can reassign the source map up to LINE - ;; to the new file. - (move-source-location-map! (stat in) (stat file) - (+ 1 line))))))))) + + (let ((post-bv (get-bytevector-all in))) + ;; Update the file with edited expression. + (with-atomic-file-output file + (lambda (out) + (put-bytevector out pre-bv) + (display str* out) + (unless (eof-object? post-bv) + ;; Copy everything that came after STR. + (put-bytevector out post-bv)))) + + ;; Due to 'with-atomic-file-output', IN and FILE no longer + ;; share the same inode, but we can reassign the source map up + ;; to LINE to the new file. + (move-source-location-map! (stat in) (stat file) + (+ 1 line)))))))))) ;;; @@ -715,6 +717,11 @@ architecture (x86_64)?" (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64" "riscv64"))) +(define* (ar-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-ar") + "ar")) + (define* (cc-for-target #:optional (target (%current-target-system))) (if target (string-append target "-gcc") @@ -725,6 +732,11 @@ architecture (x86_64)?" (string-append target "-g++") "g++")) +(define* (ld-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-ld") + "ld")) + (define* (pkg-config-for-target #:optional (target (%current-target-system))) (if target (string-append target "-pkg-config") |