summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2024-04-19 13:17:08 +0100
committerChristopher Baines <mail@cbaines.net>2024-04-19 13:52:11 +0100
commit5fec94f3a3d4c67b748f11847064ed60d67c5ade (patch)
tree9f2c7a21ad8f2c061a8d46aac817e4c68d307086 /guix
parent6931ca9baaaee4c7e85cf3cd5d0f7e4eb5cfd88e (diff)
parent949f97f7f98ac74306b9de79c93790337d804e32 (diff)
Merge remote-tracking branch 'savannah/master' into core-updates
Change-Id: I4f15bcb3e575062c4dd3b6c07a48470300413f24 Conflicts: gnu/local.mk gnu/packages/bioinformatics.scm gnu/packages/dictionaries.scm gnu/packages/display-managers.scm gnu/packages/engineering.scm gnu/packages/geo.scm gnu/packages/gl.scm gnu/packages/glib.scm gnu/packages/gnome-xyz.scm gnu/packages/gnome.scm gnu/packages/gtk.scm gnu/packages/image-processing.scm gnu/packages/linux.scm gnu/packages/mail.scm gnu/packages/patches/eudev-rules-directory.patch gnu/packages/plotutils.scm gnu/packages/sdl.scm gnu/packages/syndication.scm
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/channel.scm7
-rw-r--r--guix/build/emacs-build-system.scm85
-rw-r--r--guix/build/emacs-utils.scm15
-rw-r--r--guix/build/qt-utils.scm10
-rw-r--r--guix/channels.scm70
-rw-r--r--guix/derivations.scm6
-rw-r--r--guix/discovery.scm4
-rw-r--r--guix/download.scm4
-rw-r--r--guix/gexp.scm19
-rw-r--r--guix/git.scm52
-rw-r--r--guix/import/github.scm7
-rw-r--r--guix/import/hackage.scm4
-rw-r--r--guix/import/hexpm.scm7
-rw-r--r--guix/import/opam.scm7
-rw-r--r--guix/import/pypi.scm5
-rw-r--r--guix/nar.scm8
-rw-r--r--guix/packages.scm5
-rw-r--r--guix/platforms/xtensa.scm28
-rw-r--r--guix/profiles.scm2
-rw-r--r--guix/scripts.scm7
-rw-r--r--guix/scripts/build.scm4
-rw-r--r--guix/scripts/describe.scm4
-rw-r--r--guix/scripts/offload.scm3
-rwxr-xr-xguix/scripts/substitute.scm88
-rw-r--r--guix/scripts/system.scm31
-rw-r--r--guix/scripts/system/reconfigure.scm4
-rw-r--r--guix/ssh.scm6
-rw-r--r--guix/store.scm18
-rw-r--r--guix/store/database.scm239
-rw-r--r--guix/ui.scm36
-rw-r--r--guix/utils.scm17
31 files changed, 415 insertions, 387 deletions
diff --git a/guix/build-system/channel.scm b/guix/build-system/channel.scm
index 6ad377f930..0607dcf4d7 100644
--- a/guix/build-system/channel.scm
+++ b/guix/build-system/channel.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019-2022, 2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -37,6 +37,7 @@
(define* (build-channels name inputs
#:key source system commit
+ (channels '())
(authenticate? #t)
#:allow-other-keys)
(mlet* %store-monad ((instances
@@ -44,7 +45,7 @@
(return (list source)))
((channel? source)
(latest-channel-instances*
- (list source)
+ (cons source channels)
#:authenticate? authenticate?))
((string? source)
;; If SOURCE is a store file name, as is the
@@ -64,12 +65,14 @@
(define channel-build-system
;; Build system used to "convert" a channel instance to a package.
(let ((lower (lambda* (name #:key system source commit (authenticate? #t)
+ (channels '())
#:allow-other-keys)
(bag
(name name)
(system system)
(build build-channels)
(arguments `(#:source ,source
+ #:channels ,channels
#:authenticate? ,authenticate?
#:commit ,commit))))))
(build-system (name 'channel)
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 3808b60445..aa083c6409 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -132,29 +132,25 @@ environment variable\n" source-directory))
(parameterize ((%emacs emacs))
(emacs-compile-directory (elpa-directory out)))))
-(define* (patch-el-files #:key outputs #:allow-other-keys)
- "Substitute the absolute \"/bin/\" directory with the right location in the
-store in '.el' files."
-
- (let* ((out (assoc-ref outputs "out"))
- (elpa-name-ver (store-directory->elpa-name-version out))
- (el-dir (string-append out %install-dir "/" elpa-name-ver))
- (el-files (find-files (getcwd) "\\.el$")))
- (define (substitute-program-names)
- (substitute* el-files
- (("\"/bin/([^.]\\S*)\"" _ cmd-name)
- (let ((cmd (which cmd-name)))
- (unless cmd
- (error "patch-el-files: unable to locate " cmd-name))
- (string-append "\"" cmd "\"")))))
-
- (with-directory-excursion el-dir
- ;; Some old '.el' files (e.g., tex-buf.el in AUCTeX) are still
- ;; ISO-8859-1-encoded.
- (unless (false-if-exception (substitute-program-names))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (substitute-program-names))))
- #t))
+(define* (patch-el-files #:key inputs outputs #:allow-other-keys)
+ "Substitute the absolute \"/bin/\" and \"/sbin\" directories with the right
+locations in the store in '.el' files."
+
+ (define substitute-program-names
+ (let ((el-files (find-files (getcwd) "\\.el$")))
+ (lambda ()
+ (substitute* el-files
+ (("\"/(s?bin/[^.]\\S*)\"" _ cmd)
+ (let ((cmd (search-input-file inputs cmd)))
+ (unless cmd
+ (error "patch-el-files: unable to locate " (basename cmd)))
+ (string-append "\"" cmd "\"")))))))
+
+ (unless (false-if-exception (substitute-program-names))
+ ;; Some old '.el' files (e.g., tex-buf.el in AUCTeX) are still
+ ;; ISO-8859-1-encoded.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (substitute-program-names))))
(define (find-root-library-file name)
(let loop ((parts (string-split
@@ -224,10 +220,8 @@ store in '.el' files."
(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))))
+ (let ((name (store-directory->elpa-name-version (assoc-ref outputs "out"))))
+ (and=> (find-root-library-file name) write-pkg-file)))
(define* (check #:key tests? (test-command '("make" "check"))
(parallel-tests? #t) #:allow-other-keys)
@@ -306,24 +300,15 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND."
info-files)))
#t))
-(define* (make-autoloads #:key outputs inputs #:allow-other-keys)
+(define* (make-autoloads #:key outputs #:allow-other-keys)
"Generate the autoloads file."
- (let* ((emacs (search-input-file inputs "/bin/emacs"))
- (out (assoc-ref outputs "out"))
- (elpa-name-ver (store-directory->elpa-name-version out))
- (elpa-name (package-name->name+version elpa-name-ver))
- (el-dir (elpa-directory out)))
- (parameterize ((%emacs emacs))
- (emacs-generate-autoloads elpa-name el-dir))))
-
-(define* (enable-autoloads-compilation #:key outputs #:allow-other-keys)
- "Remove the NO-BYTE-COMPILATION local variable embedded in the generated
-autoload files."
- (let* ((out (assoc-ref outputs "out"))
- (autoloads (find-files out "-autoloads.el$")))
- (substitute* autoloads
- ((";; no-byte-compile.*") ""))
- #t))
+ (emacs-generate-autoloads
+ (package-name->name+version (store-directory->elpa-name-version
+ (assoc-ref outputs "out")))
+ (getcwd))
+ ;; Ensure that autoloads can be byte-compiled.
+ (substitute* (find-files "." "-autoloads\\.el$")
+ ((";; no-byte-compile.*") "")))
(define* (validate-compiled-autoloads #:key outputs #:allow-other-keys)
"Verify whether the byte compiled autoloads load fine."
@@ -358,7 +343,11 @@ for libraries following the ELPA convention."
(define %standard-phases
(modify-phases gnu:%standard-phases
(replace 'unpack unpack)
+ (add-after 'unpack 'ensure-package-description
+ ensure-package-description)
(add-after 'unpack 'expand-load-path expand-load-path)
+ (add-after 'unpack 'patch-el-files patch-el-files)
+ (add-after 'expand-load-path 'make-autoloads make-autoloads)
(add-after 'expand-load-path 'add-install-to-native-load-path
add-install-to-native-load-path)
(delete 'bootstrap)
@@ -366,14 +355,8 @@ for libraries following the ELPA convention."
(delete 'build)
(replace 'check check)
(replace 'install install)
- (add-after 'install 'make-autoloads make-autoloads)
- (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 'ensure-package-description 'build build)
+ (add-after 'install '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/emacs-utils.scm b/guix/build/emacs-utils.scm
index 8e12b5b6d4..aeb364133a 100644
--- a/guix/build/emacs-utils.scm
+++ b/guix/build/emacs-utils.scm
@@ -136,7 +136,14 @@ If native code is not supported, compile to bytecode instead."
(emacs-batch-eval
`(let ((byte-compile-debug t) ; for proper exit status
(byte+native-compile (native-comp-available-p))
- (files (directory-files-recursively ,dir "\\.el$")))
+ (files (directory-files-recursively ,dir "\\.el$"))
+ (write-bytecode
+ (and (native-comp-available-p)
+ (progn
+ (require 'comp)
+ (if (fboundp 'comp-write-bytecode-file)
+ 'comp-write-bytecode-file
+ 'comp--write-bytecode-file)))))
(mapc
(lambda (file)
(let (byte-to-native-output-buffer-file
@@ -146,11 +153,13 @@ If native code is not supported, compile to bytecode instead."
(cadr native-comp-eln-load-path))))
(if byte+native-compile
(native-compile file
- (comp-el-to-eln-filename file eln-dir))
+ (comp-el-to-eln-filename
+ (file-relative-name file ,dir)
+ eln-dir))
(byte-compile-file file))
;; After native compilation, write the bytecode file.
(unless (null byte-to-native-output-buffer-file)
- (comp-write-bytecode-file nil))))
+ (funcall write-bytecode nil))))
files))
#:dynamic? #t))
diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm
index 7d1b0e0e23..d7609b9f21 100644
--- a/guix/build/qt-utils.scm
+++ b/guix/build/qt-utils.scm
@@ -3,9 +3,9 @@
;;; Copyright © 2019, 2020, 2021 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-;;; Copyright © 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2022, 2023, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
+;;; Copyright © 2024 Zheng Junjie <873216071@qq.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -90,8 +90,10 @@
'("XDG_CONFIG_DIRS" suffix directory "/etc/xdg")
`("QT_PLUGIN_PATH" prefix directory
,(format #f "/lib/qt~a/plugins" qt-major-version))
- `("QML2_IMPORT_PATH" prefix directory
- ,(format #f "/lib/qt~a/qml" qt-major-version))
+ `(,(if (>= (string->number qt-major-version) 6)
+ "QML_IMPORT_PATH"
+ "QML2_IMPORT_PATH")
+ prefix directory ,(format #f "/lib/qt~a/qml" qt-major-version))
;; QTWEBENGINEPROCESS_PATH accepts a single value, which makes 'exact the
;; most suitable environment variable type for it.
`("QTWEBENGINEPROCESS_PATH" = regular
diff --git a/guix/channels.scm b/guix/channels.scm
index 1b07eb5221..51024dcad4 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
@@ -20,12 +20,23 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix channels)
- #:use-module (git)
- #:use-module (guix git)
- #:use-module (guix git-authenticate)
- #:use-module ((guix openpgp)
- #:select (openpgp-public-key-fingerprint
- openpgp-format-fingerprint))
+ #:autoload (git commit) (commit-lookup
+ commit-id)
+ #:autoload (git oid) (oid->string
+ string->oid)
+ #:autoload (git object) (object-id)
+ #:autoload (git errors) (GIT_ENOTFOUND)
+ #:autoload (git structs) (git-error-code)
+ #:autoload (guix git) (update-cached-checkout
+ url+commit->name
+ commit-difference
+ repository-info
+ commit-short-id
+ tag->commit
+ with-repository)
+ #:autoload (guix git-authenticate) (authenticate-repository)
+ #:autoload (guix openpgp) (openpgp-public-key-fingerprint
+ openpgp-format-fingerprint)
#:use-module (guix base16)
#:use-module (guix records)
#:use-module (guix gexp)
@@ -41,10 +52,10 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
#:autoload (guix describe) (current-channels) ;XXX: circular dep
#:autoload (guix self) (whole-package make-config.scm)
#:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
@@ -205,18 +216,13 @@ introduction, add it."
channel that uses that repository and the commit HEAD currently points to; use
INTRODUCTION as the channel's introduction. Return #f if no Git repository
could be found at DIRECTORY or one of its ancestors."
- (catch 'git-error
- (lambda ()
- (with-repository (repository-discover directory) repository
- (let* ((head (repository-head repository))
- (commit (oid->string (reference-target head))))
- (channel
- (inherit %default-guix-channel)
- (url (repository-working-directory repository))
- (commit commit)
- (branch (reference-shorthand head))
- (introduction introduction)))))
- (const #f)))
+ (let ((directory commit branch (repository-info directory)))
+ (channel
+ (inherit %default-guix-channel)
+ (url directory)
+ (commit commit)
+ (branch branch)
+ (introduction introduction))))
(define-record-type <channel-instance>
(channel-instance channel commit checkout)
@@ -341,9 +347,6 @@ result is unspecified."
(apply-patch patch checkout))
(loop rest)))))
-(define commit-short-id
- (compose (cut string-take <> 7) oid->string commit-id))
-
(define* (authenticate-channel channel checkout commit
#:key (keyring-reference-prefix "origin/"))
"Authenticate the given COMMIT of CHANNEL, available at CHECKOUT, a
@@ -409,12 +412,11 @@ their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated."
(and (string=? (basename file) ".git")
(eq? 'directory (stat:type stat))))
- (let-values (((channel)
- (ensure-default-introduction channel))
- ((checkout commit relation)
- (update-cached-checkout (channel-url channel)
- #:ref (channel-reference channel)
- #:starting-commit starting-commit)))
+ (let ((channel (ensure-default-introduction channel))
+ (checkout commit relation
+ (update-cached-checkout (channel-url channel)
+ #:ref (channel-reference channel)
+ #:starting-commit starting-commit)))
(when relation
(validate-pull channel starting-commit commit relation))
@@ -1153,14 +1155,8 @@ the field its 'tag' refers to. A 'git-error' exception is raised if the tag
cannot be found."
(if (channel-news-entry-commit entry)
entry
- (let* ((tag (channel-news-entry-tag entry))
- (reference (reference-lookup repository
- (string-append "refs/tags/" tag)))
- (target (reference-target reference))
- (oid (let ((obj (object-lookup repository target)))
- (if (= OBJ-TAG (object-type obj)) ;annotated tag?
- (tag-target-id (tag-lookup repository target))
- target))))
+ (let* ((tag (channel-news-entry-tag entry))
+ (oid (object-id (tag->commit repository tag))))
(channel-news-entry (oid->string oid) tag
(channel-news-entry-title entry)
(channel-news-entry-body entry)))))
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 9fec7f4f0b..a91c1ae984 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2021, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2021, 2023-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -32,7 +32,7 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 vlist)
#:use-module (guix store)
- #:use-module (guix utils)
+ #:autoload (guix utils) (%current-system string-replace-substring)
#:use-module (guix base16)
#:use-module (guix memoization)
#:use-module (guix combinators)
@@ -40,7 +40,7 @@
#:use-module (guix diagnostics)
#:use-module (guix i18n)
#:use-module (guix monads)
- #:use-module (gcrypt hash)
+ #:autoload (gcrypt hash) (sha256)
#:use-module (guix sets)
#:export (<derivation>
derivation?
diff --git a/guix/discovery.scm b/guix/discovery.scm
index 0edc7fd1ae..2febfcdcb7 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2019, 2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,7 +20,7 @@
#:use-module (guix i18n)
#:use-module (guix modules)
#:use-module (guix combinators)
- #:use-module (guix build syscalls)
+ #:autoload (guix build syscalls) (scandir*)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
diff --git a/guix/download.scm b/guix/download.scm
index 3dfe143e9f..b251e1f6c0 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -31,8 +31,8 @@
#:autoload (guix build download) (url-fetch)
#:use-module (guix monads)
#:use-module (guix gexp)
- #:use-module (guix utils)
- #:use-module (web uri)
+ #:autoload (guix build utils) (call-with-temporary-output-file)
+ #:autoload (web uri) (string->uri uri-scheme uri-path)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (%download-methods
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 29819878fa..74b4c49f90 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2024 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>
@@ -633,25 +633,29 @@ This is the declarative counterpart of 'gexp->script'."
#:target target))))
(define-record-type <scheme-file>
- (%scheme-file name gexp splice? load-path?)
+ (%scheme-file name gexp splice? guile load-path?)
scheme-file?
(name scheme-file-name) ;string
(gexp scheme-file-gexp) ;gexp
(splice? scheme-file-splice?) ;Boolean
+ (guile scheme-file-guile) ;package
(load-path? scheme-file-set-load-path?)) ;Boolean
-(define* (scheme-file name gexp #:key splice? (set-load-path? #t))
+(define* (scheme-file name gexp
+ #:key splice?
+ guile (set-load-path? #t))
"Return an object representing the Scheme file NAME that contains GEXP.
This is the declarative counterpart of 'gexp->file'."
- (%scheme-file name gexp splice? set-load-path?))
+ (%scheme-file name gexp splice? guile set-load-path?))
(define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
system target)
;; Compile FILE by returning a derivation that builds the file.
(match file
- (($ <scheme-file> name gexp splice? set-load-path?)
+ (($ <scheme-file> name gexp splice? guile set-load-path?)
(gexp->file name gexp
+ #:guile (or guile (default-guile))
#:set-load-path? set-load-path?
#:splice? splice?
#:system system
@@ -2019,6 +2023,7 @@ imported modules in its search path. Look up EXP's modules in MODULE-PATH."
#:substitutable? #f)))
(define* (gexp->file name exp #:key
+ (guile (default-guile))
(set-load-path? #t)
(module-path %load-path)
(splice? #f)
@@ -2038,6 +2043,8 @@ Lookup EXP's modules in MODULE-PATH."
((target (if (eq? target 'current)
(current-target-system)
(return target)))
+ (guile-for-build
+ (lower-object guile system #:target #f))
(no-load-path? -> (or (not set-load-path?)
(and (null? modules)
(null? extensions))))
@@ -2057,6 +2064,7 @@ Lookup EXP's modules in MODULE-PATH."
'(ungexp (if splice?
exp
(gexp ((ungexp exp)))))))))
+ #:guile-for-build guile-for-build
#:local-build? #t
#:substitutable? #f
#:system system
@@ -2073,6 +2081,7 @@ Lookup EXP's modules in MODULE-PATH."
exp
(gexp ((ungexp exp)))))))))
#:module-path module-path
+ #:guile-for-build guile-for-build
#:local-build? #t
#:substitutable? #f
#:system system
diff --git a/guix/git.scm b/guix/git.scm
index a041b2cf88..1f3881fd97 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-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2024 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>
@@ -27,14 +27,13 @@
#:use-module (guix i18n)
#:use-module (guix base32)
#:use-module (guix cache)
- #:use-module (gcrypt hash)
+ #:autoload (gcrypt hash) (sha256)
#:use-module ((guix build utils)
#:select (mkdir-p delete-file-recursively invoke/quiet))
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix records)
- #:use-module ((guix build syscalls)
- #:select (terminal-string-width))
+ #:autoload (guix build syscalls) (terminal-string-width)
#:use-module (guix gexp)
#:autoload (guix git-download)
(git-reference-url git-reference-commit git-reference-recursive?)
@@ -59,6 +58,7 @@
with-repository
with-git-error-handling
false-if-git-not-found
+ repository-info
update-cached-checkout
url+commit->name
latest-repository-commit
@@ -66,6 +66,8 @@
commit-relation
commit-descendant?
commit-id?
+ commit-short-id
+ tag->commit
remote-refs
@@ -232,6 +234,22 @@ is a tag name. This is based on a simple heuristic so use with care!"
(and (= (string-length str) 40)
(string-every char-set:hex-digit str)))
+(define commit-short-id
+ (compose (cut string-take <> 7) oid->string commit-id))
+
+(define (tag->commit repository tag)
+ "Resolve TAG in REPOSITORY and return the corresponding object, usually a
+commit."
+ (let* ((oid (reference-name->oid repository
+ (string-append "refs/tags/" tag)))
+ (obj (object-lookup repository oid)))
+ ;; OID may designate an "annotated tag" object or a "commit" object.
+ ;; Return the commit object in both cases.
+ (if (= OBJ-TAG (object-type obj))
+ (object-lookup repository
+ (tag-target-id (tag-lookup repository oid)))
+ obj)))
+
(define (resolve-reference repository ref)
"Resolve the branch, commit or tag specified by REF, and return the
corresponding Git object."
@@ -278,15 +296,7 @@ corresponding Git object."
;; There's no such tag, so it must be a commit ID.
(resolve `(commit . ,str)))))))
(('tag . tag)
- (let* ((oid (reference-name->oid repository
- (string-append "refs/tags/" tag)))
- (obj (object-lookup repository oid)))
- ;; OID may designate an "annotated tag" object or a "commit" object.
- ;; Return the commit object in both cases.
- (if (= OBJ-TAG (object-type obj))
- (object-lookup repository
- (tag-target-id (tag-lookup repository oid)))
- obj))))))
+ (tag->commit repository tag)))))
(define (switch-to-ref repository ref)
"Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
@@ -330,6 +340,22 @@ dynamic extent of EXP."
(lambda (key err)
(report-git-error err))))
+(define (repository-info directory)
+ "Open the Git repository in DIRECTORY or one of its parent and return three
+values: the working directory of that repository, its checked out commit ID,
+and its checked out reference (such as a branch name). Return #f (three
+values) if DIRECTORY does not hold a readable Git repository."
+ (catch 'git-error
+ (lambda ()
+ (with-repository (repository-discover directory) repository
+ (let* ((head (repository-head repository))
+ (commit (oid->string (reference-target head))))
+ (values (repository-working-directory repository)
+ commit
+ (reference-shorthand head)))))
+ (lambda _
+ (values #f #f #f))))
+
(define* (update-submodules repository
#:key (log-port (current-error-port))
(fetch-options #f))
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 7409c9a202..c5556d78ee 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -6,6 +6,7 @@
;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,6 +25,7 @@
(define-module (guix import github)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
@@ -96,6 +98,11 @@ false if none is recognized"
url)
(string-append prefix "/releases/download/" repo "-" new-version "/"
repo "-" new-version ext))
+ ((string-match (string-append "/releases/download/(v)?" version "/"
+ name ".*" ext "$")
+ url)
+ (string-replace-substring url version new-version))
+
(#t #f))) ; Some URLs are not recognised.
#f))
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index bbaee73a06..79a51d3300 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -8,7 +8,7 @@
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
-;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023-2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -47,7 +47,7 @@
#:use-module (guix upstream)
#:use-module (guix packages)
#:autoload (guix build-system haskell) (hackage-uri)
- #:use-module ((guix utils) #:select (call-with-temporary-output-file))
+ #:autoload (guix build utils) (call-with-temporary-output-file)
#:export (%hackage-url
hackage->guix-package
hackage-recursive-import
diff --git a/guix/import/hexpm.scm b/guix/import/hexpm.scm
index 628a44ff24..71a54ba973 100644
--- a/guix/import/hexpm.scm
+++ b/guix/import/hexpm.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2016 David Craven <david@craven.ch>
-;;; Copyright © 2017, 2019-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019-2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020-2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -28,10 +28,11 @@
#:use-module ((guix build utils)
#:select ((package-name->name+version
. hyphen-package-name->name+version)
- dump-port))
+ dump-port
+ call-with-temporary-output-file))
#:use-module (guix packages)
#:use-module (guix upstream)
- #:use-module (guix utils)
+ #:autoload (guix utils) (version>? file-sans-extension)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index 86e82cde59..a7f8092507 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -31,7 +31,9 @@
#:use-module ((srfi srfi-26) #:select (cut))
#:use-module (srfi srfi-34)
#:use-module ((web uri) #:select (string->uri uri->string))
- #:use-module ((guix build utils) #:select (dump-port find-files mkdir-p))
+ #:use-module ((guix build utils)
+ #:select (dump-port find-files mkdir-p
+ call-with-temporary-output-file))
#:use-module (guix build-system)
#:use-module (guix i18n)
#:use-module (guix diagnostics)
@@ -39,8 +41,7 @@
#:use-module (guix packages)
#:use-module (guix upstream)
#:use-module ((guix utils) #:select (cache-directory
- version>?
- call-with-temporary-output-file))
+ version>?))
#:use-module ((guix import utils) #:select (beautify-description
guix-hash-url
recursive-import
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 1a3070fb36..6719fde330 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-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015-2017, 2019-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -52,7 +52,8 @@
#:select ((package-name->name+version
. hyphen-package-name->name+version)
find-files
- invoke))
+ invoke
+ call-with-temporary-output-file))
#:use-module (guix import utils)
#:use-module (guix import json)
#:use-module (json)
diff --git a/guix/nar.scm b/guix/nar.scm
index a817b56007..c7842399dc 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2016, 2018-2020, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -19,7 +19,7 @@
(define-module (guix nar)
#:use-module (guix serialization)
- #:use-module (guix build syscalls)
+ #:autoload (guix build syscalls) (lock-file unlock-file)
#:use-module ((guix build utils)
#:select (delete-file-recursively with-directory-excursion))
@@ -103,11 +103,11 @@ held."
(acquire-lock file)))))
(with-database %default-database-file db
- (unless (path-id db target)
+ (unless (valid-path-id db target)
(let ((lock (and lock?
(acquire-lock (string-append target ".lock")))))
- (unless (path-id db target)
+ (unless (valid-path-id db target)
;; If FILE already exists, delete it (it's invalid anyway.)
(when (file-exists? target)
(delete-file-recursively target))
diff --git a/guix/packages.scm b/guix/packages.scm
index 15935ebfdd..2c953d18ee 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 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>
@@ -27,8 +27,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix packages)
- #:use-module ((guix build utils) #:select (compressor tarball?
- strip-store-file-name))
+ #:autoload (guix build utils) (compressor tarball? strip-store-file-name)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix store)
diff --git a/guix/platforms/xtensa.scm b/guix/platforms/xtensa.scm
new file mode 100644
index 0000000000..304e23ab1a
--- /dev/null
+++ b/guix/platforms/xtensa.scm
@@ -0,0 +1,28 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Foundation Devices, Inc. <hello@foundationdevices.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix platforms xtensa)
+ #:use-module (guix platform)
+ #:use-module (guix records)
+ #:export (xtensa-ath9k-elf))
+
+(define xtensa-ath9k-elf
+ (platform
+ (target "xtensa-ath9k-elf")
+ (system #f)
+ (glibc-dynamic-linker #f)))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 5d3dd59211..2545a0aa56 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1568,7 +1568,7 @@ MIME type."
"Return a derivation that builds the @file{mime.cache} database from manifest
entries. It's used to query the MIME type of a given file."
(define shared-mime-info ; lazy reference
- (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
+ (module-ref (resolve-interface '(gnu packages freedesktop)) 'shared-mime-info))
(mlet %store-monad ((glib (manifest-lookup-package manifest "glib")))
(define build
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 5d11ce7fe9..c4849816ea 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2015, 2017-2021, 2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
@@ -29,7 +29,10 @@
#:use-module (guix packages)
#:use-module (guix derivations)
#:autoload (guix describe) (current-profile-date)
- #:use-module (guix build syscalls)
+ #:autoload (guix build syscalls) (statfs
+ file-system-block-size
+ file-system-blocks-available
+ file-system-block-count)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-37)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 05f022a92e..da4859eeaa 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
@@ -45,7 +45,7 @@
#:use-module (guix platform)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module ((guix progress) #:select (current-terminal-columns))
- #:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:autoload (guix build syscalls) (terminal-columns)
#:use-module (guix transformations)
#:export (log-url
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index 449ab4b252..70ae84e9f6 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021, 2023, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
@@ -37,7 +37,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:autoload (ice-9 pretty-print) (pretty-print)
- #:use-module (web uri)
+ #:autoload (web uri) (string->uri uri-host)
#:export (display-profile-content
channel-commit-hyperlink
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 137e3b5fe3..93e9d3759c 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -213,9 +213,6 @@ private key from '~a': ~a")
When MAX-SILENT-TIME is true, it must be a positive integer denoting the
number of seconds after which the connection times out."
(let ((private (private-key-from-file* (build-machine-private-key machine)))
- (public (public-key-from-file
- (string-append (build-machine-private-key machine)
- ".pub")))
(session (make-session #:user (build-machine-user machine)
#:host (build-machine-name machine)
#:port (build-machine-port machine)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 37cd08e289..a7ad56dbcd 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
@@ -452,7 +452,8 @@ server certificates."
(define* (download-nar narinfo destination
#:key status-port
- deduplicate? print-build-trace?)
+ deduplicate? print-build-trace?
+ (fetch-timeout %fetch-timeout))
"Download the nar prescribed in NARINFO, which is assumed to be authentic
and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and
if DESTINATION is in the store, deduplicate its files. Print a status line to
@@ -473,28 +474,38 @@ STATUS-PORT."
(let ((port (open-file (uri-path uri) "r0b")))
(values port (stat:size (stat port)))))
((http https)
- ;; Test this with:
- ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
- ;; and then cancel with:
- ;; sudo tc qdisc del dev eth0 root
- (with-timeout %fetch-timeout
- (begin
- (warning (G_ "while fetching ~a: server is somewhat slow~%")
- (uri->string uri))
- (warning (G_ "try `--no-substitutes' if the problem persists~%")))
- (with-cached-connection uri port
- (http-fetch uri #:text? #f
- #:port port
- #:keep-alive? #t
- #:buffered? #f))))
+ (if fetch-timeout
+ ;; Test this with:
+ ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
+ ;; and then cancel with:
+ ;; sudo tc qdisc del dev eth0 root
+ (with-timeout %fetch-timeout
+ (begin
+ (warning (G_ "while fetching ~a: server is somewhat slow~%")
+ (uri->string uri))
+ (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+ (with-cached-connection uri port
+ (http-fetch uri #:text? #f
+ #:port port
+ #:keep-alive? #t
+ #:buffered? #f)))
+ (with-cached-connection uri port
+ (http-fetch uri #:text? #f
+ #:port port
+ #:keep-alive? #t
+ #:buffered? #f))))
(else
- (leave (G_ "unsupported substitute URI scheme: ~a~%")
- (uri->string uri)))))
+ (raise
+ (formatted-message
+ (G_ "unsupported substitute URI scheme: ~a~%")
+ (uri->string uri))))))
(define (try-fetch choices)
(match choices
(((uri compression file-size) rest ...)
- (guard (c ((and (pair? rest) (http-get-error? c))
+ (guard (c ((and (pair? rest)
+ (or (http-get-error? c)
+ (network-error? c)))
(warning (G_ "download from '~a' failed, trying next URL~%")
(uri->string uri))
(try-fetch rest)))
@@ -504,9 +515,11 @@ STATUS-PORT."
(G_ "Downloading ~a...~%") (uri->string uri)))
(values port uri compression download-size))))
(()
- (leave (G_ "no valid nar URLs for ~a at ~a~%")
- (narinfo-path narinfo)
- (narinfo-uri-base narinfo)))))
+ (raise
+ (formatted-message
+ (G_ "no valid nar URLs for ~a at ~a~%")
+ (narinfo-path narinfo)
+ (narinfo-uri-base narinfo))))))
;; Delete DESTINATION first--necessary when starting over after a failed
;; download.
@@ -613,13 +626,7 @@ STATUS-PORT."
(and (kind-and-args? exception)
(memq (exception-kind exception)
'(gnutls-error getaddrinfo-error)))
- (and (http-get-error? exception)
- (begin
- (warning (G_ "download from '~a' failed: ~a, ~s~%")
- (uri->string (http-get-error-uri exception))
- (http-get-error-code exception)
- (http-get-error-reason exception))
- #t))))))
+ (http-get-error? exception)))))
(define* (process-substitution/fallback port narinfo destination
#:key cache-urls acl
@@ -647,7 +654,13 @@ way to download the nar."
(if (or (equivalent-narinfo? narinfo alternate)
(valid-narinfo? alternate acl)
(%allow-unauthenticated-substitutes?))
- (guard (c ((network-error? c) (loop rest)))
+ (guard (c ((network-error? c)
+ (when (http-get-error? c)
+ (warning (G_ "download from '~a' failed: ~a, ~s~%")
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c)))
+ (loop rest)))
(download-nar alternate destination
#:status-port port
#:deduplicate? deduplicate?
@@ -671,10 +684,17 @@ PORT."
(cut valid-narinfo? <> acl))))
(unless narinfo
- (leave (G_ "no valid substitute for '~a'~%")
- store-item))
+ (raise
+ (formatted-message
+ (G_ "no valid substitute for '~a'~%")
+ store-item)))
(guard (c ((network-error? c)
+ (when (http-get-error? c)
+ (warning (G_ "download from '~a' failed: ~a, ~s~%")
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c)))
(format (current-error-port)
(G_ "retrying download of '~a' with other substitute URLs...~%")
store-item)
@@ -749,8 +769,8 @@ found."
(#f
;; This can only happen when this script is not invoked by the
;; daemon.
- '("http://ci.guix.gnu.org"
- "http://bordeaux.guix.gnu.org"))))
+ '("http://bordeaux.guix.gnu.org"
+ "http://ci.guix.gnu.org"))))
;; In order to prevent using large number of discovered local substitute
;; servers, limit the local substitute urls list size.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index bf3d2f9044..2260bcf985 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2024 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>
@@ -35,9 +35,9 @@
#:use-module (guix store)
#:autoload (guix base16) (bytevector->base16-string)
#:autoload (guix store database)
- (sqlite-register store-database-file call-with-database)
+ (register-valid-path store-database-file call-with-database)
#:autoload (guix build store-copy) (copy-store-item)
- #:use-module (guix describe)
+ #:autoload (guix describe) (current-profile)
#:use-module (guix gexp)
#:use-module (guix derivations)
#:use-module (guix diagnostics)
@@ -47,7 +47,10 @@
#:use-module (guix records)
#:use-module (guix profiles)
#:use-module (guix scripts)
- #:use-module (guix channels)
+ #:autoload (guix channels) (channel-name
+ channel-url
+ channel-branch
+ channel-commit)
#:use-module (guix scripts build)
#:autoload (guix scripts package) (delete-generations
delete-matching-generations
@@ -57,7 +60,8 @@
graph-backend-name lookup-backend)
#:use-module (guix scripts system reconfigure)
#:use-module (guix build utils)
- #:use-module (guix progress)
+ #:autoload (guix progress) (progress-reporter/bar
+ call-with-progress-reporter)
#:use-module ((guix docker) #:select (%docker-image-max-layers))
#:use-module (gnu build image)
#:use-module (gnu build install)
@@ -158,14 +162,15 @@ given INFO, a <path-info> record."
(copy-store-item item target
#:deduplicate? #t)
- (sqlite-register db
- #:path item
- #:references (path-info-references info)
- #:deriver (path-info-deriver info)
- #:hash (string-append
- "sha256:"
- (bytevector->base16-string (path-info-hash info)))
- #:nar-size (path-info-nar-size info))))
+ (register-valid-path db
+ #:path item
+ #:references (path-info-references info)
+ #:deriver (path-info-deriver info)
+ #:hash (string-append
+ "sha256:"
+ (bytevector->base16-string
+ (path-info-hash info)))
+ #:nar-size (path-info-nar-size info))))
(define* (copy-closure item target
#:key (log-port (current-error-port)))
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 9418060158..604ba08fee 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2022, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -106,7 +106,7 @@ atomically, and run OS's activation script."
(generation (generation-file-name profile number)))
(switch-symlinks generation #$os)
(switch-symlinks profile generation)
- (setenv "GUIX_NEW_SYSTEM" #$os)
+ (setenv "GUIX_NEW_SYSTEM" generation)
(primitive-load #$(operating-system-activation-script os))))))))
(define* (switch-to-system eval os #:optional profile)
diff --git a/guix/ssh.scm b/guix/ssh.scm
index c4617d2c74..ae506df14c 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016-2021, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016-2021, 2023-2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -180,8 +180,8 @@ to SSH server at '~a'")
(get-error session)))))))))))
(x
;; Connection failed or timeout expired.
- (raise (formatted-message (G_ "SSH connection to '~a' failed: ~a~%")
- host (get-error session)))))))
+ (raise (formatted-message (G_ "SSH connection to '~a' port ~a failed: ~a~%")
+ host (or port 22) (get-error session)))))))
(define* (remote-inferior session #:optional become-command)
"Return a remote inferior for the given SESSION. If BECOME-COMMAND is
diff --git a/guix/store.scm b/guix/store.scm
index 97c4f32a5b..a238cb627a 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
@@ -29,7 +29,7 @@
#:use-module (guix records)
#:use-module (guix base16)
#:use-module (guix base32)
- #:use-module (gcrypt hash)
+ #:autoload (gcrypt hash) (sha256)
#:use-module (guix profiling)
#:autoload (guix build syscalls) (terminal-columns)
#:autoload (guix build utils) (dump-port)
@@ -49,7 +49,12 @@
#:use-module (ice-9 popen)
#:autoload (ice-9 threads) (current-processor-count)
#:use-module (ice-9 format)
- #:use-module (web uri)
+ #:autoload (web uri) (uri?
+ string->uri
+ uri-scheme
+ uri-host
+ uri-port
+ uri-path)
#:export (%daemon-socket-uri
%gc-roots-directory
%default-substitute-urls
@@ -764,11 +769,8 @@ encoding conversion errors."
;; Default list of substituters. This is *not* the list baked in
;; 'guix-daemon', but it is used by 'guix-service-type' and and a couple of
;; clients ('guix build --log-file' uses it.)
- (map (if (false-if-exception (resolve-interface '(gnutls)))
- (cut string-append "https://" <>)
- (cut string-append "http://" <>))
- '("ci.guix.gnu.org"
- "bordeaux.guix.gnu.org")))
+ '("https://bordeaux.guix.gnu.org"
+ "https://ci.guix.gnu.org"))
(define (current-user-name)
"Return the name of the calling user."
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 2968f13492..a847f9d2f0 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -40,8 +40,10 @@
store-database-file
call-with-database
with-database
- path-id
- sqlite-register
+
+ valid-path-id
+
+ register-valid-path
register-items
%epoch
reset-timestamps
@@ -130,60 +132,29 @@ errors."
the transaction, otherwise commit the transaction after it finishes.
RESTARTABLE? may be set to a non-#f value when it is safe to run PROC multiple
times. This may reduce contention for the database somewhat."
- (define (exec sql)
- (with-statement db sql stmt
- (sqlite-fold cons '() stmt)))
;; We might use begin immediate here so that if we need to retry, we figure
;; that out immediately rather than because some SQLITE_BUSY exception gets
;; thrown partway through PROC - in which case the part already executed
;; (which may contain side-effects!) might have to be executed again for
;; every retry.
- (exec (if restartable? "begin;" "begin immediate;"))
+ (sqlite-exec db (if restartable? "begin;" "begin immediate;"))
(catch #t
(lambda ()
(let-values ((result (proc)))
- (exec "commit;")
+ (sqlite-exec db "commit;")
(apply values result)))
(lambda args
;; The roll back may or may not have occurred automatically when the
;; error was generated. If it has occurred, this does nothing but signal
;; an error. If it hasn't occurred, this needs to be done.
- (false-if-exception (exec "rollback;"))
+ (false-if-exception (sqlite-exec db "rollback;"))
(apply throw args))))
-(define* (call-with-savepoint db proc
- #:optional (savepoint-name "SomeSavepoint"))
- "Call PROC after creating a savepoint named SAVEPOINT-NAME. If PROC exits
-abnormally, rollback to that savepoint. In all cases, remove the savepoint
-prior to returning."
- (define (exec sql)
- (with-statement db sql stmt
- (sqlite-fold cons '() stmt)))
-
- (dynamic-wind
- (lambda ()
- (exec (string-append "SAVEPOINT " savepoint-name ";")))
- (lambda ()
- (catch #t
- proc
- (lambda args
- (exec (string-append "ROLLBACK TO " savepoint-name ";"))
- (apply throw args))))
- (lambda ()
- (exec (string-append "RELEASE " savepoint-name ";")))))
-
(define* (call-with-retrying-transaction db proc #:key restartable?)
(call-with-SQLITE_BUSY-retrying
(lambda ()
(call-with-transaction db proc #:restartable? restartable?))))
-(define* (call-with-retrying-savepoint db proc
- #:optional (savepoint-name
- "SomeSavepoint"))
- (call-with-SQLITE_BUSY-retrying
- (lambda ()
- (call-with-savepoint db proc savepoint-name))))
-
(define %default-database-file
;; Default location of the store database.
(string-append %store-database-directory "/db.sqlite"))
@@ -198,48 +169,32 @@ If FILE doesn't exist, create it and initialize it as a new database. Pass
((_ file db exp ...)
(call-with-database file (lambda (db) exp ...)))))
-(define (call-with-statement db sql proc)
- (let ((stmt (sqlite-prepare db sql #:cache? #t)))
- (dynamic-wind
- (const #t)
- (lambda ()
- (proc stmt))
- (lambda ()
- (sqlite-finalize stmt)))))
-
-(define-syntax-rule (with-statement db sql stmt exp ...)
- "Run EXP... with STMT bound to a prepared statement corresponding to the sql
-string SQL for DB."
- (call-with-statement db sql
- (lambda (stmt) exp ...)))
+(define (sqlite-step-and-reset statement)
+ (let ((val (sqlite-step statement)))
+ (sqlite-reset statement)
+ val))
(define (last-insert-row-id db)
;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
;; Work around that.
- (with-statement db "SELECT last_insert_rowid();" stmt
- (match (sqlite-fold cons '() stmt)
- ((#(id)) id)
- (_ #f))))
-
-(define path-id-sql
- "SELECT id FROM ValidPaths WHERE path = :path")
-
-(define* (path-id db path)
- "If PATH exists in the 'ValidPaths' table, return its numerical
-identifier. Otherwise, return #f."
- (with-statement db path-id-sql stmt
+ (let ((stmt (sqlite-prepare db
+ "SELECT last_insert_rowid();"
+ #:cache? #t)))
+ (vector-ref (sqlite-step-and-reset stmt)
+ 0)))
+
+(define (valid-path-id db path)
+ "If PATH exists in the 'ValidPaths' table, return its numerical identifier.
+Otherwise, return #f."
+ (let ((stmt (sqlite-prepare
+ db
+ "
+SELECT id FROM ValidPaths WHERE path = :path"
+ #:cache? #t)))
(sqlite-bind-arguments stmt #:path path)
- (match (sqlite-fold cons '() stmt)
- ((#(id) . _) id)
- (_ #f))))
-
-(define update-sql
- "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver =
-:deriver, narSize = :size WHERE id = :id")
-
-(define insert-sql
- "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
-VALUES (:path, :hash, :time, :deriver, :size)")
+ (match (sqlite-step-and-reset stmt)
+ (#(id) id)
+ (#f #f))))
(define-inlinable (assert-integer proc in-range? key number)
(unless (integer? number)
@@ -251,63 +206,19 @@ VALUES (:path, :hash, :time, :deriver, :size)")
"Integer ~A out of range: ~S" (list key number)
(list number))))
-(define* (update-or-insert db #:key path deriver hash nar-size time)
- "The classic update-if-exists and insert-if-doesn't feature that sqlite
-doesn't exactly have... they've got something close, but it involves deleting
-and re-inserting instead of updating, which causes problems with foreign keys,
-of course. Returns the row id of the row that was modified or inserted."
-
- ;; Make sure NAR-SIZE is valid.
- (assert-integer "update-or-insert" positive? #:nar-size nar-size)
- (assert-integer "update-or-insert" (cut >= <> 0) #:time time)
-
- ;; It's important that querying the path-id and the insert/update operation
- ;; take place in the same transaction, as otherwise some other
- ;; process/thread/fiber could register the same path between when we check
- ;; whether it's already registered and when we register it, resulting in
- ;; duplicate paths (which, due to a 'unique' constraint, would cause an
- ;; exception to be thrown). With the default journaling mode this will
- ;; prevent writes from occurring during that sensitive time, but with WAL
- ;; mode it will instead arrange to return SQLITE_BUSY when a write occurs
- ;; between the start of a read transaction and its upgrading to a write
- ;; transaction (see https://sqlite.org/rescode.html#busy_snapshot).
- ;; Experimentally, it seems this SQLITE_BUSY will ignore a busy_timeout and
- ;; immediately return (makes sense, since waiting won't change anything).
-
- ;; Note that when that kind of SQLITE_BUSY error is returned, it will keep
- ;; being returned every time we try to upgrade the same outermost
- ;; transaction to a write transaction. So when retrying, we have to restart
- ;; the *outermost* write transaction. We can't inherently tell whether
- ;; we're the outermost write transaction, so we leave the retry-handling to
- ;; the caller.
- (call-with-savepoint db
- (lambda ()
- (let ((id (path-id db path)))
- (if id
- (with-statement db update-sql stmt
- (sqlite-bind-arguments stmt #:id id
- #:deriver deriver
- #:hash hash #:size nar-size #:time time)
- (sqlite-fold cons '() stmt))
- (with-statement db insert-sql stmt
- (sqlite-bind-arguments stmt
- #:path path #:deriver deriver
- #:hash hash #:size nar-size #:time time)
- (sqlite-fold cons '() stmt)))
- (last-insert-row-id db)))))
-
-(define add-reference-sql
- "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);")
-
(define (add-references db referrer references)
"REFERRER is the id of the referring store item, REFERENCES is a list
ids of items referred to."
- (with-statement db add-reference-sql stmt
+ (let ((stmt (sqlite-prepare
+ db
+ "
+INSERT OR REPLACE INTO Refs (referrer, reference)
+VALUES (:referrer, :reference)"
+ #:cache? #t)))
(for-each (lambda (reference)
- (sqlite-reset stmt)
(sqlite-bind-arguments stmt #:referrer referrer
#:reference reference)
- (sqlite-fold cons '() stmt))
+ (sqlite-step-and-reset stmt))
references)))
(define (timestamp)
@@ -320,9 +231,9 @@ ids of items referred to."
(make-time time-utc 0 seconds)
(current-time time-utc)))))
-(define* (sqlite-register db #:key path (references '())
- deriver hash nar-size
- (time (timestamp)))
+(define* (register-valid-path db #:key path (references '())
+ deriver hash nar-size
+ (time (timestamp)))
"Registers this stuff in DB. PATH is the store item to register and
REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv'
that produced PATH, HASH is the base16-encoded Nix sha256 hash of
@@ -331,15 +242,53 @@ being converted to nar form. TIME is the registration time to be recorded in
the database or #f, meaning \"right now\".
Every store item in REFERENCES must already be registered."
- (let ((id (update-or-insert db #:path path
- #:deriver deriver
- #:hash hash
- #:nar-size nar-size
- #:time (time-second time))))
- ;; Call 'path-id' on each of REFERENCES. This ensures we get a
- ;; "non-NULL constraint" failure if one of REFERENCES is unregistered.
- (add-references db id
- (map (cut path-id db <>) references))))
+
+ (define registration-time
+ (time-second time))
+
+ ;; Make sure NAR-SIZE is valid.
+ (assert-integer "register-valid-path" positive? #:nar-size nar-size)
+ (assert-integer "register-valid-path" (cut >= <> 0)
+ #:time registration-time)
+
+ (define id
+ (let ((existing-id (valid-path-id db path)))
+ (if existing-id
+ (let ((stmt (sqlite-prepare
+ db
+ "
+UPDATE ValidPaths
+SET hash = :hash, registrationTime = :time, deriver = :deriver, narSize = :size
+WHERE id = :id"
+ #:cache? #t)))
+ (sqlite-bind-arguments stmt
+ #:id existing-id
+ #:deriver deriver
+ #:hash hash
+ #:size nar-size
+ #:time registration-time)
+ (sqlite-step-and-reset stmt)
+ existing-id)
+ (let ((stmt (sqlite-prepare
+ db
+ "
+INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
+VALUES (:path, :hash, :time, :deriver, :size)"
+ #:cache? #t)))
+ (sqlite-bind-arguments stmt
+ #:path path
+ #:deriver deriver
+ #:hash hash
+ #:size nar-size
+ #:time registration-time)
+ (sqlite-step-and-reset stmt)
+ (last-insert-row-id db)))))
+
+ ;; Call 'path-id' on each of REFERENCES. This ensures we get a
+ ;; "non-NULL constraint" failure if one of REFERENCES is unregistered.
+ (add-references db id
+ (map (cut valid-path-id db <>) references)))
+
;;;
@@ -416,18 +365,18 @@ typically by adding them as temp-roots."
;; When TO-REGISTER is already registered, skip it. This makes a
;; significant differences when 'register-closures' is called
;; consecutively for overlapping closures such as 'system' and 'bootcfg'.
- (unless (path-id db to-register)
+ (unless (valid-path-id db to-register)
(let-values (((hash nar-size) (nar-sha256 real-file-name)))
(call-with-retrying-transaction db
(lambda ()
- (sqlite-register db #:path to-register
- #:references (store-info-references item)
- #:deriver (store-info-deriver item)
- #:hash (string-append
- "sha256:"
- (bytevector->base16-string hash))
- #:nar-size nar-size
- #:time registration-time))))))
+ (register-valid-path db #:path to-register
+ #:references (store-info-references item)
+ #:deriver (store-info-deriver item)
+ #:hash (string-append
+ "sha256:"
+ (bytevector->base16-string hash))
+ #:nar-size nar-size
+ #:time registration-time))))))
(let* ((prefix (format #f "registering ~a items" (length items)))
(progress (progress-reporter/bar (length items)
diff --git a/guix/ui.scm b/guix/ui.scm
index 5719a1d2e2..bca4c385f5 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -47,13 +47,15 @@
#:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (guix derivations)
- #:use-module (guix build-system)
+ #:autoload (guix build-system) (build-system-name)
#:use-module (guix serialization)
- #:use-module ((guix licenses)
- #:select (license? license-name license-uri))
- #:use-module ((guix build syscalls)
- #:select (free-disk-space terminal-columns terminal-rows
- with-file-lock/no-wait))
+ #:autoload (guix licenses) (license?
+ license-name
+ license-uri)
+ #:autoload (guix build syscalls) (free-disk-space
+ terminal-columns
+ terminal-rows
+ with-file-lock/no-wait)
#:use-module ((guix build utils)
;; XXX: All we need are the bindings related to
;; '&invoke-error'. However, to work around the bug described
@@ -1471,23 +1473,9 @@ converted to a space; sequences of more than one line break are preserved."
;;;
(define %text-width
- ;; '*line-width*' was introduced in Guile 2.2.7/3.0.1. On older versions of
- ;; Guile, monkey-patch 'wrap*' below.
- (if (defined? '*line-width*)
- (let ((parameter (fluid->parameter *line-width*)))
- (parameter (terminal-columns))
- parameter)
- (make-parameter (terminal-columns))))
-
-(unless (defined? '*line-width*) ;Guile < 2.2.7
- (set! (@@ (texinfo plain-text) wrap*)
- ;; XXX: Monkey patch this private procedure to let 'package->recutils'
- ;; parameterize the fill of description field correctly.
- (lambda strings
- (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
- (fill-string (string-concatenate strings)
- #:line-width (%text-width) #:initial-indent indent
- #:subsequent-indent indent)))))
+ ;; '*line-width*' was introduced in Guile 2.2.7/3.0.1. Keep this alias for
+ ;; backward-compatibility and for convenience.
+ (fluid->parameter *line-width*))
(define (texi->plain-text str)
"Return a plain-text representation of texinfo fragment STR."
@@ -1533,7 +1521,7 @@ followed by \"+ \", which makes for a valid multi-line field value in the
'()
str)))
-(define* (package->recutils p port #:optional (width (%text-width))
+(define* (package->recutils p port #:optional (width (terminal-columns))
#:key
(hyperlinks? (supports-hyperlinks? port))
(extra-fields '())
diff --git a/guix/utils.scm b/guix/utils.scm
index 29ad09d9f7..d8ce6ed886 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022, 2024 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>
@@ -47,11 +47,12 @@
#:use-module (rnrs io ports) ;need 'port-position' etc.
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix memoization)
- #:use-module ((guix build utils)
- #:select (dump-port mkdir-p delete-file-recursively
- call-with-temporary-output-file %xz-parallel-args))
- #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
- #:use-module ((guix combinators) #:select (fold2))
+ #:autoload (guix build utils) (dump-port
+ mkdir-p
+ delete-file-recursively
+ %xz-parallel-args)
+ #:autoload (guix build syscalls) (mkdtemp! fdatasync)
+ #:autoload (guix combinators) (fold2)
#:use-module (guix diagnostics) ;<location>, &error-location, etc.
#:use-module (ice-9 format)
#:use-module ((ice-9 iconv) #:prefix iconv:)
@@ -76,9 +77,7 @@
&fix-hint
fix-hint?
- condition-fix-hint
-
- call-with-temporary-output-file)
+ condition-fix-hint)
#:export (strip-keyword-arguments
default-keyword-arguments
substitute-keyword-arguments