summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/gnu.scm4
-rw-r--r--guix/build-system/texlive.scm13
-rw-r--r--guix/build/emacs-build-system.scm77
-rw-r--r--guix/build/maven/java.scm9
-rw-r--r--guix/build/store-copy.scm2
-rw-r--r--guix/cpu.scm115
-rw-r--r--guix/deprecation.scm8
-rw-r--r--guix/gexp.scm31
-rw-r--r--guix/import/opam.scm8
-rw-r--r--guix/import/pypi.scm49
-rw-r--r--guix/import/utils.scm7
-rw-r--r--guix/inferior.scm273
-rw-r--r--guix/profiles.scm106
-rw-r--r--guix/scripts/deploy.scm111
-rw-r--r--guix/scripts/home.scm37
-rw-r--r--guix/scripts/import/pypi.scm37
-rw-r--r--guix/scripts/system.scm4
-rw-r--r--guix/status.scm4
-rw-r--r--guix/store.scm6
-rw-r--r--guix/tests.scm3
-rw-r--r--guix/utils.scm32
21 files changed, 656 insertions, 280 deletions
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 651415098e..2f74000eef 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -273,7 +273,9 @@ standard packages used as implicit inputs of the GNU build system."
;; Resolve (gnu packages commencement) lazily to hide circular dependency.
(let ((distro (resolve-module '(gnu packages commencement))))
- (module-ref distro '%final-inputs)))
+ (if (target-riscv64?)
+ (module-ref distro '%final-inputs-riscv64)
+ (module-ref distro '%final-inputs))))
(define* (lower name
#:key source inputs native-inputs outputs target
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/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/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/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/gexp.scm b/guix/gexp.scm
index 01dca902f7..dfeadbd15d 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.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 © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -597,13 +597,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 target)))
+ (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 +2068,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 +2077,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 +2119,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)
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..e07b792c53 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,7 @@
;;; 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>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -41,6 +42,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 +61,7 @@
specification->requirement-name
guix-package->pypi-name
pypi-recursive-import
+ find-project-url
pypi->guix-package
%pypi-updater))
@@ -418,6 +421,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 +467,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
@@ -486,8 +499,20 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(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))))
+ (raise
+ (make-compound-condition
+ (formatted-message
+ (G_ "no source release for pypi package ~a ~a~%")
+ (project-info-name info) version)
+ (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}.")
+ (or (project-info-home-page info)
+ (project-info-url info)
+ "?"))))))))))
(make-pypi-sexp (project-info-name info) version
(and=> (source-release project version)
distribution-url)
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)
- (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)
+ (listen socket 2)
- ;; '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)))))
+ (send-inferior-request
+ `(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)
+ (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))))))
+ (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/profiles.scm b/guix/profiles.scm
index 1d354ecb78..86926d6793 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -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
@@ -1768,72 +1768,56 @@ 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"))
+ ;; 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 "GUIX_TEXMF" "/tmp/texlive/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)
+ ;; 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")))
- ;; 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)))
+ ;; 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"))))))
(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 +1833,7 @@ MANIFEST."
glib-schemas
gtk-icon-themes
gtk-im-modules
+ texlive-font-maps
xdg-desktop-database
xdg-mime-database))
@@ -2037,9 +2022,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/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/home.scm b/guix/scripts/home.scm
index 2312e4d313..837fd96361 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -36,7 +36,8 @@
#: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)
#:use-module ((guix status) #:select (with-status-verbosity))
@@ -92,6 +93,9 @@ Some ACTIONS support additional ARGS.\n"))
-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"))
+ (display (G_ "
-v, --verbosity=LEVEL use the given verbosity LEVEL"))
(newline)
(display (G_ "
@@ -127,18 +131,23 @@ 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)))
%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)))
;;;
@@ -149,12 +158,17 @@ Some ACTIONS support additional ARGS.\n"))
#:key
dry-run?
derivations-only?
- use-substitutes?)
+ use-substitutes?
+ (validate-reconfigure ensure-forward-reconfigure))
"Perform ACTION for home environment. "
(define println
(cut format #t "~a~%" <>))
+ (when (eq? action 'reconfigure)
+ (check-forward-update validate-reconfigure
+ #:current-channels (home-provenance %guix-home)))
+
(mlet* %store-monad
((he-drv (home-environment-derivation he))
(drvs (mapm/accumulate-builds lower-object (list he-drv)))
@@ -237,13 +251,12 @@ 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))))))
(warn-about-disk-space)))
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/system.scm b/guix/scripts/system.scm
index 414e931c8a..430815902d 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>
@@ -1328,7 +1328,7 @@ argument list and OPTS is the option alist."
(x (leave (G_ "wrong number of arguments~%"))))))
(list-generations pattern)))
((describe)
- (match (generation-number %system-profile)
+ (match (generation-number "/run/current-system" %system-profile)
(0
(leave (G_ "no system generation, nothing to describe~%")))
(generation
diff --git a/guix/status.scm b/guix/status.scm
index eefe18365f..fba28765df 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -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'
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..06ef3cf76d 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -472,7 +472,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/utils.scm b/guix/utils.scm
index cba6464523..a0ca9b9070 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>
@@ -454,27 +454,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))))))))))
;;;
generated by cgit v1.2.3 (git 2.50.1) at 2025-08-09 05:30:12 +0000